lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility -*- coding: utf-8-er; -*-
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009 MORIOKA Tomohiko.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
   8
   9 ;; This file is part of XEmacs CHISE.
  10
  11 ;; XEmacs CHISE is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'alist)
  29
  30 (defconst unidata-normative-category-alist
  31   '(("Lu" letter        uppercase)
  32     ("Ll" letter        lowercase)
  33     ("Lt" letter        titlecase)
  34     ("Mn" mark          non-spacing)
  35     ("Mc" mark          spacing-combining)
  36     ("Me" mark          enclosing)
  37     ("Nd" number        decimal-digit)
  38     ("Nl" number        letter)
  39     ("No" number        other)
  40     ("Zs" separator     space)
  41     ("Zl" separator     line)
  42     ("Zp" separator     paragraph)
  43     ("Cc" other         control)
  44     ("Cf" other         format)
  45     ("Cs" other         surrogate)
  46     ("Co" other         private-use)
  47     ("Cn" other         not-assigned)))
  48
  49 (defconst unidata-informative-category-alist
  50   '(("Lm" letter        modifier)
  51     ("Lo" letter        other)
  52     ("Pc" punctuation   connector)
  53     ("Pd" punctuation   dash)
  54     ("Ps" punctuation   open)
  55     ("Pe" punctuation   close)
  56     ("Pi" punctuation   initial-quote)
  57     ("Pf" punctuation   final-quote)
  58     ("Po" punctuation   other)
  59     ("Sm" symbol        math)
  60     ("Sc" symbol        currency)
  61     ("Sk" symbol        modifier)
  62     ("So" symbol        other)
  63     ))
  64
  65 (defconst ideographic-radicals
  66   (let ((v (make-vector 215 nil))
  67         (i 1))
  68     (while (< i 215)
  69       (aset v i (decode-char '=ucs (+ #x2EFF i)))
  70       (setq i (1+ i)))
  71     v))
  72
  73 (defun ideographic-radical (number)
  74   (aref ideographic-radicals number))
  75
  76 (defconst shuowen-radicals
  77   [?一 ?上 ?示 ?三 ?王 ?玉 ?玨 ?气 ?士 ?丨 ; 010
  78    ?屮 ?艸 ?蓐 ?茻 ?小 ?八 ?釆 ?半 ?牛 ?犛 ; 020
  79    ?告 ?口 ?凵 ?吅 ?哭 ?走 ?止 ?癶 ?步 ?此 ; 030
  80    ?正 ?是 ?辵 ?彳 ?廴 ?㢟 ?行 ?齒 ?牙 ?足 ; 040
  81    ?疋 ?品 ?龠 ?冊 ?㗊 ?舌 ?干 ?谷 ?只 ?㕯 ; 050
  82    ?句 ?丩 ?古 ?十 ?卅 ?言 ?誩 ?音 ?䇂 ?丵 ; 060
  83    ?菐 ?𠬞 ?廾 ?共 ?異 ?舁 ?𦥑 ?䢅 ?爨 ?革 ; 070
  84    ?鬲 ?䰜 ?爪 ?𠃨 ?鬥 ?又 ?𠂇 ?㕜 ?支 ?𦘒 ; 080
  85    ?聿 ?畫 ?隶 ?臤 ?臣 ?殳 ?殺 ?𠘧 ?寸 ?皮 ; 090
  86    ?㼱 ?攴 ?敎 ?卜 ?用 ?爻 ?㸚 ?𥄎 ?目 ?䀠 ; 100
  87    ?眉 ?盾 ?自 ?白 ?鼻 ?皕 ?習 ?羽 ?隹 ?奞 ; 110
  88    ?萑 ?𦫳 ?苜 ?羊 ?羴 ?瞿 ?雔 ?雥 ?鳥 ?烏 ; 120
  89    ?𠦒 ?冓 ?幺 ?𢆶 ?叀 ?玄 ?予 ?放 ?𠬪 ?𣦼 ; 130
  90    ?歺 ?死 ?冎 ?骨 ?肉 ?筋 ?刀 ?刃 ?㓞 ?丰 ; 140
  91    ?耒 ?𧢲 ?竹 ?箕 ?丌 ?左 ?工 ?㠭 ?巫 ?甘 ; 150
  92    ?曰 ?乃 ?丂 ?可 ?兮 ?号 ?亏 ?旨 ?喜 ?壴 ; 160
  93    ?鼓 ?豈 ?豆 ?豊 ?豐 ?䖒 ?虍 ?虎 ?虤 ?皿 ; 170
  94    ?𠙴 ?去 ?血 ?丶 ?丹 ?青 ?井 ?皀 ?鬯 ?食 ; 180
  95    ?亼 ?會 ?倉 ?入 ?缶 ?矢 ?高 ?冂 ?𩫏 ?京 ; 190
  96    ?亯 ?𣆪 ?畗 ?㐭 ?嗇 ?來 ?麥 ?夊 ?舛 ?䑞 ; 200
  97    ?韋 ?弟 ?夂 ?久 ?桀 ?木 ?東 ?林 ?才 ?叒 ; 210
  98    ?之 ?帀 ?出 ?𣎵 ?生 ?乇 ?𠂹 ?𠌶 ?華 ?𥝌 ; 220
  99    ?稽 ?巢 ?桼 ?束 ?㯻 ?囗 ?員 ?貝 ?邑 ?𨛜 ; 230
 100    ?日 ?旦 ?倝 ?㫃 ?冥 ?晶 ?月 ?有 ?明 ?囧 ; 240
 101    ?夕 ?多 ?毌 ?𢎘 ?𣐺 ?卣 ?齊 ?朿 ?片 ?鼎 ; 250
 102    ?克 ?彔 ?禾 ?秝 ?黍 ?香 ?米 ?毇 ?臼 ?凶 ; 260
 103    ?𣎳 ?林 ?麻 ?尗 ?耑 ?韭 ?瓜 ?瓠 ?宀 ?宮 ; 270
 104    ?呂 ?穴 ?㝱 ?𤕫 ?冖 ?𠔼 ?冃 ?㒳 ?网 ?襾 ; 280
 105    ?巾 ?巿 ?帛 ?白 ?㡀 ?黹 ?人 ?𠤎 ?匕 ?从 ; 290
 106    ])
 107
 108 (defun shuowen-radical (number)
 109   (aref shuowen-radicals (1- number)))
 110
 111 (defvar char-db-file-coding-system 'utf-8-mcs-er)
 112
 113 (defvar char-db-feature-domains
 114   '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
 115         jis-x0212 jis-x0213 cdp shinjigen misc unknown))
 116
 117 (defvar char-db-ignored-attributes '(ideographic-products))
 118
 119 (defun char-attribute-name< (ka kb)
 120   (cond
 121    ((eq '->denotational kb)
 122     t)
 123    ((eq '->subsumptive kb)
 124     (not (eq '->denotational ka)))
 125    ((eq '->denotational ka)
 126     nil)
 127    ((eq '->subsumptive ka)
 128     nil)
 129    ((and (symbolp ka)
 130          (string-match "^->" (symbol-name ka)))
 131     (cond ((and (symbolp kb)
 132                 (string-match "^->" (symbol-name kb)))
 133            (string< (symbol-name ka)
 134                     (symbol-name kb))
 135            ))
 136     )
 137    ((and (symbolp kb)
 138          (string-match "^->" (symbol-name kb)))
 139     t)
 140    ((and (symbolp ka)
 141          (string-match "^<-" (symbol-name ka)))
 142     (cond ((symbolp kb)
 143            (cond ((string-match "^<-" (symbol-name kb))
 144                   (string< (symbol-name ka)
 145                            (symbol-name kb))
 146                   )
 147                  ;; ((string-match "^->" (symbol-name kb))
 148                  ;;  t)
 149                  )))
 150     )
 151    ((and (symbolp kb)
 152          (string-match "^<-" (symbol-name kb)))
 153     t
 154     ;; (not (string-match "^->" (symbol-name ka)))
 155     )
 156    ((find-charset ka)
 157     (if (find-charset kb)
 158         (if (or (<= (charset-id ka) 1)
 159                 (and (charset-final ka)
 160                      (>= (charset-final ka) ?@)))
 161             (if (or (<= (charset-id kb) 1)
 162                     (and (charset-final kb)
 163                          (>= (charset-final kb) ?@)))
 164                 (cond
 165                  ((= (charset-dimension ka)
 166                      (charset-dimension kb))
 167                   (if (and (<= (charset-id ka) 1)
 168                            (<= (charset-id kb) 1))
 169                       (> (charset-id ka)(charset-id kb))
 170                     (if (and (charset-final ka)
 171                              (charset-final kb))
 172                         (cond
 173                          ((= (charset-final ka)(charset-final kb))
 174                           (if (<= (charset-id ka) 1)
 175                               (if (<= (charset-id kb) 1)
 176                                   (> (charset-id ka)(charset-id kb))
 177                                 t)
 178                             (if (<= (charset-id kb) 1)
 179                                 nil
 180                               (< (charset-id ka)(charset-id kb))))
 181                           )
 182                          ((< (charset-final ka)(charset-final kb))
 183                           ))
 184                       (if (<= (charset-id ka) 1)
 185                           (if (<= (charset-id kb) 1)
 186                               (> (charset-id ka)(charset-id kb))
 187                             t)
 188                         (if (<= (charset-id kb) 1)
 189                             nil
 190                           (cond ((and (charset-final ka)
 191                                       (>= (charset-final ka) ?@))
 192                                  t)
 193                                 ((and (charset-final kb)
 194                                       (>= (charset-final kb) ?@))
 195                                  nil)
 196                                 (t
 197                                  (< (charset-id ka)(charset-id kb))
 198                                  ))))))
 199                   )
 200                  (t
 201                   (> (charset-dimension ka)
 202                      (charset-dimension kb))
 203                   ))
 204               t)
 205           (if (or (<= (charset-id kb) 1)
 206                   (and (charset-final kb)
 207                        (>= (charset-final kb) ?@)))
 208               nil
 209             (< (charset-id ka)(charset-id kb))))
 210       nil))
 211    ((find-charset kb)
 212     t)
 213    ((symbolp ka)
 214     (cond ((symbolp kb)
 215            (string< (symbol-name ka)
 216                     (symbol-name kb)))
 217           (t)))
 218    ((symbolp kb)
 219     nil)))
 220
 221 (defvar char-db-coded-charset-priority-list
 222   '(ascii
 223     control-1
 224     latin-iso8859-1
 225     latin-iso8859-2
 226     latin-iso8859-3
 227     latin-iso8859-4
 228     latin-iso8859-9
 229     latin-jisx0201
 230     cyrillic-iso8859-5
 231     greek-iso8859-7
 232     thai-tis620
 233     =jis-x0208
 234     =jis-x0208@1978
 235     =jis-x0208@1983
 236     japanese-jisx0212
 237     chinese-gb2312
 238     =jis-x0208@1990
 239     chinese-cns11643-1
 240     chinese-cns11643-2
 241     chinese-cns11643-3
 242     chinese-cns11643-4
 243     chinese-cns11643-5
 244     chinese-cns11643-6
 245     chinese-cns11643-7
 246     =jis-x0213-1-2000
 247     =jis-x0213-2-2000
 248     korean-ksc5601
 249     chinese-isoir165
 250     katakana-jisx0201
 251     hebrew-iso8859-8
 252     chinese-gb12345
 253     latin-viscii
 254     ethiopic-ucs
 255     =big5-cdp
 256     =gt
 257     ideograph-daikanwa-2
 258     ideograph-daikanwa
 259     =cbeta
 260     ideograph-hanziku-1
 261     ideograph-hanziku-2
 262     ideograph-hanziku-3
 263     ideograph-hanziku-4
 264     ideograph-hanziku-5
 265     ideograph-hanziku-6
 266     ideograph-hanziku-7
 267     ideograph-hanziku-8
 268     ideograph-hanziku-9
 269     ideograph-hanziku-10
 270     ideograph-hanziku-11
 271     ideograph-hanziku-12
 272     =gt-k
 273     =ucs@iso
 274     =ucs@unicode
 275     =big5
 276     =big5-eten
 277     =jis-x0208@1997
 278     =zinbun-oracle
 279     =ruimoku-v6
 280     =jef-china3))
 281
 282 (defun char-db-make-char-spec (char)
 283   (let (ret char-spec)
 284     (cond ((characterp char)
 285            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 286                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 287                   (setq char-spec (list (cons '=ucs ret)))
 288                   (cond ((setq ret (get-char-attribute char 'name))
 289                          (setq char-spec (cons (cons 'name ret) char-spec))
 290                          )
 291                         ((setq ret (get-char-attribute char 'name*))
 292                          (setq char-spec (cons (cons 'name* ret) char-spec))
 293                          ))
 294                   )
 295                  ((setq ret
 296                         (catch 'tag
 297                           (let ((rest char-db-coded-charset-priority-list)
 298                                 ccs)
 299                             (while rest
 300                               (setq ccs (charset-name
 301                                          (find-charset (car rest))))
 302                               (if (setq ret
 303                                         (encode-char char ccs
 304                                                      'defined-only))
 305                                   (throw 'tag (cons ccs ret)))
 306                               (setq rest (cdr rest))))))
 307                   (setq char-spec (list ret))
 308                   (dolist (ccs (delq (car ret) (charset-list)))
 309                     (if (and (or (charset-iso-final-char ccs)
 310                                  (memq ccs
 311                                        '(=daikanwa
 312                                          =daikanwa@rev2
 313                                          ;; =gt-k
 314                                          =jis-x0208@1997
 315                                          )))
 316                              (setq ccs (charset-name ccs))
 317                              (null (assq ccs char-spec))
 318                              (setq ret (encode-char char ccs 'defined-only)))
 319                         (setq char-spec (cons (cons ccs ret) char-spec))))
 320                   (if (null char-spec)
 321                       (setq char-spec (split-char char)))
 322                   (cond ((setq ret (get-char-attribute char 'name))
 323                          (setq char-spec (cons (cons 'name ret) char-spec))
 324                          )
 325                         ((setq ret (get-char-attribute char 'name*))
 326                          (setq char-spec (cons (cons 'name* ret) char-spec))
 327                          ))
 328                   )
 329                  ((setq ret (get-char-attribute
 330                              char 'ideographic-combination))
 331                   (setq char-spec
 332                         (cons (cons 'ideographic-combination ret)
 333                               char-spec))
 334                   ))
 335            char-spec)
 336           ((consp char)
 337            char))))
 338
 339 (defun char-db-insert-char-spec (char &optional readable column
 340                                       required-features)
 341   (unless column
 342     (setq column (current-column)))
 343   (let (char-spec temp-char)
 344     (setq char-spec (char-db-make-char-spec char))
 345     (unless (or (characterp char) ; char
 346                 (condition-case nil
 347                     (setq char (find-char char-spec))
 348                   (error nil)))
 349       ;; define temporary character
 350       ;;   Current implementation is dirty.
 351       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 352                                          char-spec)))
 353       (remove-char-attribute temp-char 'ideograph-daikanwa)
 354       (setq char temp-char))
 355     (insert-char-attributes char
 356                             readable
 357                             (union (mapcar #'car char-spec)
 358                                    required-features))
 359     (when temp-char
 360       ;; undefine temporary character
 361       ;;   Current implementation is dirty.
 362       (setq char-spec (char-attribute-alist temp-char))
 363       (while char-spec
 364         (remove-char-attribute temp-char (car (car char-spec)))
 365         (setq char-spec (cdr char-spec))))))
 366
 367 (defun char-db-insert-alist (alist &optional readable column)
 368   (unless column
 369     (setq column (current-column)))
 370   (let ((line-breaking
 371          (concat "\n" (make-string (1+ column) ?\ )))
 372         name value
 373         ret al ; cal
 374         key
 375         lbs cell rest separator)
 376     (insert "(")
 377     (while alist
 378       (setq name (car (car alist))
 379             value (cdr (car alist)))
 380       (cond ((eq name 'char)
 381              (insert "(char . ")
 382              (if (setq ret (condition-case nil
 383                                (find-char value)
 384                              (error nil)))
 385                  (progn
 386                    (setq al nil
 387                          ;; cal nil
 388                          )
 389                    (while value
 390                      (setq key (car (car value)))
 391                      ;; (if (find-charset key)
 392                      ;;     (setq cal (cons key cal))
 393                      (setq al (cons key al))
 394                      ;; )
 395                      (setq value (cdr value)))
 396                    (insert-char-attributes ret
 397                                            readable
 398                                            (or al 'none) ; cal
 399                                            ))
 400                (insert (prin1-to-string value)))
 401              (insert ")")
 402              (insert line-breaking))
 403             ((consp value)
 404              (insert (format "(%-18s " name))
 405              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 406              (while (consp value)
 407                (setq cell (car value))
 408                (if (and (consp cell)
 409                         (consp (car cell))
 410                         (setq ret (condition-case nil
 411                                       (find-char cell)
 412                                     (error nil)))
 413                         )
 414                    (progn
 415                      (setq rest cell
 416                            al nil
 417                            ;; cal nil
 418                            )
 419                      (while rest
 420                        (setq key (car (car rest)))
 421                        ;; (if (find-charset key)
 422                        ;;     (setq cal (cons key cal))
 423                        (setq al (cons key al))
 424                        ;; )
 425                        (setq rest (cdr rest)))
 426                      (if separator
 427                          (insert lbs))
 428                      (insert-char-attributes ret
 429                                              readable
 430                                              al ; cal
 431                                              )
 432                      (setq separator lbs))
 433                  (if separator
 434                      (insert separator))
 435                  (insert (prin1-to-string cell))
 436                  (setq separator " "))
 437                (setq value (cdr value)))
 438              (insert ")")
 439              (insert line-breaking))
 440             (t
 441              (insert (format "(%-18s . %S)%s"
 442                              name value
 443                              line-breaking))))
 444       (setq alist (cdr alist))))
 445   (insert ")"))
 446
 447 (defun char-db-insert-char-reference (plist &optional readable column)
 448   (unless column
 449     (setq column (current-column)))
 450   (let ((line-breaking
 451          (concat "\n" (make-string (1+ column) ?\ )))
 452         (separator "")
 453         name value)
 454     (insert "(")
 455     (while plist
 456       (setq name (pop plist))
 457       (setq value (pop plist))
 458       (cond ((eq name :char)
 459              (insert separator)
 460              (insert ":char\t")
 461              (cond ((numberp value)
 462                     (setq value (decode-char '=ucs value)))
 463                    ;; ((consp value)
 464                    ;;  (setq value (or (find-char value)
 465                    ;;                  value)))
 466                    )
 467              (char-db-insert-char-spec value readable)
 468              (insert line-breaking)
 469              (setq separator ""))
 470             ((eq name :radical)
 471              (insert (format "%s%s\t%d ; %c%s"
 472                              separator
 473                              name value
 474                              (ideographic-radical value)
 475                              line-breaking))
 476              (setq separator ""))
 477             (t
 478              (insert (format "%s%s\t%S" separator name value))
 479              (setq separator line-breaking)))
 480       ))
 481   (insert ")"))
 482
 483 (defun char-db-decode-isolated-char (ccs code-point)
 484   (let (ret)
 485     (setq ret
 486           (cond ((eq ccs 'arabic-iso8859-6)
 487                  (decode-char ccs code-point))
 488                 ((and (memq ccs '(=gt-pj-1
 489                                   =gt-pj-2
 490                                   =gt-pj-3
 491                                   =gt-pj-4
 492                                   =gt-pj-5
 493                                   =gt-pj-6
 494                                   =gt-pj-7
 495                                   =gt-pj-8
 496                                   =gt-pj-9
 497                                   =gt-pj-10
 498                                   =gt-pj-11))
 499                       (setq ret (decode-char ccs code-point))
 500                       (setq ret (encode-char ret '=gt 'defined-only)))
 501                  (decode-builtin-char '=gt ret))
 502                 (t
 503                  (decode-builtin-char ccs code-point))))
 504     (cond ((and (<= 0 (char-int ret))
 505                 (<= (char-int ret) #x1F))
 506            (decode-char '=ucs (+ #x2400 (char-int ret))))
 507           ((= (char-int ret) #x7F)
 508            ?\u2421)
 509           (t ret))))
 510
 511 (defvar char-db-convert-obsolete-format t)
 512
 513 (defun char-db-insert-ccs-feature (name value line-breaking)
 514   (insert
 515    (format
 516     (cond ((memq name '(=shinjigen
 517                         =shinjigen@1ed
 518                         =shinjigen@rev =shinjigen/+p@rev))
 519            "(%-18s .  %04d)\t; %c")
 520           ((eq name '=shinjigen@1ed/24pr)
 521            "(%-18s . %04d)\t; %c")
 522           ((or (memq name '(=daikanwa
 523                             =daikanwa@rev1 =daikanwa@rev2
 524                             =gt =gt-k =cbeta =zinbun-oracle))
 525                (string-match "^=adobe-" (symbol-name name)))
 526            "(%-18s . %05d)\t; %c")
 527           ((eq name 'mojikyo)
 528            "(%-18s . %06d)\t; %c")
 529           ((>= (charset-dimension name) 2)
 530            "(%-18s . #x%04X)\t; %c")
 531           (t
 532            "(%-18s . #x%02X)\t; %c"))
 533     name
 534     (if (= (charset-iso-graphic-plane name) 1)
 535         (logior value
 536                 (cond ((= (charset-dimension name) 1)
 537                        #x80)
 538                       ((= (charset-dimension name) 2)
 539                        #x8080)
 540                       ((= (charset-dimension name) 3)
 541                        #x808080)
 542                       (t 0)))
 543       value)
 544     (char-db-decode-isolated-char name value)))
 545   (if (and (= (charset-chars name) 94)
 546            (= (charset-dimension name) 2))
 547       (insert (format " [%02d-%02d]"
 548                       (- (lsh value -8) 32)
 549                       (- (logand value 255) 32))))
 550   (insert line-breaking))
 551
 552 (defun char-db-insert-relation-feature (char name value line-breaking
 553                                              ccss readable)
 554   (insert (format "(%-18s%s " name line-breaking))
 555   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 556         separator cell sources required-features
 557         ret)
 558     (while (consp value)
 559       (setq cell (car value))
 560       (if (integerp cell)
 561           (setq cell (decode-char '=ucs cell)))
 562       (cond
 563        ((eq name '->subsumptive)
 564         (when (or (not (some (lambda (atr)
 565                                (get-char-attribute cell atr))
 566                              char-db-ignored-attributes))
 567                   (some (lambda (ccs)
 568                           (encode-char cell ccs 'defined-only))
 569                         ccss))
 570           (if separator
 571               (insert lbs))
 572           (let ((char-db-ignored-attributes
 573                  (cons '<-subsumptive
 574                        char-db-ignored-attributes)))
 575             (insert-char-attributes cell readable))
 576           (setq separator lbs))
 577         )
 578        ((characterp cell)
 579         (setq sources
 580               (get-char-attribute
 581                char (intern (format "%s*sources" name))))
 582         (setq required-features nil)
 583         (dolist (source sources)
 584           (cond
 585            ((memq source '(JP
 586                            JP/Jouyou
 587                            shinjigen shinjigen@1ed shinjigen@rev))
 588             (setq required-features
 589                   (union required-features
 590                          '(=jis-x0208
 591                            =jis-x0208@1990
 592                            =jis-x0213-1-2000
 593                            =jis-x0213-2-2000
 594                            =jis-x0212
 595                            =jis-x0208@1983
 596                            =jis-x0208@1978
 597                            =shinjigen))))
 598            ((eq source 'CN)
 599             (setq required-features
 600                   (union required-features
 601                          '(=gb2312
 602                            =gb12345
 603                            =iso-ir165)))))
 604           (cond
 605            ((find-charset (setq ret (intern (format "=%s" source))))
 606             (setq required-features
 607                   (cons ret required-features)))
 608            (t (setq required-features
 609                     (cons source required-features)))))
 610         (cond ((string-match "@JP" (symbol-name name))
 611                (setq required-features
 612                      (union required-features
 613                             '(=jis-x0208
 614                               =jis-x0208@1990
 615                               =jis-x0213-1-2000
 616                               =jis-x0213-2-2000
 617                               =jis-x0212
 618                               =jis-x0208@1983
 619                               =jis-x0208@1978))))
 620               ((string-match "@CN" (symbol-name name))
 621                (setq required-features
 622                      (union required-features
 623                             '(=gb2312
 624                               =gb12345
 625                               =iso-ir165)))))
 626         (if separator
 627             (insert lbs))
 628         (if readable
 629             (insert (format "%S" cell))
 630           (char-db-insert-char-spec cell readable
 631                                     nil
 632                                     required-features))
 633         (setq separator lbs))
 634        ((consp cell)
 635         (if separator
 636             (insert lbs))
 637         (if (consp (car cell))
 638             (char-db-insert-char-spec cell readable)
 639           (char-db-insert-char-reference cell readable))
 640         (setq separator lbs))
 641        (t
 642         (if separator
 643             (insert separator))
 644         (insert (prin1-to-string cell))
 645         (setq separator " ")))
 646       (setq value (cdr value)))
 647     (insert ")")
 648     (insert line-breaking)))
 649
 650 (defun insert-char-attributes (char &optional readable attributes column)
 651   (unless column
 652     (setq column (current-column)))
 653   (let (name value ; has-long-ccs-name
 654         rest
 655         radical strokes
 656         (line-breaking
 657          (concat "\n" (make-string (1+ column) ?\ )))
 658         lbs cell separator ret
 659         key al cal
 660         dest-ccss ; sources required-features
 661         ccss)
 662     (let (atr-d)
 663       (setq attributes
 664             (sort (if attributes
 665                       (if (consp attributes)
 666                           (progn
 667                             (dolist (name attributes)
 668                               (unless (memq name char-db-ignored-attributes)
 669                                 (if (find-charset name)
 670                                     (push name ccss))
 671                                 (push name atr-d)))
 672                             atr-d))
 673                     (dolist (name (char-attribute-list))
 674                       (unless (memq name char-db-ignored-attributes)
 675                         (if (find-charset name)
 676                             (push name ccss))
 677                         (push name atr-d)))
 678                     atr-d)
 679                   #'char-attribute-name<)))
 680     (insert "(")
 681     (when (memq '<-subsumptive attributes)
 682       (when readable
 683         (when (setq value (get-char-attribute char '<-subsumptive))
 684           (char-db-insert-relation-feature char '<-subsumptive value
 685                                            line-breaking
 686                                            ccss readable)))
 687       (setq attributes (delq '<-subsumptive attributes)))
 688     (when (and (memq '<-denotational attributes)
 689                (setq value (get-char-attribute char '<-denotational)))
 690       (char-db-insert-relation-feature char '<-denotational value
 691                                        line-breaking
 692                                        ccss readable)
 693       (setq attributes (delq '<-denotational attributes)))
 694     (when (and (memq 'name attributes)
 695                (setq value (get-char-attribute char 'name)))
 696       (insert (format
 697                (if (> (+ (current-column) (length value)) 48)
 698                    "(name . %S)%s"
 699                  "(name               . %S)%s")
 700                value line-breaking))
 701       (setq attributes (delq 'name attributes))
 702       )
 703     (when (and (memq 'name* attributes)
 704                (setq value (get-char-attribute char 'name*)))
 705       (insert (format
 706                (if (> (+ (current-column) (length value)) 48)
 707                    "(name* . %S)%s"
 708                  "(name*              . %S)%s")
 709                value line-breaking))
 710       (setq attributes (delq 'name* attributes))
 711       )
 712     (when (and (memq 'script attributes)
 713                (setq value (get-char-attribute char 'script)))
 714       (insert (format "(script\t\t%s)%s"
 715                       (mapconcat (function prin1-to-string)
 716                                  value " ")
 717                       line-breaking))
 718       (setq attributes (delq 'script attributes))
 719       )
 720     (dolist (name '(=>ucs =>ucs*))
 721       (when (and (memq name attributes)
 722                  (setq value (get-char-attribute char name)))
 723         (insert (format "(%-18s . #x%04X)\t; %c%s"
 724                         name value (decode-char '=ucs value)
 725                         line-breaking))
 726         (setq attributes (delq name attributes))))
 727     (dolist (name '(=>ucs@gb =>ucs@cns =>ucs@jis =>ucs@ks =>ucs@big5))
 728       (when (and (memq name attributes)
 729                  (setq value (get-char-attribute char name)))
 730         (insert (format "(%-18s . #x%04X)\t; %c%s"
 731                         name value
 732                         (decode-char (intern
 733                                       (concat "="
 734                                               (substring
 735                                                (symbol-name name) 2)))
 736                                      value)
 737                         line-breaking))
 738         (setq attributes (delq name attributes))
 739         ))
 740     (dolist (name '(=>daikanwa))
 741       (when (and (memq name attributes)
 742                  (setq value (get-char-attribute char name)))
 743         (insert
 744          (if (integerp value)
 745              (format "(%-18s . %05d)\t; %c%s"
 746                      name value (decode-char '=daikanwa value)
 747                      line-breaking)
 748            (format "(%-18s %s)\t; %c%s"
 749                    name
 750                    (mapconcat (function prin1-to-string)
 751                               value " ")
 752                    (char-representative-of-daikanwa char)
 753                    line-breaking)))
 754         (setq attributes (delq name attributes))))
 755     (when (and (memq 'general-category attributes)
 756                (setq value (get-char-attribute char 'general-category)))
 757       (insert (format
 758                "(general-category\t%s) ; %s%s"
 759                (mapconcat (lambda (cell)
 760                             (format "%S" cell))
 761                           value " ")
 762                (cond ((rassoc value unidata-normative-category-alist)
 763                       "Normative Category")
 764                      ((rassoc value unidata-informative-category-alist)
 765                       "Informative Category")
 766                      (t
 767                       "Unknown Category"))
 768                line-breaking))
 769       (setq attributes (delq 'general-category attributes))
 770       )
 771     (when (and (memq 'bidi-category attributes)
 772                (setq value (get-char-attribute char 'bidi-category)))
 773       (insert (format "(bidi-category\t. %S)%s"
 774                       value
 775                       line-breaking))
 776       (setq attributes (delq 'bidi-category attributes))
 777       )
 778     (unless (or (not (memq 'mirrored attributes))
 779                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 780                     'empty))
 781       (insert (format "(mirrored\t\t. %S)%s"
 782                       value
 783                       line-breaking))
 784       (setq attributes (delq 'mirrored attributes))
 785       )
 786     (cond
 787      ((and (memq 'decimal-digit-value attributes)
 788            (setq value (get-char-attribute char 'decimal-digit-value)))
 789       (insert (format "(decimal-digit-value . %S)%s"
 790                       value
 791                       line-breaking))
 792       (setq attributes (delq 'decimal-digit-value attributes))
 793       (when (and (memq 'digit-value attributes)
 794                  (setq value (get-char-attribute char 'digit-value)))
 795         (insert (format "(digit-value\t . %S)%s"
 796                         value
 797                         line-breaking))
 798         (setq attributes (delq 'digit-value attributes))
 799         )
 800       (when (and (memq 'numeric-value attributes)
 801                  (setq value (get-char-attribute char 'numeric-value)))
 802         (insert (format "(numeric-value\t . %S)%s"
 803                         value
 804                         line-breaking))
 805         (setq attributes (delq 'numeric-value attributes))
 806         )
 807       )
 808      (t
 809       (when (and (memq 'digit-value attributes)
 810                  (setq value (get-char-attribute char 'digit-value)))
 811         (insert (format "(digit-value\t. %S)%s"
 812                         value
 813                         line-breaking))
 814         (setq attributes (delq 'digit-value attributes))
 815         )
 816       (when (and (memq 'numeric-value attributes)
 817                  (setq value (get-char-attribute char 'numeric-value)))
 818         (insert (format "(numeric-value\t. %S)%s"
 819                         value
 820                         line-breaking))
 821         (setq attributes (delq 'numeric-value attributes))
 822         )))
 823     (when (and (memq 'iso-10646-comment attributes)
 824                (setq value (get-char-attribute char 'iso-10646-comment)))
 825       (insert (format "(iso-10646-comment\t. %S)%s"
 826                       value
 827                       line-breaking))
 828       (setq attributes (delq 'iso-10646-comment attributes))
 829       )
 830     (when (and (memq 'morohashi-daikanwa attributes)
 831                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 832       (insert (format "(morohashi-daikanwa\t%s)%s"
 833                       (mapconcat (function prin1-to-string) value " ")
 834                       line-breaking))
 835       (setq attributes (delq 'morohashi-daikanwa attributes))
 836       )
 837     (setq radical nil
 838           strokes nil)
 839     (when (and (memq 'ideographic-radical attributes)
 840                (setq value (get-char-attribute char 'ideographic-radical)))
 841       (setq radical value)
 842       (insert (format "(ideographic-radical . %S)\t; %c%s"
 843                       radical
 844                       (ideographic-radical radical)
 845                       line-breaking))
 846       (setq attributes (delq 'ideographic-radical attributes))
 847       )
 848     (when (and (memq 'shuowen-radical attributes)
 849                (setq value (get-char-attribute char 'shuowen-radical)))
 850       (insert (format "(shuowen-radical\t. %S)\t; %c%s"
 851                       value
 852                       (shuowen-radical value)
 853                       line-breaking))
 854       (setq attributes (delq 'shuowen-radical attributes))
 855       )
 856     (let (key)
 857       (dolist (domain
 858                (append
 859                 char-db-feature-domains
 860                 (let (dest domain)
 861                   (dolist (feature (char-attribute-list))
 862                     (setq feature (symbol-name feature))
 863                     (when (string-match
 864                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
 865                            feature)
 866                       (setq domain (intern (match-string 2 feature)))
 867                      (unless (memq domain dest)
 868                        (setq dest (cons domain dest)))))
 869                   (sort dest #'string<))))
 870         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
 871         (when (and (memq key attributes)
 872                    (setq value (get-char-attribute char key)))
 873           (setq radical value)
 874           (insert (format "(%s . %S)\t; %c%s"
 875                           key
 876                           radical
 877                           (ideographic-radical radical)
 878                           line-breaking))
 879           (setq attributes (delq key attributes))
 880           )
 881         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
 882         (when (and (memq key attributes)
 883                    (setq value (get-char-attribute char key)))
 884           (setq strokes value)
 885           (insert (format "(%s . %S)%s"
 886                           key
 887                           strokes
 888                           line-breaking))
 889           (setq attributes (delq key attributes))
 890           )
 891         (setq key (intern (format "%s@%s" 'total-strokes domain)))
 892         (when (and (memq key attributes)
 893                    (setq value (get-char-attribute char key)))
 894           (insert (format "(%s       . %S)%s"
 895                           key
 896                           value
 897                           line-breaking))
 898           (setq attributes (delq key attributes))
 899           )
 900         (dolist (feature '(ideographic-radical
 901                            ideographic-strokes
 902                            total-strokes))
 903           (setq key (intern (format "%s@%s*sources" feature domain)))
 904           (when (and (memq key attributes)
 905                      (setq value (get-char-attribute char key)))
 906             (insert (format "(%s%s" key line-breaking))
 907             (dolist (cell value)
 908               (insert (format " %s" cell)))
 909             (insert ")")
 910             (insert line-breaking)
 911             (setq attributes (delq key attributes))
 912             ))
 913         ))
 914     (when (and (memq 'ideographic-strokes attributes)
 915                (setq value (get-char-attribute char 'ideographic-strokes)))
 916       (setq strokes value)
 917       (insert (format "(ideographic-strokes . %S)%s"
 918                       strokes
 919                       line-breaking))
 920       (setq attributes (delq 'ideographic-strokes attributes))
 921       )
 922     (when (and (memq 'kangxi-radical attributes)
 923                (setq value (get-char-attribute char 'kangxi-radical)))
 924       (unless (eq value radical)
 925         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 926                         value
 927                         (ideographic-radical value)
 928                         line-breaking))
 929         (or radical
 930             (setq radical value)))
 931       (setq attributes (delq 'kangxi-radical attributes))
 932       )
 933     (when (and (memq 'kangxi-strokes attributes)
 934                (setq value (get-char-attribute char 'kangxi-strokes)))
 935       (unless (eq value strokes)
 936         (insert (format "(kangxi-strokes\t . %S)%s"
 937                         value
 938                         line-breaking))
 939         (or strokes
 940             (setq strokes value)))
 941       (setq attributes (delq 'kangxi-strokes attributes))
 942       )
 943     (when (and (memq 'japanese-radical attributes)
 944                (setq value (get-char-attribute char 'japanese-radical)))
 945       (unless (eq value radical)
 946         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 947                         value
 948                         (ideographic-radical value)
 949                         line-breaking))
 950         (or radical
 951             (setq radical value)))
 952       (setq attributes (delq 'japanese-radical attributes))
 953       )
 954     (when (and (memq 'japanese-strokes attributes)
 955                (setq value (get-char-attribute char 'japanese-strokes)))
 956       (unless (eq value strokes)
 957         (insert (format "(japanese-strokes\t . %S)%s"
 958                         value
 959                         line-breaking))
 960         (or strokes
 961             (setq strokes value)))
 962       (setq attributes (delq 'japanese-strokes attributes))
 963       )
 964     (when (and (memq 'cns-radical attributes)
 965                (setq value (get-char-attribute char 'cns-radical)))
 966       (insert (format "(cns-radical\t . %S)\t; %c%s"
 967                       value
 968                       (ideographic-radical value)
 969                       line-breaking))
 970       (setq attributes (delq 'cns-radical attributes))
 971       )
 972     (when (and (memq 'cns-strokes attributes)
 973                (setq value (get-char-attribute char 'cns-strokes)))
 974       (unless (eq value strokes)
 975         (insert (format "(cns-strokes\t . %S)%s"
 976                         value
 977                         line-breaking))
 978         (or strokes
 979             (setq strokes value)))
 980       (setq attributes (delq 'cns-strokes attributes))
 981       )
 982     (when (and (memq 'shinjigen-1-radical attributes)
 983                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 984       (unless (eq value radical)
 985         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 986                         value
 987                         (ideographic-radical value)
 988                         line-breaking))
 989         (or radical
 990             (setq radical value)))
 991       (setq attributes (delq 'shinjigen-1-radical attributes))
 992       )
 993     (when (and (memq 'ideographic- attributes)
 994                (setq value (get-char-attribute char 'ideographic-)))
 995       (insert "(ideographic-       ")
 996       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 997             separator nil)
 998       (while (consp value)
 999         (setq cell (car value))
1000         (if (integerp cell)
1001             (setq cell (decode-char '=ucs cell)))
1002         (cond ((characterp cell)
1003                (if separator
1004                    (insert lbs))
1005                (if readable
1006                    (insert (format "%S" cell))
1007                  (char-db-insert-char-spec cell readable))
1008                (setq separator lbs))
1009               ((consp cell)
1010                (if separator
1011                    (insert lbs))
1012                (if (consp (car cell))
1013                    (char-db-insert-char-spec cell readable)
1014                  (char-db-insert-char-reference cell readable))
1015                (setq separator lbs))
1016               (t
1017                (if separator
1018                    (insert separator))
1019                (insert (prin1-to-string cell))
1020                (setq separator " ")))
1021         (setq value (cdr value)))
1022       (insert ")")
1023       (insert line-breaking)
1024       (setq attributes (delq 'ideographic- attributes)))
1025     (when (and (memq 'total-strokes attributes)
1026                (setq value (get-char-attribute char 'total-strokes)))
1027       (insert (format "(total-strokes       . %S)%s"
1028                       value
1029                       line-breaking))
1030       (setq attributes (delq 'total-strokes attributes))
1031       )
1032     (when (and (memq '->ideograph attributes)
1033                (setq value (get-char-attribute char '->ideograph)))
1034       (insert (format "(->ideograph\t%s)%s"
1035                       (mapconcat (lambda (code)
1036                                    (cond ((symbolp code)
1037                                           (symbol-name code))
1038                                          ((integerp code)
1039                                           (format "#x%04X" code))
1040                                          (t
1041                                           (format "%s %S"
1042                                                   line-breaking code))))
1043                                  value " ")
1044                       line-breaking))
1045       (setq attributes (delq '->ideograph attributes))
1046       )
1047     ;; (when (and (memq '->decomposition attributes)
1048     ;;            (setq value (get-char-attribute char '->decomposition)))
1049     ;;   (insert (format "(->decomposition\t%s)%s"
1050     ;;                   (mapconcat (lambda (code)
1051     ;;                                (cond ((symbolp code)
1052     ;;                                       (symbol-name code))
1053     ;;                                      ((characterp code)
1054     ;;                                       (if readable
1055     ;;                                           (format "%S" code)
1056     ;;                                         (format "#x%04X"
1057     ;;                                                 (char-int code))
1058     ;;                                         ))
1059     ;;                                      ((integerp code)
1060     ;;                                       (format "#x%04X" code))
1061     ;;                                      (t
1062     ;;                                       (format "%s%S" line-breaking code))))
1063     ;;                              value " ")
1064     ;;                   line-breaking))
1065     ;;   (setq attributes (delq '->decomposition attributes))
1066     ;;   )
1067     (if (equal (get-char-attribute char '->titlecase)
1068                (get-char-attribute char '->uppercase))
1069         (setq attributes (delq '->titlecase attributes)))
1070     (when (and (memq '->mojikyo attributes)
1071                (setq value (get-char-attribute char '->mojikyo)))
1072       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
1073                       value (decode-char 'mojikyo value)
1074                       line-breaking))
1075       (setq attributes (delq '->mojikyo attributes))
1076       )
1077     (when (and (memq 'hanyu-dazidian-vol attributes)
1078                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
1079       (insert (format "(hanyu-dazidian-vol  . %d)%s"
1080                       value line-breaking))
1081       (setq attributes (delq 'hanyu-dazidian-vol attributes))
1082       )
1083     (when (and (memq 'hanyu-dazidian-page attributes)
1084                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
1085       (insert (format "(hanyu-dazidian-page . %d)%s"
1086                       value line-breaking))
1087       (setq attributes (delq 'hanyu-dazidian-page attributes))
1088       )
1089     (when (and (memq 'hanyu-dazidian-char attributes)
1090                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
1091       (insert (format "(hanyu-dazidian-char . %d)%s"
1092                       value line-breaking))
1093       (setq attributes (delq 'hanyu-dazidian-char attributes))
1094       )
1095     (unless readable
1096       (dolist (ignored '(composition
1097                          ->denotational <-subsumptive ->ucs-unified
1098                          ->ideographic-component-forms))
1099         (setq attributes (delq ignored attributes))))
1100     (while attributes
1101       (setq name (car attributes))
1102       (if (setq value (get-char-attribute char name))
1103           (cond ((setq ret (find-charset name))
1104                  (setq name (charset-name ret))
1105                  (if (and (not (memq name dest-ccss))
1106                           (prog1
1107                               (setq value (get-char-attribute char name))
1108                             (setq dest-ccss (cons name dest-ccss))))
1109                      (char-db-insert-ccs-feature name value line-breaking))
1110                  )
1111                 ((string-match "^=>ucs@" (symbol-name name))
1112                  (insert (format "(%-18s . #x%04X)\t; %c%s"
1113                                  name value (decode-char '=ucs value)
1114                                  line-breaking))
1115                  )
1116                 ((eq name 'jisx0208-1978/4X)
1117                  (insert (format "(%-18s . #x%04X)%s"
1118                                  name value
1119                                  line-breaking))
1120                  )
1121                 ((and
1122                   (not readable)
1123                   (not (eq name '->subsumptive))
1124                   (not (eq name '->uppercase))
1125                   (not (eq name '->lowercase))
1126                   (not (eq name '->titlecase))
1127                   (not (eq name '->canonical))
1128                   (not (eq name '->Bopomofo))
1129                   (not (eq name '->mistakable))
1130                   (not (eq name '->ideographic-variants))
1131                   (null (get-char-attribute
1132                          char (intern (format "%s*sources" name))))
1133                   (not (string-match "\\*sources$" (symbol-name name)))
1134                   (null (get-char-attribute
1135                          char (intern (format "%s*note" name))))
1136                   (not (string-match "\\*note$" (symbol-name name)))
1137                   (or (eq name '<-identical)
1138                       (eq name '<-uppercase)
1139                       (eq name '<-lowercase)
1140                       (eq name '<-titlecase)
1141                       (eq name '<-canonical)
1142                       (eq name '<-ideographic-variants)
1143                       ;; (eq name '<-synonyms)
1144                       (string-match "^<-synonyms" (symbol-name name))
1145                       (eq name '<-mistakable)
1146                       (when (string-match "^->" (symbol-name name))
1147                         (cond
1148                          ((string-match "^->fullwidth" (symbol-name name))
1149                           (not (and (consp value)
1150                                     (characterp (car value))
1151                                     (encode-char
1152                                      (car value) '=ucs 'defined-only)))
1153                           )
1154                          (t)))
1155                       ))
1156                  )
1157                 ((or (eq name 'ideographic-structure)
1158                      (eq name 'ideographic-combination)
1159                      (eq name 'ideographic-)
1160                      (eq name '=decomposition)
1161                      (string-match "^=>decomposition" (symbol-name name))
1162                      (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
1163                      (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
1164                                    (symbol-name name))
1165                      )
1166                  (char-db-insert-relation-feature char name value
1167                                                   line-breaking
1168                                                   ccss readable))
1169                 ((memq name '(ideograph=
1170                               original-ideograph-of
1171                               ancient-ideograph-of
1172                               vulgar-ideograph-of
1173                               wrong-ideograph-of
1174                               ;; simplified-ideograph-of
1175                               ideographic-variants
1176                               ;; ideographic-different-form-of
1177                               ))
1178                  (insert (format "(%-18s%s " name line-breaking))
1179                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1180                        separator nil)
1181                  (while (consp value)
1182                    (setq cell (car value))
1183                    (if (and (consp cell)
1184                             (consp (car cell)))
1185                        (progn
1186                          (if separator
1187                              (insert lbs))
1188                          (char-db-insert-alist cell readable)
1189                          (setq separator lbs))
1190                      (if separator
1191                          (insert separator))
1192                      (insert (prin1-to-string cell))
1193                      (setq separator " "))
1194                    (setq value (cdr value)))
1195                  (insert ")")
1196                  (insert line-breaking))
1197                 ((consp value)
1198                  (insert (format "(%-18s " name))
1199                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1200                        separator nil)
1201                  (while (consp value)
1202                    (setq cell (car value))
1203                    (if (and (consp cell)
1204                             (consp (car cell))
1205                             (setq ret (condition-case nil
1206                                           (find-char cell)
1207                                         (error nil))))
1208                        (progn
1209                          (setq rest cell
1210                                al nil
1211                                cal nil)
1212                          (while rest
1213                            (setq key (car (car rest)))
1214                            (if (find-charset key)
1215                                (setq cal (cons key cal))
1216                              (setq al (cons key al)))
1217                            (setq rest (cdr rest)))
1218                          (if separator
1219                              (insert lbs))
1220                          (insert-char-attributes ret
1221                                                  readable
1222                                                  al cal)
1223                          (setq separator lbs))
1224                      (setq ret (prin1-to-string cell))
1225                      (if separator
1226                          (if (< (+ (current-column)
1227                                    (length ret)
1228                                    (length separator))
1229                                 76)
1230                              (insert separator)
1231                            (insert lbs)))
1232                      (insert ret)
1233                      (setq separator " "))
1234                    (setq value (cdr value)))
1235                  (insert ")")
1236                  (insert line-breaking))
1237                 (t
1238                  (insert (format "(%-18s" name))
1239                  (setq ret (prin1-to-string value))
1240                  (unless (< (+ (current-column)
1241                                (length ret)
1242                                3)
1243                             76)
1244                    (insert line-breaking))
1245                  (insert " . " ret ")" line-breaking)
1246                  ;; (insert (format "(%-18s . %S)%s"
1247                  ;;                 name value
1248                  ;;                 line-breaking))
1249                  )
1250                 ))
1251       (setq attributes (cdr attributes)))
1252     (insert ")")))
1253
1254 (defun insert-char-data (char &optional readable
1255                               attributes)
1256   (save-restriction
1257     (narrow-to-region (point)(point))
1258     (insert "(define-char
1259   '")
1260     (insert-char-attributes char readable attributes)
1261     (insert ")\n")
1262     (goto-char (point-min))
1263     (while (re-search-forward "[ \t]+$" nil t)
1264       (replace-match ""))
1265     ;; from tabify.
1266     (goto-char (point-min))
1267     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1268       (let ((column (current-column))
1269             (indent-tabs-mode t))
1270         (delete-region (match-beginning 0) (point))
1271         (indent-to column)))
1272     (goto-char (point-max))
1273     ;; (tabify (point-min)(point-max))
1274     ))
1275
1276 (defun insert-char-data-with-variant (char &optional printable
1277                                            no-ucs-unified
1278                                            script excluded-script)
1279   (insert-char-data char printable)
1280   (let ((variants (char-variants char))
1281         rest
1282         variant vs ret)
1283     (setq variants (sort variants #'<))
1284     (setq rest variants)
1285     (setq variants (cons char variants))
1286     (while rest
1287       (setq variant (car rest))
1288       (unless (get-char-attribute variant '<-subsumptive)
1289         (if (and (or (null script)
1290                      (null (setq vs (get-char-attribute variant 'script)))
1291                      (memq script vs))
1292                  (or (null excluded-script)
1293                      (null (setq vs (get-char-attribute variant 'script)))
1294                      (not (memq excluded-script vs))))
1295             (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1296               (insert-char-data variant printable)
1297               (if (setq ret (char-variants variant))
1298                   (while ret
1299                     (or (memq (car ret) variants)
1300                         ;; (get-char-attribute (car ret) '<-subsumptive)
1301                         (setq rest (nconc rest (list (car ret)))))
1302                     (setq ret (cdr ret)))))))
1303       (setq rest (cdr rest)))))
1304
1305 (defun insert-char-range-data (min max &optional script excluded-script)
1306   (let ((code min)
1307         char)
1308     (while (<= code max)
1309       (setq char (decode-char '=ucs code))
1310       (if (encode-char char '=ucs 'defined-only)
1311           (insert-char-data-with-variant char nil 'no-ucs-unified
1312                                          script excluded-script))
1313       (setq code (1+ code)))))
1314
1315 (defun write-char-range-data-to-file (min max file
1316                                           &optional script excluded-script)
1317   (let ((coding-system-for-write char-db-file-coding-system))
1318     (with-temp-buffer
1319       (insert (format ";; -*- coding: %s -*-\n"
1320                       char-db-file-coding-system))
1321       (insert-char-range-data min max script excluded-script)
1322       (write-region (point-min)(point-max) file))))
1323
1324 (defvar what-character-original-window-configuration)
1325
1326 ;;;###autoload
1327 (defun what-char-definition (char)
1328   (interactive (list (char-after)))
1329   (let ((buf (get-buffer-create "*Character Description*"))
1330         (the-buf (current-buffer))
1331         (win-conf (current-window-configuration)))
1332     (pop-to-buffer buf)
1333     (make-local-variable 'what-character-original-window-configuration)
1334     (setq what-character-original-window-configuration win-conf)
1335     (setq buffer-read-only nil)
1336     (erase-buffer)
1337     (condition-case err
1338         (progn
1339           (insert-char-data-with-variant char 'printable)
1340           (unless (char-attribute-alist char)
1341             (insert (format ";; = %c\n"
1342                             (let* ((rest (split-char char))
1343                                    (ccs (pop rest))
1344                                    (code (pop rest)))
1345                               (while rest
1346                                 (setq code (logior (lsh code 8)
1347                                                    (pop rest))))
1348                               (decode-char ccs code)))))
1349           ;; (char-db-update-comment)
1350           (set-buffer-modified-p nil)
1351           (view-mode the-buf (lambda (buf)
1352                                (set-window-configuration
1353                                 what-character-original-window-configuration)
1354                                ))
1355           (goto-char (point-min)))
1356       (error (progn
1357                (set-window-configuration
1358                 what-character-original-window-configuration)
1359                (signal (car err) (cdr err)))))))
1360
1361 (provide 'char-db-util)
1362
1363 ;;; char-db-util.el ends here