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