git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility
   2
   3 ;; Copyright (C) 1998,1999,2000,2001,2002 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'alist)
  28
  29 (defconst unidata-normative-category-alist
  30   '(("Lu" letter        uppercase)
  31     ("Ll" letter        lowercase)
  32     ("Lt" letter        titlecase)
  33     ("Mn" mark          non-spacing)
  34     ("Mc" mark          spacing-combining)
  35     ("Me" mark          enclosing)
  36     ("Nd" number        decimal-digit)
  37     ("Nl" number        letter)
  38     ("No" number        other)
  39     ("Zs" separator     space)
  40     ("Zl" separator     line)
  41     ("Zp" separator     paragraph)
  42     ("Cc" other         control)
  43     ("Cf" other         format)
  44     ("Cs" other         surrogate)
  45     ("Co" other         private-use)
  46     ("Cn" other         not-assigned)))
  47
  48 (defconst unidata-informative-category-alist
  49   '(("Lm" letter        modifier)
  50     ("Lo" letter        other)
  51     ("Pc" punctuation   connector)
  52     ("Pd" punctuation   dash)
  53     ("Ps" punctuation   open)
  54     ("Pe" punctuation   close)
  55     ("Pi" punctuation   initial-quote)
  56     ("Pf" punctuation   final-quote)
  57     ("Po" punctuation   other)
  58     ("Sm" symbol        math)
  59     ("Sc" symbol        currency)
  60     ("Sk" symbol        modifier)
  61     ("So" symbol        other)
  62     ))
  63
  64 (defconst ideographic-radicals
  65   (let ((v (make-vector 215 nil))
  66         (i 1))
  67     (while (< i 215)
  68       (aset v i (decode-char 'ucs (+ #x2EFF i)))
  69       (setq i (1+ i)))
  70     ;; (unless (charset-iso-final-char (car (split-char (aref v 34))))
  71     ;;   (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
  72     v))
  73
  74 (defvar char-db-ignored-attributes nil)
  75
  76 (defun char-attribute-name< (ka kb)
  77   (cond
  78    ((find-charset ka)
  79     (cond
  80      ((find-charset kb)
  81       (cond
  82        ((= (charset-dimension ka)
  83            (charset-dimension kb))
  84         (cond ((= (charset-chars ka)(charset-chars kb))
  85                (if (charset-iso-final-char ka)
  86                    (cond
  87                     ((>= (charset-iso-final-char ka) ?@)
  88                      (if (and (charset-iso-final-char kb)
  89                               (>= (charset-iso-final-char kb) ?@))
  90                          (< (charset-iso-final-char ka)
  91                             (charset-iso-final-char kb))
  92                        t))
  93                     (t
  94                      (if (charset-iso-final-char kb)
  95                          (if (>= (charset-iso-final-char kb) ?@)
  96                              nil
  97                            (< (charset-iso-final-char ka)
  98                               (charset-iso-final-char kb)))
  99                        t)))
 100                  (if (charset-iso-final-char kb)
 101                      nil
 102                    (< (charset-id ka)(charset-id kb)))))
 103               ((<= (charset-chars ka)(charset-chars kb)))))
 104        (t
 105         (< (charset-dimension ka)
 106            (charset-dimension kb))
 107         )))
 108      ((symbolp kb)
 109       nil)
 110      (t
 111       t)))
 112    ((find-charset kb)
 113     t)
 114    ((symbolp ka)
 115     (cond ((symbolp kb)
 116            (string< (symbol-name ka)
 117                     (symbol-name kb)))
 118           (t)))
 119    ((symbolp kb)
 120     nil)))
 121
 122 (defvar char-db-coded-charset-priority-list
 123   (let ((rest default-coded-charset-priority-list)
 124         dest)
 125     (while rest
 126       (when (symbolp (car rest))
 127         (cond ((memq (car rest)
 128                      '(latin-viscii-lower
 129                        latin-viscii-upper
 130                        ipa
 131                        lao
 132                        ethiopic
 133                        arabic-digit
 134                        arabic-1-column
 135                        arabic-2-column)))
 136               ((string-match "^chinese-big5" (symbol-name (car rest))))
 137               ((string-match "^ideograph-gt-pj-" (symbol-name (car rest)))
 138                (unless (memq 'ideograph-gt dest)
 139                  (setq dest (cons 'ideograph-gt dest))))
 140               (t
 141                (setq dest (cons (car rest) dest)))))
 142       (setq rest (cdr rest)))
 143     (append (sort dest #'char-attribute-name<)
 144             '(chinese-big5-cdp chinese-big5-eten chinese-big5))))
 145
 146 (defun char-db-make-char-spec (char)
 147   (let (ret char-spec)
 148     (cond ((characterp char)
 149            (cond ((and (setq ret (get-char-attribute char 'ucs))
 150                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 151                   (setq char-spec (list (cons 'ucs ret)))
 152                   (if (setq ret (get-char-attribute char 'name))
 153                       (setq char-spec (cons (cons 'name ret) char-spec)))
 154                   )
 155                  ((setq ret
 156                         (let ((default-coded-charset-priority-list
 157                                 char-db-coded-charset-priority-list))
 158                           (split-char char)))
 159                   (setq char-spec (list ret))
 160                   (dolist (ccs (delq (car ret) (charset-list)))
 161                     (if (or (and (charset-iso-final-char ccs)
 162                                  (setq ret (get-char-attribute char ccs)))
 163                             (eq ccs 'ideograph-daikanwa))
 164                         (setq char-spec (cons (cons ccs ret) char-spec))))
 165                   (if (null char-spec)
 166                       (setq char-spec (split-char char)))
 167                   (if (setq ret (get-char-attribute char 'name))
 168                       (setq char-spec (cons (cons 'name ret) char-spec)))
 169                   ))
 170            char-spec)
 171           ((consp char)
 172            char))))
 173
 174 (defun char-db-insert-char-spec (char &optional readable column)
 175   (unless column
 176     (setq column (current-column)))
 177   (let (char-spec ret al cal key temp-char)
 178     (setq char-spec (char-db-make-char-spec char))
 179     ;; (cond ((characterp char)
 180     ;;        (cond ((and (setq ret (get-char-attribute char 'ucs))
 181     ;;                    (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 182     ;;               (setq char-spec (list (cons 'ucs ret)))
 183     ;;               (if (setq ret (get-char-attribute char 'name))
 184     ;;                   (setq char-spec (cons (cons 'name ret) char-spec)))
 185     ;;               )
 186     ;;              ((setq ret
 187     ;;                     (let ((default-coded-charset-priority-list
 188     ;;                             char-db-coded-charset-priority-list))
 189     ;;                       (split-char char)))
 190     ;;               (setq char-spec (list ret))
 191     ;;               (dolist (ccs (delq (car ret) (charset-list)))
 192     ;;                 (if (or (and (charset-iso-final-char ccs)
 193     ;;                              (setq ret (get-char-attribute char ccs)))
 194     ;;                         (eq ccs 'ideograph-daikanwa))
 195     ;;                     (setq char-spec (cons (cons ccs ret) char-spec))))
 196     ;;               (if (null char-spec)
 197     ;;                   (setq char-spec (split-char char)))
 198     ;;               (if (setq ret (get-char-attribute char 'name))
 199     ;;                   (setq char-spec (cons (cons 'name ret) char-spec)))
 200     ;;               )))
 201     ;;       ((consp char)
 202     ;;        (setq char-spec char)
 203     ;;        (setq char nil)))
 204     (unless (or (characterp char) ; char
 205                 (condition-case nil
 206                     (setq char (find-char char-spec))
 207                   (error nil)))
 208       ;; define temporary character
 209       ;;   Current implementation is dirty.
 210       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 211                                          char-spec)))
 212       (remove-char-attribute temp-char 'ideograph-daikanwa)
 213       (setq char temp-char))
 214     (setq al nil
 215           cal nil)
 216     (while char-spec
 217       (setq key (car (car char-spec)))
 218       (unless (memq key char-db-ignored-attributes)
 219         (if (find-charset key)
 220             (if (get-char-attribute char key)
 221                 (setq cal (cons key cal)))
 222           (setq al (cons key al))))
 223       (setq char-spec (cdr char-spec)))
 224     (unless cal
 225       (setq char-spec (char-db-make-char-spec char))
 226       (while char-spec
 227         (setq key (car (car char-spec)))
 228         (unless (memq key char-db-ignored-attributes)
 229           (if (find-charset key)
 230               (setq cal (cons key cal))
 231             (setq al (cons key al))))
 232         (setq char-spec (cdr char-spec)))
 233       )
 234     (unless (or cal
 235                 (memq 'ideographic-structure al))
 236       (push 'ideographic-structure al))
 237     (insert-char-attributes char
 238                             readable
 239                             (or al 'none) cal)
 240     (when temp-char
 241       ;; undefine temporary character
 242       ;;   Current implementation is dirty.
 243       (setq char-spec (char-attribute-alist temp-char))
 244       (while char-spec
 245         (remove-char-attribute temp-char (car (car char-spec)))
 246         (setq char-spec (cdr char-spec))))))
 247
 248 (defun char-db-insert-alist (alist &optional readable column)
 249   (unless column
 250     (setq column (current-column)))
 251   (let ((line-breaking
 252          (concat "\n" (make-string (1+ column) ?\ )))
 253         name value
 254         ret al cal key
 255         lbs cell rest separator)
 256     (insert "(")
 257     (while alist
 258       (setq name (car (car alist))
 259             value (cdr (car alist)))
 260       (cond ((eq name 'char)
 261              (insert "(char . ")
 262              (if (setq ret (condition-case nil
 263                                (find-char value)
 264                              (error nil)))
 265                  (progn
 266                    (setq al nil
 267                          cal nil)
 268                    (while value
 269                      (setq key (car (car value)))
 270                      (if (find-charset key)
 271                          (setq cal (cons key cal))
 272                        (setq al (cons key al)))
 273                      (setq value (cdr value)))
 274                    (insert-char-attributes ret
 275                                            readable
 276                                            (or al 'none) cal))
 277                (insert (prin1-to-string value)))
 278              (insert ")")
 279              (insert line-breaking))
 280             ((consp value)
 281              (insert (format "(%-18s " name))
 282              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 283              (while (consp value)
 284                (setq cell (car value))
 285                (if (and (consp cell)
 286                         (consp (car cell))
 287                         (setq ret (condition-case nil
 288                                       (find-char cell)
 289                                     (error nil)))
 290                         )
 291                    (progn
 292                      (setq rest cell
 293                            al nil
 294                            cal nil)
 295                      (while rest
 296                        (setq key (car (car rest)))
 297                        (if (find-charset key)
 298                            (setq cal (cons key cal))
 299                          (setq al (cons key al)))
 300                        (setq rest (cdr rest)))
 301                      (if separator
 302                          (insert lbs))
 303                      (insert-char-attributes ret
 304                                              readable
 305                                              al cal)
 306                      (setq separator lbs))
 307                  (if separator
 308                      (insert separator))
 309                  (insert (prin1-to-string cell))
 310                  (setq separator " "))
 311                (setq value (cdr value)))
 312              (insert ")")
 313              (insert line-breaking))
 314             (t
 315              (insert (format "(%-18s . %S)%s"
 316                              name value
 317                              line-breaking))))
 318       (setq alist (cdr alist))))
 319   (insert ")"))
 320
 321 (defun char-db-insert-char-reference (plist &optional readable column)
 322   (unless column
 323     (setq column (current-column)))
 324   (let ((line-breaking
 325          (concat "\n" (make-string (1+ column) ?\ )))
 326         (separator "")
 327         name value)
 328     (insert "(")
 329     (while plist
 330       (setq name (pop plist))
 331       (setq value (pop plist))
 332       (cond ((eq name :char)
 333              (insert separator)
 334              (insert ":char\t")
 335              (cond ((numberp value)
 336                     (setq value (decode-char 'ucs value)))
 337                    ;; ((consp value)
 338                    ;;  (setq value (or (find-char value)
 339                    ;;                  value)))
 340                    )
 341              (char-db-insert-char-spec value readable)
 342              (insert line-breaking)
 343              (setq separator ""))
 344             ((eq name :radical)
 345              (insert (format "%s%s\t%d ; %c%s"
 346                              separator
 347                              name value
 348                              (aref ideographic-radicals value)
 349                              line-breaking))
 350              (setq separator ""))
 351             (t
 352              (insert (format "%s%s\t%S" separator name value))
 353              (setq separator line-breaking)))
 354       ))
 355   (insert ")"))
 356
 357 (defun char-db-decode-isolated-char (ccs code-point)
 358   (let (ret)
 359     (setq ret
 360           (cond ((eq ccs 'arabic-iso8859-6)
 361                  (decode-char ccs code-point))
 362                 ((and (memq ccs '(ideograph-gt-pj-1
 363                                   ideograph-gt-pj-2
 364                                   ideograph-gt-pj-3
 365                                   ideograph-gt-pj-4
 366                                   ideograph-gt-pj-5
 367                                   ideograph-gt-pj-6
 368                                   ideograph-gt-pj-7
 369                                   ideograph-gt-pj-8
 370                                   ideograph-gt-pj-9
 371                                   ideograph-gt-pj-10
 372                                   ideograph-gt-pj-11))
 373                       (setq ret (decode-char ccs code-point))
 374                       (setq ret (get-char-attribute ret 'ideograph-gt)))
 375                  (decode-builtin-char 'ideograph-gt ret))
 376                 (t
 377                  (decode-builtin-char ccs code-point))))
 378     (cond ((and (<= 0 (char-int ret))
 379                 (<= (char-int ret) #x1F))
 380            (decode-char 'ucs (+ #x2400 (char-int ret))))
 381           ((= (char-int ret) #x7F)
 382            ?\u2421)
 383           (t ret))))
 384
 385 (defvar char-db-convert-obsolete-format t)
 386
 387 (defun insert-char-attributes (char &optional readable
 388                                     attributes ccs-attributes
 389                                     column)
 390   (let (atr-d ccs-d)
 391     (setq attributes
 392           (sort (if attributes
 393                     (if (consp attributes)
 394                         (progn
 395                           (dolist (name attributes)
 396                             (unless (memq name char-db-ignored-attributes)
 397                               (push name atr-d)))
 398                           atr-d))
 399                   (dolist (name (char-attribute-list))
 400                     (unless (memq name char-db-ignored-attributes)
 401                       (if (find-charset name)
 402                           (push name ccs-d)
 403                         (push name atr-d))))
 404                   atr-d)
 405                 #'char-attribute-name<))
 406     (setq ccs-attributes
 407           (sort (if ccs-attributes
 408                     (progn
 409                       (setq ccs-d nil)
 410                       (dolist (name ccs-attributes)
 411                         (unless (memq name char-db-ignored-attributes)
 412                           (push name ccs-d)))
 413                       ccs-d)
 414                   (or ccs-d
 415                       (progn
 416                         (dolist (name (charset-list))
 417                           (unless (memq name char-db-ignored-attributes)
 418                             (push name ccs-d)))
 419                         ccs-d)))
 420                 #'char-attribute-name<)))
 421   (unless column
 422     (setq column (current-column)))
 423   (let (name value has-long-ccs-name rest
 424         radical strokes
 425         (line-breaking
 426          (concat "\n" (make-string (1+ column) ?\ )))
 427         lbs cell separator ret
 428         key al cal)
 429     (insert "(")
 430     (when (and (memq 'name attributes)
 431                (setq value (get-char-attribute char 'name)))
 432       (insert (format
 433                (if (> (+ (current-column) (length value)) 48)
 434                    "(name . %S)%s"
 435                  "(name               . %S)%s")
 436                value line-breaking))
 437       (setq attributes (delq 'name attributes))
 438       )
 439     (when (and (memq 'script attributes)
 440                (setq value (get-char-attribute char 'script)))
 441       (insert (format "(script\t\t%s)%s"
 442                       (mapconcat (function prin1-to-string)
 443                                  value " ")
 444                       line-breaking))
 445       (setq attributes (delq 'script attributes))
 446       )
 447     (when (and (memq '=>ucs attributes)
 448                (setq value (get-char-attribute char '=>ucs)))
 449       (insert (format "(=>ucs\t\t. #x%04X)\t; %c%s"
 450                       value (decode-char 'ucs value)
 451                       line-breaking))
 452       (setq attributes (delq '=>ucs attributes))
 453       )
 454     (when (and (memq '=>ucs* attributes)
 455                (setq value (get-char-attribute char '=>ucs*)))
 456       (insert (format "(=>ucs*\t\t. #x%04X)\t; %c%s"
 457                       value (decode-char 'ucs value)
 458                       line-breaking))
 459       (setq attributes (delq '=>ucs* attributes))
 460       )
 461     (when (and (memq '=>ucs-gb attributes)
 462                (setq value (get-char-attribute char '=>ucs-gb)))
 463       (insert (format "(=>ucs-gb\t\t. #x%04X)\t; %c%s"
 464                       value (decode-char 'ucs value)
 465                       line-breaking))
 466       (setq attributes (delq '=>ucs-gb attributes))
 467       )
 468     (when (and (memq '=>ucs-cns attributes)
 469                (setq value (get-char-attribute char '=>ucs-cns)))
 470       (insert (format "(=>ucs-cns\t\t. #x%04X)\t; %c%s"
 471                       value (decode-char 'ucs-cns value)
 472                       line-breaking))
 473       (setq attributes (delq '=>ucs-cns attributes))
 474       )
 475     (when (and (memq '=>ucs-jis attributes)
 476                (setq value (get-char-attribute char '=>ucs-jis)))
 477       (insert (format "(=>ucs-jis\t\t. #x%04X)\t; %c%s"
 478                       value (decode-char 'ucs-jis value)
 479                       line-breaking))
 480       (setq attributes (delq '=>ucs-jis attributes))
 481       )
 482     (when (and (memq '=>ucs-ks attributes)
 483                (setq value (get-char-attribute char '=>ucs-ks)))
 484       (insert (format "(=>ucs-ks\t\t. #x%04X)\t; %c%s"
 485                       value (decode-char 'ucs-ks value)
 486                       line-breaking))
 487       (setq attributes (delq '=>ucs-ks attributes))
 488       )
 489     (when (and (memq '->ucs attributes)
 490                (setq value (get-char-attribute char '->ucs)))
 491       (insert (format (if char-db-convert-obsolete-format
 492                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 493                         "(->ucs\t\t. #x%04X)\t; %c%s")
 494                       value (decode-char 'ucs value)
 495                       line-breaking))
 496       (setq attributes (delq '->ucs attributes))
 497       )
 498     (when (and (memq 'general-category attributes)
 499                (setq value (get-char-attribute char 'general-category)))
 500       (insert (format
 501                "(general-category\t%s) ; %s%s"
 502                (mapconcat (lambda (cell)
 503                             (format "%S" cell))
 504                           value " ")
 505                (cond ((rassoc value unidata-normative-category-alist)
 506                       "Normative Category")
 507                      ((rassoc value unidata-informative-category-alist)
 508                       "Informative Category")
 509                      (t
 510                       "Unknown Category"))
 511                line-breaking))
 512       (setq attributes (delq 'general-category attributes))
 513       )
 514     (when (and (memq 'bidi-category attributes)
 515                (setq value (get-char-attribute char 'bidi-category)))
 516       (insert (format "(bidi-category\t. %S)%s"
 517                       value
 518                       line-breaking))
 519       (setq attributes (delq 'bidi-category attributes))
 520       )
 521     (unless (or (not (memq 'mirrored attributes))
 522                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 523                     'empty))
 524       (insert (format "(mirrored\t\t. %S)%s"
 525                       value
 526                       line-breaking))
 527       (setq attributes (delq 'mirrored attributes))
 528       )
 529     (cond
 530      ((and (memq 'decimal-digit-value attributes)
 531            (setq value (get-char-attribute char 'decimal-digit-value)))
 532       (insert (format "(decimal-digit-value . %S)%s"
 533                       value
 534                       line-breaking))
 535       (setq attributes (delq 'decimal-digit-value attributes))
 536       (when (and (memq 'digit-value attributes)
 537                  (setq value (get-char-attribute char 'digit-value)))
 538         (insert (format "(digit-value\t . %S)%s"
 539                         value
 540                         line-breaking))
 541         (setq attributes (delq 'digit-value attributes))
 542         )
 543       (when (and (memq 'numeric-value attributes)
 544                  (setq value (get-char-attribute char 'numeric-value)))
 545         (insert (format "(numeric-value\t . %S)%s"
 546                         value
 547                         line-breaking))
 548         (setq attributes (delq 'numeric-value attributes))
 549         )
 550       )
 551      (t
 552       (when (and (memq 'digit-value attributes)
 553                  (setq value (get-char-attribute char 'digit-value)))
 554         (insert (format "(digit-value\t. %S)%s"
 555                         value
 556                         line-breaking))
 557         (setq attributes (delq 'digit-value attributes))
 558         )
 559       (when (and (memq 'numeric-value attributes)
 560                  (setq value (get-char-attribute char 'numeric-value)))
 561         (insert (format "(numeric-value\t. %S)%s"
 562                         value
 563                         line-breaking))
 564         (setq attributes (delq 'numeric-value attributes))
 565         )))
 566     (when (and (memq 'iso-10646-comment attributes)
 567                (setq value (get-char-attribute char 'iso-10646-comment)))
 568       (insert (format "(iso-10646-comment\t. %S)%s"
 569                       value
 570                       line-breaking))
 571       (setq attributes (delq 'iso-10646-comment attributes))
 572       )
 573     (when (and (memq 'morohashi-daikanwa attributes)
 574                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 575       (insert (format "(morohashi-daikanwa\t%s)%s"
 576                       (mapconcat (function prin1-to-string) value " ")
 577                       line-breaking))
 578       (setq attributes (delq 'morohashi-daikanwa attributes))
 579       )
 580     (setq radical nil
 581           strokes nil)
 582     (when (and (memq 'ideographic-radical attributes)
 583                (setq value (get-char-attribute char 'ideographic-radical)))
 584       (setq radical value)
 585       (insert (format "(ideographic-radical . %S)\t; %c%s"
 586                       radical
 587                       (aref ideographic-radicals radical)
 588                       line-breaking))
 589       (setq attributes (delq 'ideographic-radical attributes))
 590       )
 591     (when (and (memq 'ideographic-strokes attributes)
 592                (setq value (get-char-attribute char 'ideographic-strokes)))
 593       (setq strokes value)
 594       (insert (format "(ideographic-strokes . %S)%s"
 595                       strokes
 596                       line-breaking))
 597       (setq attributes (delq 'ideographic-strokes attributes))
 598       )
 599     (when (and (memq 'kangxi-radical attributes)
 600                (setq value (get-char-attribute char 'kangxi-radical)))
 601       (unless (eq value radical)
 602         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 603                         value
 604                         (aref ideographic-radicals value)
 605                         line-breaking))
 606         (or radical
 607             (setq radical value)))
 608       (setq attributes (delq 'kangxi-radical attributes))
 609       )
 610     (when (and (memq 'kangxi-strokes attributes)
 611                (setq value (get-char-attribute char 'kangxi-strokes)))
 612       (unless (eq value strokes)
 613         (insert (format "(kangxi-strokes\t . %S)%s"
 614                         value
 615                         line-breaking))
 616         (or strokes
 617             (setq strokes value)))
 618       (setq attributes (delq 'kangxi-strokes attributes))
 619       )
 620     (when (and (memq 'japanese-radical attributes)
 621                (setq value (get-char-attribute char 'japanese-radical)))
 622       (unless (eq value radical)
 623         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 624                         value
 625                         (aref ideographic-radicals value)
 626                         line-breaking))
 627         (or radical
 628             (setq radical value)))
 629       (setq attributes (delq 'japanese-radical attributes))
 630       )
 631     (when (and (memq 'japanese-strokes attributes)
 632                (setq value (get-char-attribute char 'japanese-strokes)))
 633       (unless (eq value strokes)
 634         (insert (format "(japanese-strokes\t . %S)%s"
 635                         value
 636                         line-breaking))
 637         (or strokes
 638             (setq strokes value)))
 639       (setq attributes (delq 'japanese-strokes attributes))
 640       )
 641     (when (and (memq 'cns-radical attributes)
 642                (setq value (get-char-attribute char 'cns-radical)))
 643       (insert (format "(cns-radical\t . %S)\t; %c%s"
 644                       value
 645                       (aref ideographic-radicals value)
 646                       line-breaking))
 647       (setq attributes (delq 'cns-radical attributes))
 648       )
 649     (when (and (memq 'cns-strokes attributes)
 650                (setq value (get-char-attribute char 'cns-strokes)))
 651       (unless (eq value strokes)
 652         (insert (format "(cns-strokes\t . %S)%s"
 653                         value
 654                         line-breaking))
 655         (or strokes
 656             (setq strokes value)))
 657       (setq attributes (delq 'cns-strokes attributes))
 658       )
 659     (when (and (memq 'shinjigen-1-radical attributes)
 660                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 661       (unless (eq value radical)
 662         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 663                         value
 664                         (aref ideographic-radicals value)
 665                         line-breaking))
 666         (or radical
 667             (setq radical value)))
 668       (setq attributes (delq 'shinjigen-1-radical attributes))
 669       )
 670     (when (and (memq 'ideographic- attributes)
 671                (setq value (get-char-attribute char 'ideographic-)))
 672       (insert "(ideographic-       ")
 673       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 674             separator nil)
 675       (while (consp value)
 676         (setq cell (car value))
 677         (if (integerp cell)
 678             (setq cell (decode-char 'ucs cell)))
 679         (cond ((characterp cell)
 680                (if separator
 681                    (insert lbs))
 682                (if readable
 683                    (insert (format "%S" cell))
 684                  (char-db-insert-char-spec cell readable))
 685                (setq separator lbs))
 686               ((consp cell)
 687                (if separator
 688                    (insert lbs))
 689                (if (consp (car cell))
 690                    (char-db-insert-char-spec cell readable)
 691                  (char-db-insert-char-reference cell readable))
 692                (setq separator lbs))
 693               (t
 694                (if separator
 695                    (insert separator))
 696                (insert (prin1-to-string cell))
 697                (setq separator " ")))
 698         (setq value (cdr value)))
 699       (insert ")")
 700       (insert line-breaking)
 701       (setq attributes (delq 'ideographic- attributes)))
 702     (when (and (memq 'total-strokes attributes)
 703                (setq value (get-char-attribute char 'total-strokes)))
 704       (insert (format "(total-strokes       . %S)%s"
 705                       value
 706                       line-breaking))
 707       (setq attributes (delq 'total-strokes attributes))
 708       )
 709     (when (and (memq '->ideograph attributes)
 710                (setq value (get-char-attribute char '->ideograph)))
 711       (insert (format "(->ideograph\t%s)%s"
 712                       (mapconcat (lambda (code)
 713                                    (cond ((symbolp code)
 714                                           (symbol-name code))
 715                                          ((integerp code)
 716                                           (format "#x%04X" code))
 717                                          (t
 718                                           (format "%s %S"
 719                                                   line-breaking code))))
 720                                  value " ")
 721                       line-breaking))
 722       (setq attributes (delq '->ideograph attributes))
 723       )
 724     (when (and (memq '->decomposition attributes)
 725                (setq value (get-char-attribute char '->decomposition)))
 726       (insert (format "(->decomposition\t%s)%s"
 727                       (mapconcat (lambda (code)
 728                                    (cond ((symbolp code)
 729                                           (symbol-name code))
 730                                          ((characterp code)
 731                                           (if readable
 732                                               (format "%S" code)
 733                                             (format "#x%04X"
 734                                                     (char-int code))
 735                                             ))
 736                                          ((integerp code)
 737                                           (format "#x%04X" code))
 738                                          (t
 739                                           (format "%s%S" line-breaking code))))
 740                                  value " ")
 741                       line-breaking))
 742       (setq attributes (delq '->decomposition attributes))
 743       )
 744     (if (equal (get-char-attribute char '->titlecase)
 745                (get-char-attribute char '->uppercase))
 746         (setq attributes (delq '->titlecase attributes)))
 747     (when (and (memq '->mojikyo attributes)
 748                (setq value (get-char-attribute char '->mojikyo)))
 749       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 750                       value (decode-char 'mojikyo value)
 751                       line-breaking))
 752       (setq attributes (delq '->mojikyo attributes))
 753       )
 754     (when (and (memq 'hanyu-dazidian-vol attributes)
 755                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 756       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 757                       value line-breaking))
 758       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 759       )
 760     (when (and (memq 'hanyu-dazidian-page attributes)
 761                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 762       (insert (format "(hanyu-dazidian-page . %d)%s"
 763                       value line-breaking))
 764       (setq attributes (delq 'hanyu-dazidian-page attributes))
 765       )
 766     (when (and (memq 'hanyu-dazidian-char attributes)
 767                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 768       (insert (format "(hanyu-dazidian-char . %d)%s"
 769                       value line-breaking))
 770       (setq attributes (delq 'hanyu-dazidian-char attributes))
 771       )
 772     (unless readable
 773       (when (memq '->ucs-variants attributes)
 774         (setq attributes (delq '->ucs-variants attributes))
 775         )
 776       (when (memq 'composition attributes)
 777         (setq attributes (delq 'composition attributes))
 778         ))
 779     (setq rest ccs-attributes)
 780     (while (and rest
 781                 (progn
 782                   (setq value (get-char-attribute char (car rest)))
 783                   (if value
 784                       (if (>= (length (symbol-name (car rest))) 19)
 785                           (progn
 786                             (setq has-long-ccs-name t)
 787                             nil)
 788                         t)
 789                     t)))
 790       (setq rest (cdr rest)))
 791     (while attributes
 792       (setq name (car attributes))
 793       (if (setq value (get-char-attribute char name))
 794           (cond ((eq name 'jisx0208-1978/4X)
 795                  (insert (format "(%-18s . #x%04X)%s"
 796                                  name value
 797                                  line-breaking)))
 798                 ((or (eq name 'ideographic-structure)
 799                      (eq name 'ideographic-)
 800                      (string-match "^\\(->\\|<-\\)" (symbol-name name)))
 801                  (insert (format "(%-18s%s " name line-breaking))
 802                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 803                        separator nil)
 804                  (while (consp value)
 805                    (setq cell (car value))
 806                    (if (integerp cell)
 807                        (setq cell (decode-char 'ucs cell)))
 808                    (cond ((characterp cell)
 809                           (if separator
 810                               (insert lbs))
 811                           (if readable
 812                               (insert (format "%S" cell))
 813                             (char-db-insert-char-spec cell readable))
 814                           (setq separator lbs))
 815                          ((consp cell)
 816                           (if separator
 817                               (insert lbs))
 818                           (if (consp (car cell))
 819                               (char-db-insert-char-spec cell readable)
 820                             (char-db-insert-char-reference cell readable))
 821                           (setq separator lbs))
 822                          (t
 823                           (if separator
 824                               (insert separator))
 825                           (insert (prin1-to-string cell))
 826                           (setq separator " ")))
 827                    (setq value (cdr value)))
 828                  (insert ")")
 829                  (insert line-breaking))
 830                 ((memq name '(ideograph=
 831                               original-ideograph-of
 832                               ancient-ideograph-of
 833                               vulgar-ideograph-of
 834                               wrong-ideograph-of
 835                               simplified-ideograph-of
 836                               ideographic-variants
 837                               ideographic-different-form-of))
 838                  (insert (format "(%-18s%s " name line-breaking))
 839                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 840                        separator nil)
 841                  (while (consp value)
 842                    (setq cell (car value))
 843                    (if (and (consp cell)
 844                             (consp (car cell)))
 845                        (progn
 846                          (if separator
 847                              (insert lbs))
 848                          (char-db-insert-alist cell readable)
 849                          (setq separator lbs))
 850                      (if separator
 851                          (insert separator))
 852                      (insert (prin1-to-string cell))
 853                      (setq separator " "))
 854                    (setq value (cdr value)))
 855                  (insert ")")
 856                  (insert line-breaking))
 857                 ;; ((string-match "^->" (symbol-name name))
 858                 ;;  (insert
 859                 ;;   (format "(%-18s %s)%s"
 860                 ;;           name
 861                 ;;           (mapconcat (lambda (code)
 862                 ;;                        (cond ((symbolp code)
 863                 ;;                               (symbol-name code))
 864                 ;;                              ((integerp code)
 865                 ;;                               (format "#x%04X" code))
 866                 ;;                              (t
 867                 ;;                               (format "%s%S"
 868                 ;;                                       line-breaking code))))
 869                 ;;                      value " ")
 870                 ;;           line-breaking)))
 871                 ((consp value)
 872                  (insert (format "(%-18s " name))
 873                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 874                        separator nil)
 875                  (while (consp value)
 876                    (setq cell (car value))
 877                    (if (and (consp cell)
 878                             (consp (car cell))
 879                             (setq ret (condition-case nil
 880                                           (find-char cell)
 881                                         (error nil))))
 882                        (progn
 883                          (setq rest cell
 884                                al nil
 885                                cal nil)
 886                          (while rest
 887                            (setq key (car (car rest)))
 888                            (if (find-charset key)
 889                                (setq cal (cons key cal))
 890                              (setq al (cons key al)))
 891                            (setq rest (cdr rest)))
 892                          (if separator
 893                              (insert lbs))
 894                          (insert-char-attributes ret
 895                                                  readable
 896                                                  al cal)
 897                          (setq separator lbs))
 898                      (if separator
 899                          (insert separator))
 900                      (insert (prin1-to-string cell))
 901                      (setq separator " "))
 902                    (setq value (cdr value)))
 903                  (insert ")")
 904                  (insert line-breaking))
 905                 (t
 906                  (insert (format "(%-18s . %S)%s"
 907                                  name value
 908                                  line-breaking)))
 909                 ))
 910       (setq attributes (cdr attributes)))
 911     (while ccs-attributes
 912       (setq name (car ccs-attributes))
 913       (if (and (eq name (charset-name name))
 914                (setq value (get-char-attribute char name)))
 915           (insert
 916            (format
 917             (cond ((memq name '(ideograph-daikanwa-2
 918                                 ideograph-daikanwa
 919                                 ideograph-gt
 920                                 ideograph-gt-k
 921                                 ideograph-cbeta))
 922                    (if has-long-ccs-name
 923                        "(%-26s . %05d)\t; %c%s"
 924                      "(%-18s . %05d)\t; %c%s"))
 925                   ((eq name 'mojikyo)
 926                    (if has-long-ccs-name
 927                        "(%-26s . %06d)\t; %c%s"
 928                      "(%-18s . %06d)\t; %c%s"))
 929                   ((>= (charset-dimension name) 2) ; (eq name 'ucs)
 930                    (if has-long-ccs-name
 931                        "(%-26s . #x%04X)\t; %c%s"
 932                      "(%-18s . #x%04X)\t; %c%s"))
 933                   (t
 934                    (if has-long-ccs-name
 935                        "(%-26s . #x%02X)\t; %c%s"
 936                      "(%-18s . #x%02X)\t; %c%s")))
 937             name
 938             (if (= (charset-iso-graphic-plane name) 1)
 939                 (logior value
 940                         (cond ((= (charset-dimension name) 1)
 941                                #x80)
 942                               ((= (charset-dimension name) 2)
 943                                #x8080)
 944                               ((= (charset-dimension name) 3)
 945                                #x808080)
 946                               (t 0)))
 947               value)
 948             (char-db-decode-isolated-char name value)
 949             line-breaking)))
 950       (setq ccs-attributes (cdr ccs-attributes)))
 951     (insert ")")))
 952
 953 (defun insert-char-data (char &optional readable
 954                               attributes ccs-attributes)
 955   (save-restriction
 956     (narrow-to-region (point)(point))
 957     (insert "(define-char
 958   '")
 959     (insert-char-attributes char readable
 960                             attributes ccs-attributes)
 961     (insert ")\n")
 962     (goto-char (point-min))
 963     (while (re-search-forward "[ \t]+$" nil t)
 964       (replace-match ""))
 965     (goto-char (point-max))
 966     (tabify (point-min)(point-max))
 967     ))
 968
 969 (defun insert-char-data-with-variant (char &optional printable
 970                                            no-ucs-variant
 971                                            script excluded-script)
 972   (insert-char-data char printable)
 973   (let ((variants (or (char-variants char)
 974                       (let ((ucs (get-char-attribute char '->ucs)))
 975                         (if ucs
 976                             (delete char (char-variants (int-char ucs)))))))
 977         variant vs)
 978     (setq variants (sort variants #'<))
 979     (while variants
 980       (setq variant (car variants))
 981       (if (and (or (null script)
 982                    (null (setq vs (get-char-attribute variant 'script)))
 983                    (memq script vs))
 984                (or (null excluded-script)
 985                    (null (setq vs (get-char-attribute variant 'script)))
 986                    (not (memq excluded-script vs))))
 987           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 988               (insert-char-data variant printable)))
 989       (setq variants (cdr variants))
 990       )))
 991
 992 (defun insert-char-range-data (min max &optional script excluded-script)
 993   (let ((code min)
 994         char)
 995     (while (<= code max)
 996       (setq char (decode-char 'ucs code))
 997       (if (get-char-attribute char 'ucs)
 998           (insert-char-data-with-variant char nil 'no-ucs-variant
 999                                          script excluded-script))
1000       (setq code (1+ code))
1001       )))
1002
1003 (defun write-char-range-data-to-file (min max file
1004                                           &optional script excluded-script)
1005   (let ((coding-system-for-write 'utf-8))
1006     (with-temp-buffer
1007       (insert-char-range-data min max script excluded-script)
1008       (write-region (point-min)(point-max) file))))
1009
1010 (defvar what-character-original-window-configuration)
1011
1012 ;;;###autoload
1013 (defun what-char-definition (char)
1014   (interactive (list (char-after)))
1015   (let ((buf (get-buffer-create "*Character Description*"))
1016         (the-buf (current-buffer))
1017         (win-conf (current-window-configuration)))
1018     (pop-to-buffer buf)
1019     (make-local-variable 'what-character-original-window-configuration)
1020     (setq what-character-original-window-configuration win-conf)
1021     (setq buffer-read-only nil)
1022     (erase-buffer)
1023     (condition-case err
1024         (progn
1025           (insert-char-data-with-variant char 'printable)
1026           (unless (char-attribute-alist char)
1027             (insert (format ";; = %c\n"
1028                             (let* ((rest (split-char char))
1029                                    (ccs (pop rest))
1030                                    (code (pop rest)))
1031                               (while rest
1032                                 (setq code (logior (lsh code 8)
1033                                                    (pop rest))))
1034                               (decode-char ccs code)))))
1035           ;; (char-db-update-comment)
1036           (set-buffer-modified-p nil)
1037           (view-mode the-buf (lambda (buf)
1038                                (set-window-configuration
1039                                 what-character-original-window-configuration)
1040                                ))
1041           (goto-char (point-min)))
1042       (error (progn
1043                (set-window-configuration
1044                 what-character-original-window-configuration)
1045                (signal (car err) (cdr err)))))))
1046
1047 (provide 'char-db-util)
1048
1049 ;;; char-db-util.el ends here