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,2003,2004 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs CHISE.
   9
  10 ;; XEmacs CHISE 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 CHISE 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 CHISE; 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     v))
  71
  72 (defvar char-db-feature-domains
  73   '(ucs daikanwa cns gt jis jis/alt jis/a jis/b
  74         jis-x0213 misc unknown))
  75
  76 (defvar char-db-ignored-attributes nil)
  77
  78 ;;;###autoload
  79 (defun char-ref= (cr1 cr2)
  80   (cond ((char-ref-p cr1)
  81          (if (char-ref-p cr2)
  82              (char-spec= (plist-get cr1 :char)
  83                          (plist-get cr2 :char))
  84            (char-spec= (plist-get cr1 :char) cr2)))
  85         (t
  86          (char-spec= cr1
  87                      (if (char-ref-p cr2)
  88                          (plist-get cr2 :char)
  89                        cr2)))))
  90
  91 ;;;###autoload
  92 (defun char-spec= (cs1 cs2)
  93   (if (characterp cs1)
  94       (if (characterp cs2)
  95           (eq cs1 cs2)
  96         (eq cs1 (find-char cs2)))
  97     (if (characterp cs2)
  98         (eq (find-char cs1) cs2)
  99       (eq (find-char cs1) (find-char cs2)))))
 100
 101 (defun char-attribute-name< (ka kb)
 102   (cond
 103    ((find-charset ka)
 104     (cond
 105      ((find-charset kb)
 106       (if (<= (charset-id ka) 0)
 107           (if (<= (charset-id kb) 0)
 108               (cond
 109                ((= (charset-dimension ka)
 110                    (charset-dimension kb))
 111                 (> (charset-id ka)(charset-id kb)))
 112                (t
 113                 (> (charset-dimension ka)
 114                    (charset-dimension kb))
 115                 ))
 116             t)
 117         (if (<= (charset-id kb) 0)
 118             nil
 119           (< (charset-id ka)(charset-id kb)))))
 120      ((symbolp kb)
 121       nil)
 122      (t
 123       t)))
 124    ((find-charset kb)
 125     t)
 126    ((symbolp ka)
 127     (cond ((symbolp kb)
 128            (string< (symbol-name ka)
 129                     (symbol-name kb)))
 130           (t)))
 131    ((symbolp kb)
 132     nil)))
 133
 134 (defvar char-db-coded-charset-priority-list
 135   '(ascii
 136     control-1
 137     latin-iso8859-1
 138     latin-iso8859-2
 139     latin-iso8859-3
 140     latin-iso8859-4
 141     latin-iso8859-9
 142     latin-jisx0201
 143     cyrillic-iso8859-5
 144     greek-iso8859-7
 145     thai-tis620
 146     =jis-x0208
 147     japanese-jisx0208
 148     japanese-jisx0212
 149     japanese-jisx0208-1978
 150     chinese-gb2312
 151     chinese-cns11643-1
 152     chinese-cns11643-2
 153     chinese-cns11643-3
 154     chinese-cns11643-4
 155     chinese-cns11643-5
 156     chinese-cns11643-6
 157     chinese-cns11643-7
 158     =jis-x0208-1990
 159     =jis-x0213-1-2000
 160     =jis-x0213-2-2000
 161     korean-ksc5601
 162     chinese-isoir165
 163     katakana-jisx0201
 164     hebrew-iso8859-8
 165     chinese-gb12345
 166     latin-viscii
 167     ethiopic-ucs
 168     =big5-cdp
 169     =gt
 170     ideograph-daikanwa-2
 171     ideograph-daikanwa
 172     =cbeta
 173     ideograph-hanziku-1
 174     ideograph-hanziku-2
 175     ideograph-hanziku-3
 176     ideograph-hanziku-4
 177     ideograph-hanziku-5
 178     ideograph-hanziku-6
 179     ideograph-hanziku-7
 180     ideograph-hanziku-8
 181     ideograph-hanziku-9
 182     ideograph-hanziku-10
 183     ideograph-hanziku-11
 184     ideograph-hanziku-12
 185     =big5
 186     =big5-eten
 187     =gt-k
 188     =jef-china3))
 189
 190 (defun char-db-make-char-spec (char)
 191   (let (ret char-spec)
 192     (cond ((characterp char)
 193            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 194                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 195                   (setq char-spec (list (cons '=ucs ret)))
 196                   (cond ((setq ret (get-char-attribute char 'name))
 197                          (setq char-spec (cons (cons 'name ret) char-spec))
 198                          )
 199                         ((setq ret (get-char-attribute char 'name*))
 200                          (setq char-spec (cons (cons 'name* ret) char-spec))
 201                          ))
 202                   )
 203                  ((setq ret
 204                         (catch 'tag
 205                           (let ((rest char-db-coded-charset-priority-list)
 206                                 ccs)
 207                             (while rest
 208                               (setq ccs (charset-name
 209                                          (find-charset (car rest))))
 210                               (if (setq ret
 211                                         (encode-char char ccs
 212                                                      'defined-only))
 213                                   (throw 'tag (cons ccs ret)))
 214                               (setq rest (cdr rest))))))
 215                   (setq char-spec (list ret))
 216                   (dolist (ccs (delq (car ret) (charset-list)))
 217                     (if (and (or (charset-iso-final-char ccs)
 218                                  (memq ccs
 219                                        '(ideograph-daikanwa
 220                                          =daikanwa-rev2
 221                                          ;; =gt-k
 222                                          )))
 223                              (setq ret (encode-char char ccs 'defined-only)))
 224                         (setq char-spec (cons (cons ccs ret) char-spec))))
 225                   (if (null char-spec)
 226                       (setq char-spec (split-char char)))
 227                   (cond ((setq ret (get-char-attribute char 'name))
 228                          (setq char-spec (cons (cons 'name ret) char-spec))
 229                          )
 230                         ((setq ret (get-char-attribute char 'name*))
 231                          (setq char-spec (cons (cons 'name* ret) char-spec))
 232                          ))
 233                   ))
 234            char-spec)
 235           ((consp char)
 236            char))))
 237
 238 (defun char-db-insert-char-spec (char &optional readable column
 239                                       required-features)
 240   (unless column
 241     (setq column (current-column)))
 242   (let (char-spec al cal key temp-char)
 243     (setq char-spec (char-db-make-char-spec char))
 244     (unless (or (characterp char) ; char
 245                 (condition-case nil
 246                     (setq char (find-char char-spec))
 247                   (error nil)))
 248       ;; define temporary character
 249       ;;   Current implementation is dirty.
 250       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 251                                          char-spec)))
 252       (remove-char-attribute temp-char 'ideograph-daikanwa)
 253       (setq char temp-char))
 254     (setq al nil
 255           cal nil)
 256     (while char-spec
 257       (setq key (car (car char-spec)))
 258       (unless (memq key char-db-ignored-attributes)
 259         (if (find-charset key)
 260             (if (encode-char char key 'defined-only)
 261                 (setq cal (cons key cal)))
 262           (setq al (cons key al))))
 263       (setq char-spec (cdr char-spec)))
 264     (unless cal
 265       (setq char-spec (char-db-make-char-spec char))
 266       (while char-spec
 267         (setq key (car (car char-spec)))
 268         (unless (memq key char-db-ignored-attributes)
 269           (if (find-charset key)
 270               (setq cal (cons key cal))
 271             (setq al (cons key al))))
 272         (setq char-spec (cdr char-spec)))
 273       )
 274     (unless (or cal
 275                 (memq 'ideographic-structure al))
 276       (push 'ideographic-structure al))
 277     (dolist (feature required-features)
 278       (if (find-charset feature)
 279           (if (encode-char char feature 'defined-only)
 280               (setq cal (adjoin feature cal)))
 281         (setq al (adjoin feature al))))
 282     (insert-char-attributes char
 283                             readable
 284                             (or al 'none) cal)
 285     (when temp-char
 286       ;; undefine temporary character
 287       ;;   Current implementation is dirty.
 288       (setq char-spec (char-attribute-alist temp-char))
 289       (while char-spec
 290         (remove-char-attribute temp-char (car (car char-spec)))
 291         (setq char-spec (cdr char-spec))))))
 292
 293 (defun char-db-insert-alist (alist &optional readable column)
 294   (unless column
 295     (setq column (current-column)))
 296   (let ((line-breaking
 297          (concat "\n" (make-string (1+ column) ?\ )))
 298         name value
 299         ret al cal key
 300         lbs cell rest separator)
 301     (insert "(")
 302     (while alist
 303       (setq name (car (car alist))
 304             value (cdr (car alist)))
 305       (cond ((eq name 'char)
 306              (insert "(char . ")
 307              (if (setq ret (condition-case nil
 308                                (find-char value)
 309                              (error nil)))
 310                  (progn
 311                    (setq al nil
 312                          cal nil)
 313                    (while value
 314                      (setq key (car (car value)))
 315                      (if (find-charset key)
 316                          (setq cal (cons key cal))
 317                        (setq al (cons key al)))
 318                      (setq value (cdr value)))
 319                    (insert-char-attributes ret
 320                                            readable
 321                                            (or al 'none) cal))
 322                (insert (prin1-to-string value)))
 323              (insert ")")
 324              (insert line-breaking))
 325             ((consp value)
 326              (insert (format "(%-18s " name))
 327              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 328              (while (consp value)
 329                (setq cell (car value))
 330                (if (and (consp cell)
 331                         (consp (car cell))
 332                         (setq ret (condition-case nil
 333                                       (find-char cell)
 334                                     (error nil)))
 335                         )
 336                    (progn
 337                      (setq rest cell
 338                            al nil
 339                            cal nil)
 340                      (while rest
 341                        (setq key (car (car rest)))
 342                        (if (find-charset key)
 343                            (setq cal (cons key cal))
 344                          (setq al (cons key al)))
 345                        (setq rest (cdr rest)))
 346                      (if separator
 347                          (insert lbs))
 348                      (insert-char-attributes ret
 349                                              readable
 350                                              al cal)
 351                      (setq separator lbs))
 352                  (if separator
 353                      (insert separator))
 354                  (insert (prin1-to-string cell))
 355                  (setq separator " "))
 356                (setq value (cdr value)))
 357              (insert ")")
 358              (insert line-breaking))
 359             (t
 360              (insert (format "(%-18s . %S)%s"
 361                              name value
 362                              line-breaking))))
 363       (setq alist (cdr alist))))
 364   (insert ")"))
 365
 366 (defun char-db-insert-char-reference (plist &optional readable column)
 367   (unless column
 368     (setq column (current-column)))
 369   (let ((line-breaking
 370          (concat "\n" (make-string (1+ column) ?\ )))
 371         (separator "")
 372         name value)
 373     (insert "(")
 374     (while plist
 375       (setq name (pop plist))
 376       (setq value (pop plist))
 377       (cond ((eq name :char)
 378              (insert separator)
 379              (insert ":char\t")
 380              (cond ((numberp value)
 381                     (setq value (decode-char '=ucs value)))
 382                    ;; ((consp value)
 383                    ;;  (setq value (or (find-char value)
 384                    ;;                  value)))
 385                    )
 386              (char-db-insert-char-spec value readable)
 387              (insert line-breaking)
 388              (setq separator ""))
 389             ((eq name :radical)
 390              (insert (format "%s%s\t%d ; %c%s"
 391                              separator
 392                              name value
 393                              (aref ideographic-radicals value)
 394                              line-breaking))
 395              (setq separator ""))
 396             (t
 397              (insert (format "%s%s\t%S" separator name value))
 398              (setq separator line-breaking)))
 399       ))
 400   (insert ")"))
 401
 402 (defun char-db-decode-isolated-char (ccs code-point)
 403   (let (ret)
 404     (setq ret
 405           (cond ((eq ccs 'arabic-iso8859-6)
 406                  (decode-char ccs code-point))
 407                 ((and (memq ccs '(=gt-pj-1
 408                                   =gt-pj-2
 409                                   =gt-pj-3
 410                                   =gt-pj-4
 411                                   =gt-pj-5
 412                                   =gt-pj-6
 413                                   =gt-pj-7
 414                                   =gt-pj-8
 415                                   =gt-pj-9
 416                                   =gt-pj-10
 417                                   =gt-pj-11))
 418                       (setq ret (decode-char ccs code-point))
 419                       (setq ret (encode-char ret '=gt 'defined-only)))
 420                  (decode-builtin-char '=gt ret))
 421                 (t
 422                  (decode-builtin-char ccs code-point))))
 423     (cond ((and (<= 0 (char-int ret))
 424                 (<= (char-int ret) #x1F))
 425            (decode-char '=ucs (+ #x2400 (char-int ret))))
 426           ((= (char-int ret) #x7F)
 427            ?\u2421)
 428           (t ret))))
 429
 430 (defvar char-db-convert-obsolete-format t)
 431
 432 (defun insert-char-attributes (char &optional readable
 433                                     attributes ccs-attributes
 434                                     column)
 435   (let (atr-d ccs-d)
 436     (setq attributes
 437           (sort (if attributes
 438                     (if (consp attributes)
 439                         (progn
 440                           (dolist (name attributes)
 441                             (unless (memq name char-db-ignored-attributes)
 442                               (push name atr-d)))
 443                           atr-d))
 444                   (dolist (name (char-attribute-list))
 445                     (unless (memq name char-db-ignored-attributes)
 446                       (if (find-charset name)
 447                           (push name ccs-d)
 448                         (push name atr-d))))
 449                   atr-d)
 450                 #'char-attribute-name<))
 451     (setq ccs-attributes
 452           (sort (if ccs-attributes
 453                     (progn
 454                       (setq ccs-d nil)
 455                       (dolist (name ccs-attributes)
 456                         (unless (memq name char-db-ignored-attributes)
 457                           (push name ccs-d)))
 458                       ccs-d)
 459                   (or ccs-d
 460                       (progn
 461                         (dolist (name (charset-list))
 462                           (unless (memq name char-db-ignored-attributes)
 463                             (push name ccs-d)))
 464                         ccs-d)))
 465                 #'char-attribute-name<)))
 466   (unless column
 467     (setq column (current-column)))
 468   (let (name value has-long-ccs-name rest
 469         radical strokes
 470         (line-breaking
 471          (concat "\n" (make-string (1+ column) ?\ )))
 472         lbs cell separator ret
 473         key al cal
 474         dest-ccss
 475         sources required-features)
 476     (insert "(")
 477     (when (and (memq 'name attributes)
 478                (setq value (get-char-attribute char 'name)))
 479       (insert (format
 480                (if (> (+ (current-column) (length value)) 48)
 481                    "(name . %S)%s"
 482                  "(name               . %S)%s")
 483                value line-breaking))
 484       (setq attributes (delq 'name attributes))
 485       )
 486     (when (and (memq 'name* attributes)
 487                (setq value (get-char-attribute char 'name*)))
 488       (insert (format
 489                (if (> (+ (current-column) (length value)) 48)
 490                    "(name* . %S)%s"
 491                  "(name*              . %S)%s")
 492                value line-breaking))
 493       (setq attributes (delq 'name* attributes))
 494       )
 495     (when (and (memq 'script attributes)
 496                (setq value (get-char-attribute char 'script)))
 497       (insert (format "(script\t\t%s)%s"
 498                       (mapconcat (function prin1-to-string)
 499                                  value " ")
 500                       line-breaking))
 501       (setq attributes (delq 'script attributes))
 502       )
 503     (dolist (name '(=>ucs =>ucs*))
 504       (when (and (memq name attributes)
 505                  (setq value (get-char-attribute char name)))
 506         (insert (format "(%-18s . #x%04X)\t; %c%s"
 507                         name value (decode-char '=ucs value)
 508                         line-breaking))
 509         (setq attributes (delq name attributes))))
 510     (dolist (name '(=>ucs@gb =>ucs@cns =>ucs@jis =>ucs@ks =>ucs@big5))
 511       (when (and (memq name attributes)
 512                  (setq value (get-char-attribute char name)))
 513         (insert (format "(%-18s . #x%04X)\t; %c%s"
 514                         name value
 515                         (decode-char (intern
 516                                       (concat "="
 517                                               (substring
 518                                                (symbol-name name) 2)))
 519                                      value)
 520                         line-breaking))
 521         (setq attributes (delq name attributes))
 522         ))
 523     ;; (dolist (name '(=>ucs-gb =>ucs-cns =>ucs-jis =>ucs-ks =>ucs-big5))
 524     ;;   (when (and (memq name attributes)
 525     ;;              (setq value (get-char-attribute char name)))
 526     ;;     (insert (format "(%-18s . #x%04X)\t; %c%s"
 527     ;;                     (intern
 528     ;;                      (concat "=>ucs@"
 529     ;;                              (substring (symbol-name name) 6)))
 530     ;;                     value
 531     ;;                     (decode-char (intern
 532     ;;                                   (concat "=ucs@"
 533     ;;                                           (substring
 534     ;;                                            (symbol-name name) 6)))
 535     ;;                                  value)
 536     ;;                     line-breaking))
 537     ;;     (setq attributes (delq name attributes))))
 538     ;; (when (and (memq '->ucs attributes)
 539     ;;            (setq value (get-char-attribute char '->ucs)))
 540     ;;   (insert (format (if char-db-convert-obsolete-format
 541     ;;                       "(=>ucs\t\t. #x%04X)\t; %c%s"
 542     ;;                     "(->ucs\t\t. #x%04X)\t; %c%s")
 543     ;;                   value (decode-char '=ucs value)
 544     ;;                   line-breaking))
 545     ;;   (setq attributes (delq '->ucs attributes))
 546     ;;   )
 547     (dolist (name '(=>daikanwa))
 548       (when (and (memq name attributes)
 549                  (setq value (get-char-attribute char name)))
 550         (insert
 551          (if (integerp value)
 552              (format "(%-18s . %05d)\t; %c%s"
 553                      name value (decode-char '=daikanwa value)
 554                      line-breaking)
 555            (format "(%-18s %s)\t; %c%s"
 556                    name
 557                    (mapconcat #'prin1-to-string
 558                               value " ")
 559                    (char-representative-of-daikanwa char)
 560                    line-breaking)))
 561         (setq attributes (delq name attributes))))
 562     (when (and (memq 'general-category attributes)
 563                (setq value (get-char-attribute char 'general-category)))
 564       (insert (format
 565                "(general-category\t%s) ; %s%s"
 566                (mapconcat (lambda (cell)
 567                             (format "%S" cell))
 568                           value " ")
 569                (cond ((rassoc value unidata-normative-category-alist)
 570                       "Normative Category")
 571                      ((rassoc value unidata-informative-category-alist)
 572                       "Informative Category")
 573                      (t
 574                       "Unknown Category"))
 575                line-breaking))
 576       (setq attributes (delq 'general-category attributes))
 577       )
 578     (when (and (memq 'bidi-category attributes)
 579                (setq value (get-char-attribute char 'bidi-category)))
 580       (insert (format "(bidi-category\t. %S)%s"
 581                       value
 582                       line-breaking))
 583       (setq attributes (delq 'bidi-category attributes))
 584       )
 585     (unless (or (not (memq 'mirrored attributes))
 586                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 587                     'empty))
 588       (insert (format "(mirrored\t\t. %S)%s"
 589                       value
 590                       line-breaking))
 591       (setq attributes (delq 'mirrored attributes))
 592       )
 593     (cond
 594      ((and (memq 'decimal-digit-value attributes)
 595            (setq value (get-char-attribute char 'decimal-digit-value)))
 596       (insert (format "(decimal-digit-value . %S)%s"
 597                       value
 598                       line-breaking))
 599       (setq attributes (delq 'decimal-digit-value attributes))
 600       (when (and (memq 'digit-value attributes)
 601                  (setq value (get-char-attribute char 'digit-value)))
 602         (insert (format "(digit-value\t . %S)%s"
 603                         value
 604                         line-breaking))
 605         (setq attributes (delq 'digit-value attributes))
 606         )
 607       (when (and (memq 'numeric-value attributes)
 608                  (setq value (get-char-attribute char 'numeric-value)))
 609         (insert (format "(numeric-value\t . %S)%s"
 610                         value
 611                         line-breaking))
 612         (setq attributes (delq 'numeric-value attributes))
 613         )
 614       )
 615      (t
 616       (when (and (memq 'digit-value attributes)
 617                  (setq value (get-char-attribute char 'digit-value)))
 618         (insert (format "(digit-value\t. %S)%s"
 619                         value
 620                         line-breaking))
 621         (setq attributes (delq 'digit-value attributes))
 622         )
 623       (when (and (memq 'numeric-value attributes)
 624                  (setq value (get-char-attribute char 'numeric-value)))
 625         (insert (format "(numeric-value\t. %S)%s"
 626                         value
 627                         line-breaking))
 628         (setq attributes (delq 'numeric-value attributes))
 629         )))
 630     (when (and (memq 'iso-10646-comment attributes)
 631                (setq value (get-char-attribute char 'iso-10646-comment)))
 632       (insert (format "(iso-10646-comment\t. %S)%s"
 633                       value
 634                       line-breaking))
 635       (setq attributes (delq 'iso-10646-comment attributes))
 636       )
 637     (when (and (memq 'morohashi-daikanwa attributes)
 638                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 639       (insert (format "(morohashi-daikanwa\t%s)%s"
 640                       (mapconcat (function prin1-to-string) value " ")
 641                       line-breaking))
 642       (setq attributes (delq 'morohashi-daikanwa attributes))
 643       )
 644     (setq radical nil
 645           strokes nil)
 646     (when (and (memq 'ideographic-radical attributes)
 647                (setq value (get-char-attribute char 'ideographic-radical)))
 648       (setq radical value)
 649       (insert (format "(ideographic-radical . %S)\t; %c%s"
 650                       radical
 651                       (aref ideographic-radicals radical)
 652                       line-breaking))
 653       (setq attributes (delq 'ideographic-radical attributes))
 654       )
 655     (let (key)
 656       (dolist (domain char-db-feature-domains)
 657         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
 658         (when (and (memq key attributes)
 659                    (setq value (get-char-attribute char key)))
 660           (setq radical value)
 661           (insert (format "(%s . %S)\t; %c%s"
 662                           key
 663                           radical
 664                           (aref ideographic-radicals radical)
 665                           line-breaking))
 666           (setq attributes (delq key attributes))
 667           )
 668         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
 669         (when (and (memq key attributes)
 670                    (setq value (get-char-attribute char key)))
 671           (setq strokes value)
 672           (insert (format "(%s . %S)%s"
 673                           key
 674                           strokes
 675                           line-breaking))
 676           (setq attributes (delq key attributes))
 677           )
 678         (setq key (intern (format "%s@%s" 'total-strokes domain)))
 679         (when (and (memq key attributes)
 680                    (setq value (get-char-attribute char key)))
 681           (insert (format "(%s       . %S)%s"
 682                           key
 683                           value
 684                           line-breaking))
 685           (setq attributes (delq key attributes))
 686           )
 687         (dolist (feature '(ideographic-radical
 688                            ideographic-strokes
 689                            total-strokes))
 690           (setq key (intern (format "%s@%s*sources" feature domain)))
 691           (when (and (memq key attributes)
 692                      (setq value (get-char-attribute char key)))
 693             (insert (format "(%s%s" key line-breaking))
 694             (dolist (cell value)
 695               (insert (format " %s" cell)))
 696             (insert ")")
 697             (insert line-breaking)
 698             (setq attributes (delq key attributes))
 699             ))
 700         ))
 701     (when (and (memq 'ideographic-strokes attributes)
 702                (setq value (get-char-attribute char 'ideographic-strokes)))
 703       (setq strokes value)
 704       (insert (format "(ideographic-strokes . %S)%s"
 705                       strokes
 706                       line-breaking))
 707       (setq attributes (delq 'ideographic-strokes attributes))
 708       )
 709     (when (and (memq 'kangxi-radical attributes)
 710                (setq value (get-char-attribute char 'kangxi-radical)))
 711       (unless (eq value radical)
 712         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 713                         value
 714                         (aref ideographic-radicals value)
 715                         line-breaking))
 716         (or radical
 717             (setq radical value)))
 718       (setq attributes (delq 'kangxi-radical attributes))
 719       )
 720     (when (and (memq 'kangxi-strokes attributes)
 721                (setq value (get-char-attribute char 'kangxi-strokes)))
 722       (unless (eq value strokes)
 723         (insert (format "(kangxi-strokes\t . %S)%s"
 724                         value
 725                         line-breaking))
 726         (or strokes
 727             (setq strokes value)))
 728       (setq attributes (delq 'kangxi-strokes attributes))
 729       )
 730     (when (and (memq 'japanese-radical attributes)
 731                (setq value (get-char-attribute char 'japanese-radical)))
 732       (unless (eq value radical)
 733         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 734                         value
 735                         (aref ideographic-radicals value)
 736                         line-breaking))
 737         (or radical
 738             (setq radical value)))
 739       (setq attributes (delq 'japanese-radical attributes))
 740       )
 741     (when (and (memq 'japanese-strokes attributes)
 742                (setq value (get-char-attribute char 'japanese-strokes)))
 743       (unless (eq value strokes)
 744         (insert (format "(japanese-strokes\t . %S)%s"
 745                         value
 746                         line-breaking))
 747         (or strokes
 748             (setq strokes value)))
 749       (setq attributes (delq 'japanese-strokes attributes))
 750       )
 751     (when (and (memq 'cns-radical attributes)
 752                (setq value (get-char-attribute char 'cns-radical)))
 753       (insert (format "(cns-radical\t . %S)\t; %c%s"
 754                       value
 755                       (aref ideographic-radicals value)
 756                       line-breaking))
 757       (setq attributes (delq 'cns-radical attributes))
 758       )
 759     (when (and (memq 'cns-strokes attributes)
 760                (setq value (get-char-attribute char 'cns-strokes)))
 761       (unless (eq value strokes)
 762         (insert (format "(cns-strokes\t . %S)%s"
 763                         value
 764                         line-breaking))
 765         (or strokes
 766             (setq strokes value)))
 767       (setq attributes (delq 'cns-strokes attributes))
 768       )
 769     (when (and (memq 'shinjigen-1-radical attributes)
 770                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 771       (unless (eq value radical)
 772         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 773                         value
 774                         (aref ideographic-radicals value)
 775                         line-breaking))
 776         (or radical
 777             (setq radical value)))
 778       (setq attributes (delq 'shinjigen-1-radical attributes))
 779       )
 780     (when (and (memq 'ideographic- attributes)
 781                (setq value (get-char-attribute char 'ideographic-)))
 782       (insert "(ideographic-       ")
 783       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 784             separator nil)
 785       (while (consp value)
 786         (setq cell (car value))
 787         (if (integerp cell)
 788             (setq cell (decode-char '=ucs cell)))
 789         (cond ((characterp cell)
 790                (if separator
 791                    (insert lbs))
 792                (if readable
 793                    (insert (format "%S" cell))
 794                  (char-db-insert-char-spec cell readable))
 795                (setq separator lbs))
 796               ((consp cell)
 797                (if separator
 798                    (insert lbs))
 799                (if (consp (car cell))
 800                    (char-db-insert-char-spec cell readable)
 801                  (char-db-insert-char-reference cell readable))
 802                (setq separator lbs))
 803               (t
 804                (if separator
 805                    (insert separator))
 806                (insert (prin1-to-string cell))
 807                (setq separator " ")))
 808         (setq value (cdr value)))
 809       (insert ")")
 810       (insert line-breaking)
 811       (setq attributes (delq 'ideographic- attributes)))
 812     (when (and (memq 'total-strokes attributes)
 813                (setq value (get-char-attribute char 'total-strokes)))
 814       (insert (format "(total-strokes       . %S)%s"
 815                       value
 816                       line-breaking))
 817       (setq attributes (delq 'total-strokes attributes))
 818       )
 819     (when (and (memq '->ideograph attributes)
 820                (setq value (get-char-attribute char '->ideograph)))
 821       (insert (format "(->ideograph\t%s)%s"
 822                       (mapconcat (lambda (code)
 823                                    (cond ((symbolp code)
 824                                           (symbol-name code))
 825                                          ((integerp code)
 826                                           (format "#x%04X" code))
 827                                          (t
 828                                           (format "%s %S"
 829                                                   line-breaking code))))
 830                                  value " ")
 831                       line-breaking))
 832       (setq attributes (delq '->ideograph attributes))
 833       )
 834     (when (and (memq '->decomposition attributes)
 835                (setq value (get-char-attribute char '->decomposition)))
 836       (insert (format "(->decomposition\t%s)%s"
 837                       (mapconcat (lambda (code)
 838                                    (cond ((symbolp code)
 839                                           (symbol-name code))
 840                                          ((characterp code)
 841                                           (if readable
 842                                               (format "%S" code)
 843                                             (format "#x%04X"
 844                                                     (char-int code))
 845                                             ))
 846                                          ((integerp code)
 847                                           (format "#x%04X" code))
 848                                          (t
 849                                           (format "%s%S" line-breaking code))))
 850                                  value " ")
 851                       line-breaking))
 852       (setq attributes (delq '->decomposition attributes))
 853       )
 854     (if (equal (get-char-attribute char '->titlecase)
 855                (get-char-attribute char '->uppercase))
 856         (setq attributes (delq '->titlecase attributes)))
 857     (when (and (memq '->mojikyo attributes)
 858                (setq value (get-char-attribute char '->mojikyo)))
 859       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 860                       value (decode-char 'mojikyo value)
 861                       line-breaking))
 862       (setq attributes (delq '->mojikyo attributes))
 863       )
 864     (when (and (memq 'hanyu-dazidian-vol attributes)
 865                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 866       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 867                       value line-breaking))
 868       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 869       )
 870     (when (and (memq 'hanyu-dazidian-page attributes)
 871                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 872       (insert (format "(hanyu-dazidian-page . %d)%s"
 873                       value line-breaking))
 874       (setq attributes (delq 'hanyu-dazidian-page attributes))
 875       )
 876     (when (and (memq 'hanyu-dazidian-char attributes)
 877                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 878       (insert (format "(hanyu-dazidian-char . %d)%s"
 879                       value line-breaking))
 880       (setq attributes (delq 'hanyu-dazidian-char attributes))
 881       )
 882     (setq rest ccs-attributes)
 883     (while (and rest
 884                 (progn
 885                   (setq value (get-char-attribute char (car rest)))
 886                   (if value
 887                       (if (>= (length (symbol-name (car rest))) 19)
 888                           (progn
 889                             (setq has-long-ccs-name t)
 890                             nil)
 891                         t)
 892                     t)))
 893       (setq rest (cdr rest)))
 894     (while attributes
 895       (setq name (car attributes))
 896       (if (setq value (get-char-attribute char name))
 897           (cond ((string-match "^=>ucs@" (symbol-name name))
 898                  (insert (format "(%-18s . #x%04X)\t; %c%s"
 899                                  name value (decode-char '=ucs value)
 900                                  line-breaking))
 901                  )
 902                 ((eq name 'jisx0208-1978/4X)
 903                  (insert (format "(%-18s . #x%04X)%s"
 904                                  name value
 905                                  line-breaking)))
 906                 ((or (eq name 'ideographic-structure)
 907                      (eq name 'ideographic-)
 908                      (string-match "^\\(->\\|<-\\)" (symbol-name name)))
 909                  (insert (format "(%-18s%s " name line-breaking))
 910                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 911                        separator nil)
 912                  (while (consp value)
 913                    (setq cell (car value))
 914                    (if (integerp cell)
 915                        (setq cell (decode-char '=ucs cell)))
 916                    (cond ((eq name '->unified)
 917                           (if separator
 918                               (insert lbs))
 919                           (let ((char-db-ignored-attributes
 920                                  (cons '<-unified
 921                                        char-db-ignored-attributes)))
 922                             (insert-char-attributes cell readable))
 923                           (setq separator lbs))
 924                          ((characterp cell)
 925                           (setq sources
 926                                 (get-char-attribute
 927                                  char
 928                                  (intern (format "%s*sources" name))))
 929                           (setq required-features nil)
 930                           (dolist (source sources)
 931                             (setq required-features
 932                                   (cons
 933                                    (if (find-charset
 934                                         (setq ret (intern
 935                                                    (format "=%s" source))))
 936                                        ret
 937                                      source)
 938                                    required-features)))
 939                           (when (string-match "@JP" (symbol-name name))
 940                             (setq required-features
 941                                   (union required-features
 942                                          '(=jis-x0208
 943                                            =jis-x0208-1990
 944                                            =jis-x0213-1-2000
 945                                            =jis-x0213-2-2000
 946                                            =jis-x0212
 947                                            =jis-x0208-1983
 948                                            =jis-x0208-1978))))
 949                           (if separator
 950                               (insert lbs))
 951                           (if readable
 952                               (insert (format "%S" cell))
 953                             (char-db-insert-char-spec cell readable
 954                                                       nil
 955                                                       required-features))
 956                           (setq separator lbs))
 957                          ((consp cell)
 958                           (if separator
 959                               (insert lbs))
 960                           (if (consp (car cell))
 961                               (char-db-insert-char-spec cell readable)
 962                             (char-db-insert-char-reference cell readable))
 963                           (setq separator lbs))
 964                          (t
 965                           (if separator
 966                               (insert separator))
 967                           (insert (prin1-to-string cell))
 968                           (setq separator " ")))
 969                    (setq value (cdr value)))
 970                  (insert ")")
 971                  (insert line-breaking))
 972                 ((memq name '(ideograph=
 973                               original-ideograph-of
 974                               ancient-ideograph-of
 975                               vulgar-ideograph-of
 976                               wrong-ideograph-of
 977                               ;; simplified-ideograph-of
 978                               ideographic-variants
 979                               ;; ideographic-different-form-of
 980                               ))
 981                  (insert (format "(%-18s%s " name line-breaking))
 982                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 983                        separator nil)
 984                  (while (consp value)
 985                    (setq cell (car value))
 986                    (if (and (consp cell)
 987                             (consp (car cell)))
 988                        (progn
 989                          (if separator
 990                              (insert lbs))
 991                          (char-db-insert-alist cell readable)
 992                          (setq separator lbs))
 993                      (if separator
 994                          (insert separator))
 995                      (insert (prin1-to-string cell))
 996                      (setq separator " "))
 997                    (setq value (cdr value)))
 998                  (insert ")")
 999                  (insert line-breaking))
1000                 ((consp value)
1001                  (insert (format "(%-18s " name))
1002                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1003                        separator nil)
1004                  (while (consp value)
1005                    (setq cell (car value))
1006                    (if (and (consp cell)
1007                             (consp (car cell))
1008                             (setq ret (condition-case nil
1009                                           (find-char cell)
1010                                         (error nil))))
1011                        (progn
1012                          (setq rest cell
1013                                al nil
1014                                cal nil)
1015                          (while rest
1016                            (setq key (car (car rest)))
1017                            (if (find-charset key)
1018                                (setq cal (cons key cal))
1019                              (setq al (cons key al)))
1020                            (setq rest (cdr rest)))
1021                          (if separator
1022                              (insert lbs))
1023                          (insert-char-attributes ret
1024                                                  readable
1025                                                  al cal)
1026                          (setq separator lbs))
1027                      (if separator
1028                          (insert separator))
1029                      (insert (prin1-to-string cell))
1030                      (setq separator " "))
1031                    (setq value (cdr value)))
1032                  (insert ")")
1033                  (insert line-breaking))
1034                 (t
1035                  (insert (format "(%-18s . %S)%s"
1036                                  name value
1037                                  line-breaking)))
1038                 ))
1039       (setq attributes (cdr attributes)))
1040     (while ccs-attributes
1041       (setq name (charset-name (car ccs-attributes)))
1042       (if (and (not (memq name dest-ccss))
1043                (prog1
1044                    (setq value (get-char-attribute char name))
1045                  (setq dest-ccss (cons name dest-ccss))))
1046           (insert
1047            (format
1048             (cond ((memq name '(=daikanwa
1049                                 =daikanwa-rev1 =daikanwa-rev2
1050                                 =gt =gt-k =cbeta))
1051                    (if has-long-ccs-name
1052                        "(%-26s . %05d)\t; %c%s"
1053                      "(%-18s . %05d)\t; %c%s"))
1054                   ((eq name 'mojikyo)
1055                    (if has-long-ccs-name
1056                        "(%-26s . %06d)\t; %c%s"
1057                      "(%-18s . %06d)\t; %c%s"))
1058                   ((>= (charset-dimension name) 2)
1059                    (if has-long-ccs-name
1060                        "(%-26s . #x%04X)\t; %c%s"
1061                      "(%-18s . #x%04X)\t; %c%s"))
1062                   (t
1063                    (if has-long-ccs-name
1064                        "(%-26s . #x%02X)\t; %c%s"
1065                      "(%-18s . #x%02X)\t; %c%s")))
1066             name
1067             (if (= (charset-iso-graphic-plane name) 1)
1068                 (logior value
1069                         (cond ((= (charset-dimension name) 1)
1070                                #x80)
1071                               ((= (charset-dimension name) 2)
1072                                #x8080)
1073                               ((= (charset-dimension name) 3)
1074                                #x808080)
1075                               (t 0)))
1076               value)
1077             (char-db-decode-isolated-char name value)
1078             line-breaking)))
1079       (setq ccs-attributes (cdr ccs-attributes)))
1080     (insert ")")))
1081
1082 (defun insert-char-data (char &optional readable
1083                               attributes ccs-attributes)
1084   (save-restriction
1085     (narrow-to-region (point)(point))
1086     (insert "(define-char
1087   '")
1088     (insert-char-attributes char readable
1089                             attributes ccs-attributes)
1090     (insert ")\n")
1091     (goto-char (point-min))
1092     (while (re-search-forward "[ \t]+$" nil t)
1093       (replace-match ""))
1094     ;; from tabify.
1095     (goto-char (point-min))
1096     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1097       (let ((column (current-column))
1098             (indent-tabs-mode t))
1099         (delete-region (match-beginning 0) (point))
1100         (indent-to column)))
1101     (goto-char (point-max))
1102     ;; (tabify (point-min)(point-max))
1103     ))
1104
1105 (defun insert-char-data-with-variant (char &optional printable
1106                                            no-ucs-unified
1107                                            script excluded-script)
1108   (insert-char-data char printable)
1109   (let ((variants (or (char-variants char)
1110                       (let ((ucs (get-char-attribute char '->ucs)))
1111                         (if ucs
1112                             (delete char (char-variants (int-char ucs)))))))
1113         variant vs)
1114     (setq variants (sort variants #'<))
1115     (while variants
1116       (setq variant (car variants))
1117       (if (and (or (null script)
1118                    (null (setq vs (get-char-attribute variant 'script)))
1119                    (memq script vs))
1120                (or (null excluded-script)
1121                    (null (setq vs (get-char-attribute variant 'script)))
1122                    (not (memq excluded-script vs))))
1123           (or (and no-ucs-unified (get-char-attribute variant '=ucs))
1124               (insert-char-data variant printable)))
1125       (setq variants (cdr variants))
1126       )))
1127
1128 (defun insert-char-range-data (min max &optional script excluded-script)
1129   (let ((code min)
1130         char)
1131     (while (<= code max)
1132       (setq char (decode-char '=ucs code))
1133       (if (encode-char char '=ucs 'defined-only)
1134           (insert-char-data-with-variant char nil 'no-ucs-unified
1135                                          script excluded-script))
1136       (setq code (1+ code)))))
1137
1138 (defun write-char-range-data-to-file (min max file
1139                                           &optional script excluded-script)
1140   (let ((coding-system-for-write 'utf-8-mcs))
1141     (with-temp-buffer
1142       (insert ";; -*- coding: utf-8-mcs -*-\n")
1143       (insert-char-range-data min max script excluded-script)
1144       (write-region (point-min)(point-max) file))))
1145
1146 (defvar what-character-original-window-configuration)
1147
1148 ;;;###autoload
1149 (defun what-char-definition (char)
1150   (interactive (list (char-after)))
1151   (let ((buf (get-buffer-create "*Character Description*"))
1152         (the-buf (current-buffer))
1153         (win-conf (current-window-configuration)))
1154     (pop-to-buffer buf)
1155     (make-local-variable 'what-character-original-window-configuration)
1156     (setq what-character-original-window-configuration win-conf)
1157     (setq buffer-read-only nil)
1158     (erase-buffer)
1159     (condition-case err
1160         (progn
1161           (insert-char-data-with-variant char 'printable)
1162           (unless (char-attribute-alist char)
1163             (insert (format ";; = %c\n"
1164                             (let* ((rest (split-char char))
1165                                    (ccs (pop rest))
1166                                    (code (pop rest)))
1167                               (while rest
1168                                 (setq code (logior (lsh code 8)
1169                                                    (pop rest))))
1170                               (decode-char ccs code)))))
1171           ;; (char-db-update-comment)
1172           (set-buffer-modified-p nil)
1173           (view-mode the-buf (lambda (buf)
1174                                (set-window-configuration
1175                                 what-character-original-window-configuration)
1176                                ))
1177           (goto-char (point-min)))
1178       (error (progn
1179                (set-window-configuration
1180                 what-character-original-window-configuration)
1181                (signal (car err) (cdr err)))))))
1182
1183 (provide 'char-db-util)
1184
1185 ;;; char-db-util.el ends here