git.chise.org Git - chise/xemacs-chise.git.1/blob - 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,2007,
   4 ;;   2008,2009,2010,2011,2012,2013,2014,2015,2016 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 'chise-subr)
  29 (require 'ideograph-subr)
  30
  31 (defconst unidata-normative-category-alist
  32   '(("Lu" letter        uppercase)
  33     ("Ll" letter        lowercase)
  34     ("Lt" letter        titlecase)
  35     ("Mn" mark          non-spacing)
  36     ("Mc" mark          spacing-combining)
  37     ("Me" mark          enclosing)
  38     ("Nd" number        decimal-digit)
  39     ("Nl" number        letter)
  40     ("No" number        other)
  41     ("Zs" separator     space)
  42     ("Zl" separator     line)
  43     ("Zp" separator     paragraph)
  44     ("Cc" other         control)
  45     ("Cf" other         format)
  46     ("Cs" other         surrogate)
  47     ("Co" other         private-use)
  48     ("Cn" other         not-assigned)))
  49
  50 (defconst unidata-informative-category-alist
  51   '(("Lm" letter        modifier)
  52     ("Lo" letter        other)
  53     ("Pc" punctuation   connector)
  54     ("Pd" punctuation   dash)
  55     ("Ps" punctuation   open)
  56     ("Pe" punctuation   close)
  57     ("Pi" punctuation   initial-quote)
  58     ("Pf" punctuation   final-quote)
  59     ("Po" punctuation   other)
  60     ("Sm" symbol        math)
  61     ("Sc" symbol        currency)
  62     ("Sk" symbol        modifier)
  63     ("So" symbol        other)
  64     ))
  65
  66 (defconst shuowen-radicals
  67   [?一 ?上 ?示 ?三 ?王 ?玉 ?玨 ?气 ?士 ?丨 ; 010
  68    ?屮 ?艸 ?蓐 ?茻 ?小 ?八 ?釆 ?半 ?牛 ?犛 ; 020
  69    ?告 ?口 ?凵 ?吅 ?哭 ?走 ?止 ?癶 ?步 ?此 ; 030
  70    ?正 ?是 ?辵 ?彳 ?廴 ?㢟 ?行 ?齒 ?牙 ?足 ; 040
  71    ?疋 ?品 ?龠 ?冊 ?㗊 ?舌 ?干 ?谷 ?只 ?㕯 ; 050
  72    ?句 ?丩 ?古 ?十 ?卅 ?言 ?誩 ?音 ?䇂 ?丵 ; 060
  73    ?菐 ?𠬞 ?𠬜 ?共 ?異 ?舁 ?𦥑 ?䢅 ?爨 ?革 ; 070
  74    ?鬲 ?䰜 ?爪 ?𠃨 ?鬥 ?又 ?𠂇 ?㕜 ?支 ?𦘒 ; 080
  75    ?聿 ?畫 ?隶 ?臤 ?臣 ?殳 ?殺 ?𠘧 ?寸 ?皮 ; 090
  76    ?㼱 ?攴 ?敎 ?卜 ?用 ?爻 ?㸚 ?𥄎 ?目 ?䀠 ; 100
  77    ?眉 ?盾 ?自 ?白 ?鼻 ?皕 ?習 ?羽 ?隹 ?奞 ; 110
  78    ?萑 ?𦫳 ?苜 ?羊 ?羴 ?瞿 ?雔 ?雥 ?鳥 ?烏 ; 120
  79    ?𠦒 ?冓 ?幺 ?𢆶 ?叀 ?玄 ?予 ?放 ?𠬪 ?𣦼 ; 130
  80    ?歺 ?死 ?冎 ?骨 ?肉 ?筋 ?刀 ?刃 ?㓞 ?丰 ; 140
  81    ?耒 ?𧢲 ?竹 ?箕 ?丌 ?左 ?工 ?㠭 ?巫 ?甘 ; 150
  82    ?曰 ?乃 ?丂 ?可 ?兮 ?号 ?亏 ?旨 ?喜 ?壴 ; 160
  83 ;  ?旨 ?曰 ?乃 ?丂 ?可 ?兮 ?号 ?亏 ?喜 ?壴 ; 160
  84    ?鼓 ?豈 ?豆 ?豊 ?豐 ?䖒 ?虍 ?虎 ?虤 ?皿 ; 170
  85    ?𠙴 ?去 ?血 ?丶 ?丹 ?青 ?井 ?皀 ?鬯 ?食 ; 180
  86    ?亼 ?會 ?倉 ?入 ?缶 ?矢 ?高 ?冂 ?𩫏 ?京 ; 190
  87    ?亯 ?𣆪 ?畗 ?㐭 ?嗇 ?來 ?麥 ?夊 ?舛 ?䑞 ; 200
  88    ?韋 ?弟 ?夂 ?久 ?桀 ?木 ?東 ?林 ?才 ?叒 ; 210
  89    ?之 ?帀 ?出 ?𣎵 ?生 ?乇 ?𠂹 ?𠌶 ?華 ?𥝌 ; 220
  90    ?稽 ?巢 ?桼 ?束 ?㯻 ?囗 ?員 ?貝 ?邑 ?𨛜 ; 230
  91    ?日 ?旦 ?倝 ?㫃 ?冥 ?晶 ?月 ?有 ?明 ?囧 ; 240
  92    ?夕 ?多 ?毌 ?𢎘 ?𣐺 ?卣 ?齊 ?朿 ?片 ?鼎 ; 250
  93    ?克 ?彔 ?禾 ?秝 ?黍 ?香 ?米 ?毇 ?臼 ?凶 ; 260
  94    ?𣎳 ?林 ?麻 ?尗 ?耑 ?韭 ?瓜 ?瓠 ?宀 ?宮 ; 270
  95    ?呂 ?穴 ?㝱 ?𤕫 ?冖 ?𠔼 ?冃 ?㒳 ?网 ?襾 ; 280
  96    ?巾 ?巿 ?帛 ?白 ?㡀 ?黹 ?人 ?𠤎 ?匕 ?从 ; 290
  97    ?比 ?北 ?丘 ?㐺 ?𡈼 ?重 ?臥 ?身 ?㐆 ?衣 ; 300
  98    ?裘 ?老 ?毛 ?毳 ?尸 ?尺 ?尾 ?履 ?舟 ?方 ; 310
  99    ?儿 ?兄 ?兂 ?皃 ?𠑹 ?先 ?秃 ?見 ?覞 ?欠 ; 320
 100    ?㱃 ?㳄 ?旡 ?頁 ?𦣻 ?面 ?丏 ?首 ?𥄉 ?須 ; 330
 101    ?彡 ?彣 ?文 ?髟 ?后 ?司 ?卮 ?卩 ?印 ?色 ; 340
 102    ?𠨍 ?辟 ?勹 ?包 ?茍 ?鬼 ?甶 ?厶 ?嵬 ?山 ; 350
 103    ?屾 ?屵 ?广 ?厂 ?丸 ?危 ?石 ?長 ?勿 ?冄 ; 360
 104    ?而 ?豕 ?㣇 ?彑 ?豚 ?豸 ?𤉡 ?易 ?象 ?馬 ; 370
 105    ?𢊁 ?鹿 ?麤 ?㲋 ?兔 ?萈 ?犬 ?㹜 ?鼠 ?能 ; 380
 106    ?熊 ?火 ?炎 ?黑 ?囪 ?焱 ?炙 ?赤 ?大 ?亦 ; 390
 107    ])
 108
 109 (defun shuowen-radical (number)
 110   (aref shuowen-radicals (1- number)))
 111
 112 (defvar char-db-file-coding-system 'utf-8-mcs-er)
 113
 114 (defvar char-db-ignored-attributes '(ideographic-products))
 115
 116 (defvar char-db-coded-charset-priority-list
 117   '(ascii
 118     control-1
 119     latin-iso8859-1
 120     latin-iso8859-2
 121     latin-iso8859-3
 122     latin-iso8859-4
 123     latin-iso8859-9
 124     latin-jisx0201
 125     cyrillic-iso8859-5
 126     greek-iso8859-7
 127     thai-tis620
 128     ;; =mj
 129     ;; =adobe-japan1-0
 130     ;; =adobe-japan1-1
 131     ;; =adobe-japan1-2
 132     ;; =adobe-japan1-3
 133     ;; =adobe-japan1-4
 134     ;; =adobe-japan1-5
 135     ;; =adobe-japan1-6
 136     =jis-x0208
 137     =jis-x0208@1978
 138     =jis-x0208@1983
 139     japanese-jisx0212
 140     chinese-gb2312
 141     =jis-x0208@1990
 142     chinese-cns11643-1
 143     chinese-cns11643-2
 144     chinese-cns11643-3
 145     chinese-cns11643-4
 146     chinese-cns11643-5
 147     chinese-cns11643-6
 148     chinese-cns11643-7
 149     =jis-x0213-1
 150     =jis-x0213-1@2000
 151     =jis-x0213-1@2004
 152     =jis-x0213-2
 153     korean-ksc5601
 154     chinese-isoir165
 155     katakana-jisx0201
 156     hebrew-iso8859-8
 157     chinese-gb12345
 158     latin-viscii
 159     ethiopic-ucs
 160     =big5-cdp
 161     =hanyo-denshi/ja
 162     =hanyo-denshi/jb
 163     =hanyo-denshi/jc
 164     =hanyo-denshi/jd
 165     =hanyo-denshi/ft
 166     =hanyo-denshi/ia
 167     =hanyo-denshi/ib
 168     =hanyo-denshi/hg
 169     =hanyo-denshi/jt
 170     =hanyo-denshi/ks
 171     =hanyo-denshi/tk
 172     ;; ==mj
 173     ;; ==adobe-japan1-0
 174     ;; ==adobe-japan1-1
 175     ;; ==adobe-japan1-2
 176     ;; ==adobe-japan1-3
 177     ;; ==adobe-japan1-4
 178     ;; ==adobe-japan1-5
 179     ;; ==adobe-japan1-6
 180     ==jis-x0208
 181     ==jis-x0213-1
 182     ==jis-x0213-2
 183     ==jis-x0212
 184     ==hanyo-denshi/ja
 185     ==hanyo-denshi/jb
 186     ==hanyo-denshi/jc
 187     ==hanyo-denshi/ft
 188     ==hanyo-denshi/ib
 189     ==hanyo-denshi/hg
 190     ==hanyo-denshi/jt
 191     ==hanyo-denshi/ks
 192     =gt
 193     =gt-k
 194     =daikanwa
 195     =daikanwa@rev2
 196     =daikanwa@rev1
 197     =daikanwa/+p
 198     ==daikanwa
 199     =cbeta
 200     ideograph-hanziku-1
 201     ideograph-hanziku-2
 202     ideograph-hanziku-3
 203     ideograph-hanziku-4
 204     ideograph-hanziku-5
 205     ideograph-hanziku-6
 206     ideograph-hanziku-7
 207     ideograph-hanziku-8
 208     ideograph-hanziku-9
 209     ideograph-hanziku-10
 210     ideograph-hanziku-11
 211     ideograph-hanziku-12
 212     ;; =>>>adobe-japan1-0
 213     ;; =>>>adobe-japan1-1
 214     ;; =>>>adobe-japan1-2
 215     ;; =>>>adobe-japan1-3
 216     ;; =>>>adobe-japan1-4
 217     ;; =>>>adobe-japan1-5
 218     ;; =>>>adobe-japan1-6
 219     ;; =>>>jis-x0208
 220     ;; =>>>jis-x0213-1
 221     ;; =>>>jis-x0213-2
 222     ;; =>>>hanyo-denshi/ja
 223     ;; =>>>hanyo-denshi/jb
 224     ;; =>>>hanyo-denshi/jc
 225     ;; =>>>hanyo-denshi/ft
 226     ;; =>>>hanyo-denshi/ib
 227     ;; =>>>hanyo-denshi/hg
 228     ;; =>>>hanyo-denshi/jt
 229     ;; =>>>hanyo-denshi/ks
 230     ;; =>>>gt
 231     =>>adobe-japan1-0
 232     =>>adobe-japan1-1
 233     =>>adobe-japan1-2
 234     =>>adobe-japan1-3
 235     =>>adobe-japan1-4
 236     =>>adobe-japan1-5
 237     =>>adobe-japan1-6
 238     =>>jis-x0208
 239     =>>jis-x0213-1
 240     =>>jis-x0213-1@2000
 241     =>>jis-x0213-1@2004
 242     =>>jis-x0213-2
 243     =>>jis-x0208@1978
 244     =>>hanyo-denshi/ft
 245     =>>hanyo-denshi/jt
 246     =>>hanyo-denshi/ks
 247     =>>gt
 248     =>>daikanwa
 249     =>>cbeta
 250     =+>jis-x0208
 251     =+>jis-x0213-1
 252     =+>jis-x0213-2
 253     =+>adobe-japan1-0
 254     =+>adobe-japan1-1
 255     =+>adobe-japan1-2
 256     =+>adobe-japan1-3
 257     =+>adobe-japan1-4
 258     =+>adobe-japan1-5
 259     =+>adobe-japan1-6
 260     =+>jis-x0208@1978
 261     =>jis-x0208
 262     =>jis-x0208@1997
 263     =>jis-x0213-1
 264     =>jis-x0213-1@2000
 265     =>jis-x0213-1@2004
 266     =>jis-x0213-2
 267     ==>ucs@bucs
 268     =>iwds-1
 269     =>ucs@hanyo-denshi
 270     =>ucs@iso
 271     =>ucs@unicode
 272     =>ucs@jis
 273     =>ucs@cns
 274     =>ucs@ks
 275     =+>ucs@iso
 276     =+>ucs@unicode
 277     =+>ucs@jis
 278     =+>ucs@jis/1990
 279     =+>ucs@cns
 280     =+>ucs@ks
 281     =>>ucs@iso
 282     =>>ucs@unicode
 283     =>>ucs@jis
 284     =>>ucs@cns
 285     =>>>ucs@iso
 286     =>>>ucs@unicode
 287     ==ucs@iso
 288     ==ucs@unicode
 289     ;; ==ucs@cns
 290     ==gb2312
 291     ==ks-x1001
 292     ==cns11643-1
 293     ==cns11643-2
 294     ==cns11643-3
 295     ==cns11643-4
 296     ==cns11643-5
 297     ==cns11643-6
 298     ==cns11643-7
 299     ==gt
 300     ==jis-x0208@1990
 301     ;; ==jis-x0208@1983
 302     ==jis-x0208@1978
 303     ==gt-k
 304     =ucs@iso
 305     =ucs@unicode
 306     =ucs@cns
 307     ==big5-cdp
 308     ==cbeta
 309     =>>big5-cdp
 310     =>>gt-k
 311     =+>gt
 312     =>gt
 313     =>mj
 314     =>big5-cdp
 315     =>daikanwa
 316     =>daikanwa/ho
 317     =>cns11643-5
 318     =>cns11643-7
 319     =big5
 320     =big5-eten
 321     =>gt-k
 322     =zinbun-oracle
 323     =>zinbun-oracle
 324     =ruimoku-v6
 325     =>>ruimoku-v6
 326     ==ruimoku-v6
 327     =jef-china3
 328     =>cbeta
 329     =shinjigen
 330     =ucs-var-001
 331     =ucs-var-002
 332     =ucs-var-003
 333     =ucs-itaiji-001
 334     =ucs-itaiji-002
 335     =ucs-itaiji-003
 336     =ucs-itaiji-004
 337     =ucs-itaiji-005
 338     =ucs-itaiji-006
 339     =ucs-itaiji-008
 340     =big5-cdp-var-3
 341     =big5-cdp-var-5
 342     =>ucs@iwds-1))
 343
 344
 345 ;;; @ char-db formatters
 346 ;;;
 347
 348 (defun char-db-make-char-spec (char)
 349   (let (ret char-spec)
 350     (cond ((characterp char)
 351            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 352                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 353                   (setq char-spec (list (cons '=ucs ret)))
 354                   (cond ((setq ret (get-char-attribute char 'name))
 355                          (setq char-spec (cons (cons 'name ret) char-spec))
 356                          )
 357                         ((setq ret (get-char-attribute char 'name*))
 358                          (setq char-spec (cons (cons 'name* ret) char-spec))
 359                          ))
 360                   )
 361                  ((encode-char char '=mj 'defined-only)
 362                   (setq char-spec nil)
 363                   (dolist (ccs (charset-list))
 364                     (if (and (or (eq ccs '=mj)
 365                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 366                                  (string-match "=ucs@" (symbol-name ccs))
 367                                  )
 368                              (setq ccs (charset-name ccs))
 369                              (null (assq ccs char-spec))
 370                              (setq ret (encode-char char ccs 'defined-only)))
 371                         (setq char-spec (cons (cons ccs ret) char-spec))))
 372                   )
 373                  ((encode-char char '==mj 'defined-only)
 374                   (setq char-spec nil)
 375                   (dolist (ccs (charset-list))
 376                     (if (and (or (eq ccs '==mj)
 377                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 378                                  (string-match "=ucs@" (symbol-name ccs))
 379                                  )
 380                              (setq ccs (charset-name ccs))
 381                              (null (assq ccs char-spec))
 382                              (setq ret (encode-char char ccs 'defined-only)))
 383                         (setq char-spec (cons (cons ccs ret) char-spec))))
 384                   )
 385                  ((encode-char char '=adobe-japan1 'defined-only)
 386                   (setq char-spec nil)
 387                   (dolist (ccs (charset-list))
 388                     (if (and (or (memq ccs
 389                                        '(=adobe-japan1-0
 390                                          =adobe-japan1-1
 391                                          =adobe-japan1-2
 392                                          =adobe-japan1-3
 393                                          =adobe-japan1-4
 394                                          =adobe-japan1-5
 395                                          =adobe-japan1-6
 396                                          ))
 397                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 398                                  (string-match "=ucs@" (symbol-name ccs))
 399                                  )
 400                              (setq ccs (charset-name ccs))
 401                              (null (assq ccs char-spec))
 402                              (setq ret (encode-char char ccs 'defined-only)))
 403                         (setq char-spec (cons (cons ccs ret) char-spec))))
 404                   )
 405                  ((encode-char char '==adobe-japan1 'defined-only)
 406                   (setq char-spec nil)
 407                   (dolist (ccs (charset-list))
 408                     (if (and (or (memq ccs
 409                                        '(==adobe-japan1-0
 410                                          ==adobe-japan1-1
 411                                          ==adobe-japan1-2
 412                                          ==adobe-japan1-3
 413                                          ==adobe-japan1-4
 414                                          ==adobe-japan1-5
 415                                          ==adobe-japan1-6
 416                                          ))
 417                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 418                                  (string-match "=ucs@" (symbol-name ccs))
 419                                  )
 420                              (setq ccs (charset-name ccs))
 421                              (null (assq ccs char-spec))
 422                              (setq ret (encode-char char ccs 'defined-only)))
 423                         (setq char-spec (cons (cons ccs ret) char-spec))))
 424                   )
 425                  ((setq ret
 426                         (catch 'tag
 427                           (let ((rest char-db-coded-charset-priority-list)
 428                                 ccs)
 429                             (while rest
 430                               (setq ccs (charset-name
 431                                          (find-charset (car rest))))
 432                               (if (setq ret
 433                                         (encode-char char ccs
 434                                                      'defined-only))
 435                                   (throw 'tag (cons ccs ret)))
 436                               (setq rest (cdr rest))))))
 437                   (setq char-spec (list ret))
 438                   (dolist (ccs (delq (car ret) (charset-list)))
 439                     (if (and (or (charset-iso-final-char ccs)
 440                                  (memq ccs
 441                                        '(=daikanwa
 442                                          =daikanwa@rev2
 443                                          ;; =gt-k
 444                                          =jis-x0208@1997
 445                                          ))
 446                                  (eq (charset-property ccs 'iso-ir) 177)
 447                                  ;; (string-match "=ucs@" (symbol-name ccs))
 448                                  )
 449                              (setq ccs (charset-name ccs))
 450                              (null (assq ccs char-spec))
 451                              (setq ret (encode-char char ccs 'defined-only)))
 452                         (setq char-spec (cons (cons ccs ret) char-spec))))
 453                   (if (null char-spec)
 454                       (setq char-spec (split-char char)))
 455                   (cond ((setq ret (get-char-attribute char 'name))
 456                          (setq char-spec (cons (cons 'name ret) char-spec))
 457                          )
 458                         ((setq ret (get-char-attribute char 'name*))
 459                          (setq char-spec (cons (cons 'name* ret) char-spec))
 460                          ))
 461                   )
 462                  ((setq ret (get-char-attribute
 463                              char 'ideographic-combination))
 464                   (setq char-spec
 465                         (cons (cons 'ideographic-combination ret)
 466                               char-spec))
 467                   ))
 468            char-spec)
 469           ((consp char)
 470            char))))
 471
 472 (defun char-db-insert-char-spec (char &optional readable column
 473                                       required-features)
 474   (unless column
 475     (setq column (current-column)))
 476   (let (char-spec temp-char)
 477     (setq char-spec (char-db-make-char-spec char))
 478     (unless (or (characterp char) ; char
 479                 (condition-case nil
 480                     (setq char (find-char char-spec))
 481                   (error nil)))
 482       ;; define temporary character
 483       ;;   Current implementation is dirty.
 484       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 485                                          char-spec)))
 486       (remove-char-attribute temp-char 'ideograph-daikanwa)
 487       (setq char temp-char))
 488     (insert-char-attributes char
 489                             readable
 490                             (union (mapcar #'car char-spec)
 491                                    required-features)
 492                             nil 'for-sub-node)
 493     (when temp-char
 494       ;; undefine temporary character
 495       ;;   Current implementation is dirty.
 496       (setq char-spec (char-attribute-alist temp-char))
 497       (while char-spec
 498         (remove-char-attribute temp-char (car (car char-spec)))
 499         (setq char-spec (cdr char-spec))))))
 500
 501 (defun char-db-insert-alist (alist &optional readable column)
 502   (unless column
 503     (setq column (current-column)))
 504   (let ((line-breaking
 505          (concat "\n" (make-string (1+ column) ?\ )))
 506         name value
 507         ret al ; cal
 508         key
 509         lbs cell rest separator)
 510     (insert "(")
 511     (while alist
 512       (setq name (car (car alist))
 513             value (cdr (car alist)))
 514       (cond ((eq name 'char)
 515              (insert "(char . ")
 516              (if (setq ret (condition-case nil
 517                                (find-char value)
 518                              (error nil)))
 519                  (progn
 520                    (setq al nil
 521                          ;; cal nil
 522                          )
 523                    (while value
 524                      (setq key (car (car value)))
 525                      ;; (if (find-charset key)
 526                      ;;     (setq cal (cons key cal))
 527                      (setq al (cons key al))
 528                      ;; )
 529                      (setq value (cdr value)))
 530                    (insert-char-attributes ret
 531                                            readable
 532                                            (or al 'none) ; cal
 533                                            nil 'for-sub-node))
 534                (insert (prin1-to-string value)))
 535              (insert ")")
 536              (insert line-breaking))
 537             ((consp value)
 538              (insert (format "(%-18s " name))
 539              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 540              (while (consp value)
 541                (setq cell (car value))
 542                (if (and (consp cell)
 543                         (consp (car cell))
 544                         (setq ret (condition-case nil
 545                                       (find-char cell)
 546                                     (error nil)))
 547                         )
 548                    (progn
 549                      (setq rest cell
 550                            al nil
 551                            ;; cal nil
 552                            )
 553                      (while rest
 554                        (setq key (car (car rest)))
 555                        ;; (if (find-charset key)
 556                        ;;     (setq cal (cons key cal))
 557                        (setq al (cons key al))
 558                        ;; )
 559                        (setq rest (cdr rest)))
 560                      (if separator
 561                          (insert lbs))
 562                      (insert-char-attributes ret
 563                                              readable
 564                                              al ; cal
 565                                              nil 'for-sub-node)
 566                      (setq separator lbs))
 567                  (if separator
 568                      (insert separator))
 569                  (insert (prin1-to-string cell))
 570                  (setq separator " "))
 571                (setq value (cdr value)))
 572              (insert ")")
 573              (insert line-breaking))
 574             (t
 575              (insert (format "(%-18s . %S)%s"
 576                              name value
 577                              line-breaking))))
 578       (setq alist (cdr alist))))
 579   (insert ")"))
 580
 581 (defun char-db-insert-char-reference (plist &optional readable column)
 582   (unless column
 583     (setq column (current-column)))
 584   (let ((line-breaking
 585          (concat "\n" (make-string (1+ column) ?\ )))
 586         (separator "")
 587         name value)
 588     (insert "(")
 589     (while plist
 590       (setq name (pop plist))
 591       (setq value (pop plist))
 592       (cond ((eq name :char)
 593              (insert separator)
 594              (insert ":char\t")
 595              (cond ((numberp value)
 596                     (setq value (decode-char '=ucs value)))
 597                    ;; ((consp value)
 598                    ;;  (setq value (or (find-char value)
 599                    ;;                  value)))
 600                    )
 601              (char-db-insert-char-spec value readable)
 602              (insert line-breaking)
 603              (setq separator ""))
 604             ((eq name :radical)
 605              (insert (format "%s%s\t%d ; %c%s"
 606                              separator
 607                              name value
 608                              (ideographic-radical value)
 609                              line-breaking))
 610              (setq separator ""))
 611             (t
 612              (insert (format "%s%s\t%S" separator name value))
 613              (setq separator line-breaking)))
 614       ))
 615   (insert ")"))
 616
 617 (defun char-db-decode-isolated-char (ccs code-point)
 618   (let (ret)
 619     (setq ret
 620           (cond ((eq ccs 'arabic-iso8859-6)
 621                  (decode-char ccs code-point))
 622                 ;; ((eq ccs '=gt)
 623                 ;;  (decode-builtin-char '==gt code-point))
 624                 ((and (memq ccs '(=gt-pj-1
 625                                   =gt-pj-2
 626                                   =gt-pj-3
 627                                   =gt-pj-4
 628                                   =gt-pj-5
 629                                   =gt-pj-6
 630                                   =gt-pj-7
 631                                   =gt-pj-8
 632                                   =gt-pj-9
 633                                   =gt-pj-10
 634                                   =gt-pj-11))
 635                       (setq ret (decode-char ccs code-point))
 636                       (setq ret (encode-char ret '=gt 'defined-only)))
 637                  (decode-builtin-char '=gt ret))
 638                 (t
 639                  (decode-builtin-char ccs code-point))))
 640     (cond ((null ret)
 641            (or (decode-char ccs code-point)
 642                (define-char (list (cons ccs code-point)))))
 643           ((and (<= 0 (char-int ret))
 644                 (<= (char-int ret) #x1F))
 645            (decode-char '=ucs (+ #x2400 (char-int ret))))
 646           ((= (char-int ret) #x7F)
 647            ?\u2421)
 648           (t ret))))
 649
 650 (defvar char-db-convert-obsolete-format t)
 651
 652 (defun char-db-insert-ccs-feature (name value line-breaking)
 653   (cond
 654    ((integerp value)
 655     (insert
 656      (format
 657       (cond
 658        ((memq name '(=>iwds-1
 659                      ==shinjigen
 660                      =shinjigen
 661                      =shinjigen@1ed ==shinjigen@1ed
 662                      =shinjigen@rev ==shinjigen@rev
 663                      =shinjigen/+p@rev ==shinjigen/+p@rev
 664                      ===daikanwa/ho ==daikanwa/ho
 665                      =daikanwa/ho =>>daikanwa/ho =>daikanwa/ho))
 666         "(%-18s .  %04d)\t; %c")
 667        ((eq name '=shinjigen@1ed/24pr)
 668         "(%-18s . %04d)\t; %c")
 669        ((or
 670          (memq name
 671                '(===daikanwa
 672                  ==daikanwa =daikanwa =>>daikanwa =>daikanwa
 673                  =daikanwa@rev1 =daikanwa@rev2
 674                  =daikanwa/+p ==daikanwa/+p ===daikanwa/+p
 675                  =>>daikanwa/+p
 676                  =daikanwa/+2p =>>daikanwa/+2p
 677                  =gt ==gt ===gt
 678                  =>>gt =+>gt =>gt
 679                  =gt-k ==gt-k ===gt-k
 680                  =>>gt-k =>gt-k
 681                  =adobe-japan1-0 ==adobe-japan1-0 ===adobe-japan1-0
 682                  =adobe-japan1-1 ==adobe-japan1-1 ===adobe-japan1-1
 683                  =adobe-japan1-2 ==adobe-japan1-2 ===adobe-japan1-2
 684                  =adobe-japan1-3 ==adobe-japan1-3 ===adobe-japan1-3
 685                  =adobe-japan1-4 ==adobe-japan1-4 ===adobe-japan1-4
 686                  =adobe-japan1-5 ==adobe-japan1-5 ===adobe-japan1-5
 687                  =adobe-japan1-6 ==adobe-japan1-6 ===adobe-japan1-6
 688                  =>>adobe-japan1-0 =+>adobe-japan1-0
 689                  =>>adobe-japan1-1 =+>adobe-japan1-1
 690                  =>>adobe-japan1-2 =+>adobe-japan1-2
 691                  =>>adobe-japan1-3 =+>adobe-japan1-3
 692                  =>>adobe-japan1-4 =+>adobe-japan1-4
 693                  =>>adobe-japan1-5 =+>adobe-japan1-5
 694                  =>>adobe-japan1-6 =+>adobe-japan1-6
 695                  =>cbeta =cbeta =>>cbeta ==cbeta ===cbeta
 696                  =zinbun-oracle =>zinbun-oracle
 697                  ===hng-jou ===hng-keg ===hng-dng ===hng-mam
 698                  ===hng-drt ===hng-kgk ===hng-myz ===hng-kda
 699                  ===hng-khi ===hng-khm ===hng-hok ===hng-kyd ===hng-sok
 700                  ===hng-yhk ===hng-kak ===hng-kar ===hng-kae
 701                  ===hng-sys ===hng-tsu ===hng-tzj
 702                  ===hng-hos ===hng-nak ===hng-jhk
 703                  ===hng-hod ===hng-gok ===hng-ink ===hng-nto
 704                  ===hng-nkm ===hng-k24 ===hng-nkk
 705                  ===hng-kcc ===hng-kcj ===hng-kbk ===hng-sik
 706                  ===hng-skk ===hng-kyu ===hng-ksk ===hng-wan
 707                  ===hng-okd ===hng-wad ===hng-kmi
 708                  ===hng-zkd ===hng-doh ===hng-jyu
 709                  ===hng-tzs ===hng-kss ===hng-kyo
 710                  ===hng-smk))
 711          ;; (string-match "^=adobe-" (symbol-name name))
 712          )
 713         "(%-18s . %05d)\t; %c")
 714        ((memq name '(=hanyo-denshi/ks
 715                      ==hanyo-denshi/ks ===hanyo-denshi/ks
 716                      =>>hanyo-denshi/ks
 717                      =koseki ==koseki
 718                      =mj ==mj ===mj =>>mj =>mj
 719                      =zihai mojikyo))
 720         "(%-18s . %06d)\t; %c")
 721        ((memq name '(=hanyo-denshi/tk ==hanyo-denshi/tk))
 722         "(%-18s . %08d)\t; %c")
 723        ((>= (charset-dimension name) 2)
 724         "(%-18s . #x%04X)\t; %c")
 725        (t
 726         "(%-18s . #x%02X)\t; %c"))
 727       name
 728       (if (= (charset-iso-graphic-plane name) 1)
 729           (logior value
 730                   (cond ((= (charset-dimension name) 1)
 731                          #x80)
 732                         ((= (charset-dimension name) 2)
 733                          #x8080)
 734                         ((= (charset-dimension name) 3)
 735                          #x808080)
 736                         (t 0)))
 737         value)
 738       (char-db-decode-isolated-char name value)))
 739     (if (and (= (charset-chars name) 94)
 740              (= (charset-dimension name) 2))
 741         (insert (format " [%02d-%02d]"
 742                         (- (lsh value -8) 32)
 743                         (- (logand value 255) 32))))
 744     )
 745    (t
 746     (insert (format "(%-18s . %s)" name value))
 747     ))
 748   (insert line-breaking))
 749
 750 (defun char-db-insert-relation-feature (char name value line-breaking
 751                                              ccss readable)
 752   (insert (format "(%-18s%s " name line-breaking))
 753   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 754         separator cell sources required-features
 755         ret)
 756     (while (consp value)
 757       (setq cell (car value))
 758       (if (integerp cell)
 759           (setq cell (decode-char '=ucs cell)))
 760       (cond
 761        ((eq name '->subsumptive)
 762         (when (or (not (some (lambda (atr)
 763                                (get-char-attribute cell atr))
 764                              char-db-ignored-attributes))
 765                   (some (lambda (ccs)
 766                           (encode-char cell ccs 'defined-only))
 767                         ccss))
 768           (if separator
 769               (insert lbs))
 770           (let ((char-db-ignored-attributes
 771                  (cons '<-subsumptive
 772                        char-db-ignored-attributes)))
 773             (insert-char-attributes cell readable nil nil 'for-sub-node))
 774           (setq separator lbs))
 775         )
 776        ((characterp cell)
 777         (setq sources
 778               (get-char-attribute
 779                char (intern (format "%s*sources" name))))
 780         (setq required-features nil)
 781         (dolist (source sources)
 782           (cond
 783            ((memq source '(JP
 784                            JP/Jouyou
 785                            shinjigen shinjigen@1ed shinjigen@rev))
 786             (setq required-features
 787                   (union required-features
 788                          '(=jis-x0208
 789                            =jis-x0208@1990
 790                            =jis-x0213-1@2000
 791                            =jis-x0213-1@2004
 792                            =jis-x0213-2
 793                            =jis-x0212
 794                            =jis-x0208@1983
 795                            =jis-x0208@1978
 796                            =shinjigen
 797                            =shinjigen@1ed
 798                            =shinjigen@rev
 799                            =shinjigen/+p@rev))))
 800            ((eq source 'CN)
 801             (setq required-features
 802                   (union required-features
 803                          '(=gb2312
 804                            =gb12345
 805                            =iso-ir165)))))
 806           (cond
 807            ((find-charset (setq ret (intern (format "=%s" source))))
 808             (setq required-features
 809                   (cons ret required-features)))
 810            (t (setq required-features
 811                     (cons source required-features)))))
 812         (cond ((string-match "@JP" (symbol-name name))
 813                (setq required-features
 814                      (union required-features
 815                             '(=jis-x0208
 816                               =jis-x0208@1990
 817                               =jis-x0213-1-2000
 818                               =jis-x0213-2-2000
 819                               =jis-x0212
 820                               =jis-x0208@1983
 821                               =jis-x0208@1978))))
 822               ((string-match "@CN" (symbol-name name))
 823                (setq required-features
 824                      (union required-features
 825                             '(=gb2312
 826                               =gb12345
 827                               =iso-ir165)))))
 828         (if separator
 829             (insert lbs))
 830         (if readable
 831             (insert (format "%S" cell))
 832           (char-db-insert-char-spec cell readable
 833                                     nil
 834                                     required-features))
 835         (setq separator lbs))
 836        ((consp cell)
 837         (if separator
 838             (insert lbs))
 839         (if (consp (car cell))
 840             (char-db-insert-char-spec cell readable)
 841           (char-db-insert-char-reference cell readable))
 842         (setq separator lbs))
 843        (t
 844         (if separator
 845             (insert separator))
 846         (insert (prin1-to-string cell))
 847         (setq separator " ")))
 848       (setq value (cdr value)))
 849     (insert ")")
 850     (insert line-breaking)))
 851
 852 (defun insert-char-attributes (char &optional readable attributes column
 853                                     for-sub-node)
 854   (unless column
 855     (setq column (current-column)))
 856   (let (name value ; has-long-ccs-name
 857         rest
 858         radical strokes
 859         (line-breaking
 860          (concat "\n" (make-string (1+ column) ?\ )))
 861         lbs cell separator ret
 862         key al cal
 863         dest-ccss ; sources required-features
 864         ccss)
 865     (let (atr-d)
 866       (setq attributes
 867             (sort (if attributes
 868                       (if (consp attributes)
 869                           (progn
 870                             (dolist (name attributes)
 871                               (unless (memq name char-db-ignored-attributes)
 872                                 (if (find-charset name)
 873                                     (push name ccss))
 874                                 (push name atr-d)))
 875                             atr-d))
 876                     (dolist (name (char-attribute-list))
 877                       (unless (memq name char-db-ignored-attributes)
 878                         (if (find-charset name)
 879                             (push name ccss))
 880                         (push name atr-d)))
 881                     atr-d)
 882                   #'char-attribute-name<)))
 883     (insert "(")
 884     (when (memq '<-subsumptive attributes)
 885       (when (or readable (not for-sub-node))
 886         (when (setq value (get-char-attribute char '<-subsumptive))
 887           (char-db-insert-relation-feature char '<-subsumptive value
 888                                            line-breaking
 889                                            ccss readable)))
 890       (setq attributes (delq '<-subsumptive attributes)))
 891     (when (and (memq '<-denotational attributes)
 892                (setq value (get-char-attribute char '<-denotational)))
 893       (char-db-insert-relation-feature char '<-denotational value
 894                                        line-breaking
 895                                        ccss readable)
 896       (setq attributes (delq '<-denotational attributes)))
 897     (when (and (memq '<-denotational@component attributes)
 898                (setq value (get-char-attribute char '<-denotational@component)))
 899       (char-db-insert-relation-feature char '<-denotational@component value
 900                                        line-breaking
 901                                        ccss readable)
 902       (setq attributes (delq '<-denotational@component attributes)))
 903     (when (and (memq 'name attributes)
 904                (setq value (get-char-attribute char 'name)))
 905       (insert (format
 906                (if (> (+ (current-column) (length value)) 48)
 907                    "(name . %S)%s"
 908                  "(name               . %S)%s")
 909                value line-breaking))
 910       (setq attributes (delq 'name attributes))
 911       )
 912     (when (and (memq 'name* attributes)
 913                (setq value (get-char-attribute char 'name*)))
 914       (insert (format
 915                (if (> (+ (current-column) (length value)) 48)
 916                    "(name* . %S)%s"
 917                  "(name*              . %S)%s")
 918                value line-breaking))
 919       (setq attributes (delq 'name* attributes))
 920       )
 921     (when (and (memq 'script attributes)
 922                (setq value (get-char-attribute char 'script)))
 923       (insert (format "(script\t\t%s)%s"
 924                       (mapconcat (function prin1-to-string)
 925                                  value " ")
 926                       line-breaking))
 927       (setq attributes (delq 'script attributes))
 928       )
 929     (dolist (name '(=>ucs =>ucs*))
 930       (when (and (memq name attributes)
 931                  (setq value (get-char-attribute char name)))
 932         (insert (format "(%-18s . #x%04X)\t; %c%s"
 933                         name value (decode-char '=ucs value)
 934                         line-breaking))
 935         (setq attributes (delq name attributes))))
 936     (dolist (name '(=>ucs@gb =>ucs@big5))
 937       (when (and (memq name attributes)
 938                  (setq value (get-char-attribute char name)))
 939         (insert (format "(%-18s . #x%04X)\t; %c%s"
 940                         name value
 941                         (decode-char (intern
 942                                       (concat "="
 943                                               (substring
 944                                                (symbol-name name) 2)))
 945                                      value)
 946                         line-breaking))
 947         (setq attributes (delq name attributes))
 948         ))
 949     ;; (dolist (name '(=>daikanwa))
 950     ;;   (when (and (memq name attributes)
 951     ;;              (setq value (get-char-attribute char name)))
 952     ;;     (insert
 953     ;;      (if (integerp value)
 954     ;;          (format "(%-18s . %05d)\t; %c%s"
 955     ;;                  name value (decode-char '=daikanwa value)
 956     ;;                  line-breaking)
 957     ;;        (format "(%-18s %s)\t; %c%s"
 958     ;;                name
 959     ;;                (mapconcat (function prin1-to-string)
 960     ;;                           value " ")
 961     ;;                (char-representative-of-daikanwa char)
 962     ;;                line-breaking)))
 963     ;;     (setq attributes (delq name attributes))))
 964     (when (and (memq 'general-category attributes)
 965                (setq value (get-char-attribute char 'general-category)))
 966       (insert (format
 967                "(general-category\t%s) ; %s%s"
 968                (mapconcat (lambda (cell)
 969                             (format "%S" cell))
 970                           value " ")
 971                (cond ((rassoc value unidata-normative-category-alist)
 972                       "Normative Category")
 973                      ((rassoc value unidata-informative-category-alist)
 974                       "Informative Category")
 975                      (t
 976                       "Unknown Category"))
 977                line-breaking))
 978       (setq attributes (delq 'general-category attributes))
 979       )
 980     (when (and (memq 'bidi-category attributes)
 981                (setq value (get-char-attribute char 'bidi-category)))
 982       (insert (format "(bidi-category\t. %S)%s"
 983                       value
 984                       line-breaking))
 985       (setq attributes (delq 'bidi-category attributes))
 986       )
 987     (unless (or (not (memq 'mirrored attributes))
 988                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 989                     'empty))
 990       (insert (format "(mirrored\t\t. %S)%s"
 991                       value
 992                       line-breaking))
 993       (setq attributes (delq 'mirrored attributes))
 994       )
 995     (cond
 996      ((and (memq 'decimal-digit-value attributes)
 997            (setq value (get-char-attribute char 'decimal-digit-value)))
 998       (insert (format "(decimal-digit-value . %S)%s"
 999                       value
1000                       line-breaking))
1001       (setq attributes (delq 'decimal-digit-value attributes))
1002       (when (and (memq 'digit-value attributes)
1003                  (setq value (get-char-attribute char 'digit-value)))
1004         (insert (format "(digit-value\t . %S)%s"
1005                         value
1006                         line-breaking))
1007         (setq attributes (delq 'digit-value attributes))
1008         )
1009       (when (and (memq 'numeric-value attributes)
1010                  (setq value (get-char-attribute char 'numeric-value)))
1011         (insert (format "(numeric-value\t . %S)%s"
1012                         value
1013                         line-breaking))
1014         (setq attributes (delq 'numeric-value attributes))
1015         )
1016       )
1017      (t
1018       (when (and (memq 'digit-value attributes)
1019                  (setq value (get-char-attribute char 'digit-value)))
1020         (insert (format "(digit-value\t. %S)%s"
1021                         value
1022                         line-breaking))
1023         (setq attributes (delq 'digit-value attributes))
1024         )
1025       (when (and (memq 'numeric-value attributes)
1026                  (setq value (get-char-attribute char 'numeric-value)))
1027         (insert (format "(numeric-value\t. %S)%s"
1028                         value
1029                         line-breaking))
1030         (setq attributes (delq 'numeric-value attributes))
1031         )))
1032     (when (and (memq 'iso-10646-comment attributes)
1033                (setq value (get-char-attribute char 'iso-10646-comment)))
1034       (insert (format "(iso-10646-comment\t. %S)%s"
1035                       value
1036                       line-breaking))
1037       (setq attributes (delq 'iso-10646-comment attributes))
1038       )
1039     (when (and (memq 'morohashi-daikanwa attributes)
1040                (setq value (get-char-attribute char 'morohashi-daikanwa)))
1041       (insert (format "(morohashi-daikanwa\t%s)%s"
1042                       (mapconcat (function prin1-to-string) value " ")
1043                       line-breaking))
1044       (setq attributes (delq 'morohashi-daikanwa attributes))
1045       )
1046     (setq radical nil
1047           strokes nil)
1048     (when (and (memq 'ideographic-radical attributes)
1049                (setq value (get-char-attribute char 'ideographic-radical)))
1050       (setq radical value)
1051       (insert (format "(ideographic-radical . %S)\t; %c%s"
1052                       radical
1053                       (ideographic-radical radical)
1054                       line-breaking))
1055       (setq attributes (delq 'ideographic-radical attributes))
1056       )
1057     (when (and (memq 'shuowen-radical attributes)
1058                (setq value (get-char-attribute char 'shuowen-radical)))
1059       (insert (format "(shuowen-radical\t. %S)\t; %c%s"
1060                       value
1061                       (shuowen-radical value)
1062                       line-breaking))
1063       (setq attributes (delq 'shuowen-radical attributes))
1064       )
1065     (let (key)
1066       (dolist (domain
1067                (append
1068                 char-db-feature-domains
1069                 (let (dest domain)
1070                   (dolist (feature (char-attribute-list))
1071                     (setq feature (symbol-name feature))
1072                     (when (string-match
1073                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
1074                            feature)
1075                       (setq domain (intern (match-string 2 feature)))
1076                      (unless (memq domain dest)
1077                        (setq dest (cons domain dest)))))
1078                   (sort dest #'string<))))
1079         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
1080         (when (and (memq key attributes)
1081                    (setq value (get-char-attribute char key)))
1082           (setq radical value)
1083           (insert (format "(%s . %S)\t; %c%s"
1084                           key
1085                           radical
1086                           (ideographic-radical radical)
1087                           line-breaking))
1088           (setq attributes (delq key attributes))
1089           )
1090         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
1091         (when (and (memq key attributes)
1092                    (setq value (get-char-attribute char key)))
1093           (setq strokes value)
1094           (insert (format "(%s . %S)%s"
1095                           key
1096                           strokes
1097                           line-breaking))
1098           (setq attributes (delq key attributes))
1099           )
1100         (setq key (intern (format "%s@%s" 'total-strokes domain)))
1101         (when (and (memq key attributes)
1102                    (setq value (get-char-attribute char key)))
1103           (insert (format "(%s       . %S)%s"
1104                           key
1105                           value
1106                           line-breaking))
1107           (setq attributes (delq key attributes))
1108           )
1109         (dolist (feature '(ideographic-radical
1110                            ideographic-strokes
1111                            total-strokes))
1112           (setq key (intern (format "%s@%s*sources" feature domain)))
1113           (when (and (memq key attributes)
1114                      (setq value (get-char-attribute char key)))
1115             (insert (format "(%s%s" key line-breaking))
1116             (dolist (cell value)
1117               (insert (format " %s" cell)))
1118             (insert ")")
1119             (insert line-breaking)
1120             (setq attributes (delq key attributes))
1121             ))
1122         ))
1123     (when (and (memq 'ideographic-strokes attributes)
1124                (setq value (get-char-attribute char 'ideographic-strokes)))
1125       (setq strokes value)
1126       (insert (format "(ideographic-strokes . %S)%s"
1127                       strokes
1128                       line-breaking))
1129       (setq attributes (delq 'ideographic-strokes attributes))
1130       )
1131     (when (and (memq 'kangxi-radical attributes)
1132                (setq value (get-char-attribute char 'kangxi-radical)))
1133       (unless (eq value radical)
1134         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
1135                         value
1136                         (ideographic-radical value)
1137                         line-breaking))
1138         (or radical
1139             (setq radical value)))
1140       (setq attributes (delq 'kangxi-radical attributes))
1141       )
1142     (when (and (memq 'kangxi-strokes attributes)
1143                (setq value (get-char-attribute char 'kangxi-strokes)))
1144       (unless (eq value strokes)
1145         (insert (format "(kangxi-strokes\t . %S)%s"
1146                         value
1147                         line-breaking))
1148         (or strokes
1149             (setq strokes value)))
1150       (setq attributes (delq 'kangxi-strokes attributes))
1151       )
1152     (when (and (memq 'japanese-radical attributes)
1153                (setq value (get-char-attribute char 'japanese-radical)))
1154       (unless (eq value radical)
1155         (insert (format "(japanese-radical\t . %S)\t; %c%s"
1156                         value
1157                         (ideographic-radical value)
1158                         line-breaking))
1159         (or radical
1160             (setq radical value)))
1161       (setq attributes (delq 'japanese-radical attributes))
1162       )
1163     (when (and (memq 'japanese-strokes attributes)
1164                (setq value (get-char-attribute char 'japanese-strokes)))
1165       (unless (eq value strokes)
1166         (insert (format "(japanese-strokes\t . %S)%s"
1167                         value
1168                         line-breaking))
1169         (or strokes
1170             (setq strokes value)))
1171       (setq attributes (delq 'japanese-strokes attributes))
1172       )
1173     (when (and (memq 'cns-radical attributes)
1174                (setq value (get-char-attribute char 'cns-radical)))
1175       (insert (format "(cns-radical\t . %S)\t; %c%s"
1176                       value
1177                       (ideographic-radical value)
1178                       line-breaking))
1179       (setq attributes (delq 'cns-radical attributes))
1180       )
1181     (when (and (memq 'cns-strokes attributes)
1182                (setq value (get-char-attribute char 'cns-strokes)))
1183       (unless (eq value strokes)
1184         (insert (format "(cns-strokes\t . %S)%s"
1185                         value
1186                         line-breaking))
1187         (or strokes
1188             (setq strokes value)))
1189       (setq attributes (delq 'cns-strokes attributes))
1190       )
1191     ;; (when (and (memq 'shinjigen-1-radical attributes)
1192     ;;            (setq value (get-char-attribute char 'shinjigen-1-radical)))
1193     ;;   (unless (eq value radical)
1194     ;;     (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
1195     ;;                     value
1196     ;;                     (ideographic-radical value)
1197     ;;                     line-breaking))
1198     ;;     (or radical
1199     ;;         (setq radical value)))
1200     ;;   (setq attributes (delq 'shinjigen-1-radical attributes))
1201     ;;   )
1202     (when (and (memq 'ideographic- attributes)
1203                (setq value (get-char-attribute char 'ideographic-)))
1204       (insert "(ideographic-       ")
1205       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1206             separator nil)
1207       (while (consp value)
1208         (setq cell (car value))
1209         (if (integerp cell)
1210             (setq cell (decode-char '=ucs cell)))
1211         (cond ((characterp cell)
1212                (if separator
1213                    (insert lbs))
1214                (if readable
1215                    (insert (format "%S" cell))
1216                  (char-db-insert-char-spec cell readable))
1217                (setq separator lbs))
1218               ((consp cell)
1219                (if separator
1220                    (insert lbs))
1221                (if (consp (car cell))
1222                    (char-db-insert-char-spec cell readable)
1223                  (char-db-insert-char-reference cell readable))
1224                (setq separator lbs))
1225               (t
1226                (if separator
1227                    (insert separator))
1228                (insert (prin1-to-string cell))
1229                (setq separator " ")))
1230         (setq value (cdr value)))
1231       (insert ")")
1232       (insert line-breaking)
1233       (setq attributes (delq 'ideographic- attributes)))
1234     (when (and (memq 'total-strokes attributes)
1235                (setq value (get-char-attribute char 'total-strokes)))
1236       (insert (format "(total-strokes       . %S)%s"
1237                       value
1238                       line-breaking))
1239       (setq attributes (delq 'total-strokes attributes))
1240       )
1241     (when (and (memq '->ideograph attributes)
1242                (setq value (get-char-attribute char '->ideograph)))
1243       (insert (format "(->ideograph\t%s)%s"
1244                       (mapconcat (lambda (code)
1245                                    (cond ((symbolp code)
1246                                           (symbol-name code))
1247                                          ((integerp code)
1248                                           (format "#x%04X" code))
1249                                          (t
1250                                           (format "%s %S"
1251                                                   line-breaking code))))
1252                                  value " ")
1253                       line-breaking))
1254       (setq attributes (delq '->ideograph attributes))
1255       )
1256     ;; (when (and (memq '->decomposition attributes)
1257     ;;            (setq value (get-char-attribute char '->decomposition)))
1258     ;;   (insert (format "(->decomposition\t%s)%s"
1259     ;;                   (mapconcat (lambda (code)
1260     ;;                                (cond ((symbolp code)
1261     ;;                                       (symbol-name code))
1262     ;;                                      ((characterp code)
1263     ;;                                       (if readable
1264     ;;                                           (format "%S" code)
1265     ;;                                         (format "#x%04X"
1266     ;;                                                 (char-int code))
1267     ;;                                         ))
1268     ;;                                      ((integerp code)
1269     ;;                                       (format "#x%04X" code))
1270     ;;                                      (t
1271     ;;                                       (format "%s%S" line-breaking code))))
1272     ;;                              value " ")
1273     ;;                   line-breaking))
1274     ;;   (setq attributes (delq '->decomposition attributes))
1275     ;;   )
1276     (if (equal (get-char-attribute char '->titlecase)
1277                (get-char-attribute char '->uppercase))
1278         (setq attributes (delq '->titlecase attributes)))
1279     (when (and (memq '->mojikyo attributes)
1280                (setq value (get-char-attribute char '->mojikyo)))
1281       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
1282                       value (decode-char 'mojikyo value)
1283                       line-breaking))
1284       (setq attributes (delq '->mojikyo attributes))
1285       )
1286     (when (and (memq 'hanyu-dazidian-vol attributes)
1287                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
1288       (insert (format "(hanyu-dazidian-vol  . %d)%s"
1289                       value line-breaking))
1290       (setq attributes (delq 'hanyu-dazidian-vol attributes))
1291       )
1292     (when (and (memq 'hanyu-dazidian-page attributes)
1293                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
1294       (insert (format "(hanyu-dazidian-page . %d)%s"
1295                       value line-breaking))
1296       (setq attributes (delq 'hanyu-dazidian-page attributes))
1297       )
1298     (when (and (memq 'hanyu-dazidian-char attributes)
1299                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
1300       (insert (format "(hanyu-dazidian-char . %d)%s"
1301                       value line-breaking))
1302       (setq attributes (delq 'hanyu-dazidian-char attributes))
1303       )
1304     (unless readable
1305       (dolist (ignored '(composition
1306                          ->denotational <-subsumptive ->ucs-unified
1307                          ->ideographic-component-forms))
1308         (setq attributes (delq ignored attributes))))
1309     (while attributes
1310       (setq name (car attributes))
1311       (unless (eq (setq value (get-char-attribute char name 'value-is-empty))
1312                   'value-is-empty)
1313         (cond ((setq ret (find-charset name))
1314                (setq name (charset-name ret))
1315                (when (not (memq name dest-ccss))
1316                  (setq dest-ccss (cons name dest-ccss))
1317                  (char-db-insert-ccs-feature name value line-breaking))
1318                )
1319               ((string-match "^=>ucs@" (symbol-name name))
1320                (insert (format "(%-18s . #x%04X)\t; %c%s"
1321                                name value (decode-char '=ucs value)
1322                                line-breaking))
1323                )
1324               ((eq name 'jisx0208-1978/4X)
1325                (insert (format "(%-18s . #x%04X)%s"
1326                                name value
1327                                line-breaking))
1328                )
1329               ((and
1330                 (not readable)
1331                 (not (eq name '->subsumptive))
1332                 (not (eq name '->uppercase))
1333                 (not (eq name '->lowercase))
1334                 (not (eq name '->titlecase))
1335                 (not (eq name '->canonical))
1336                 (not (eq name '->Bopomofo))
1337                 (not (eq name '->mistakable))
1338                 (not (eq name '->ideographic-variants))
1339                 (null (get-char-attribute
1340                        char (intern (format "%s*sources" name))))
1341                 (not (string-match "\\*sources$" (symbol-name name)))
1342                 (null (get-char-attribute
1343                        char (intern (format "%s*note" name))))
1344                 (not (string-match "\\*note$" (symbol-name name)))
1345                 (or (eq name '<-identical)
1346                     (eq name '<-uppercase)
1347                     (eq name '<-lowercase)
1348                     (eq name '<-titlecase)
1349                     (eq name '<-canonical)
1350                     (eq name '<-ideographic-variants)
1351                     ;; (eq name '<-synonyms)
1352                     (string-match "^<-synonyms" (symbol-name name))
1353                     (eq name '<-mistakable)
1354                     (when (string-match "^->" (symbol-name name))
1355                       (cond
1356                        ((string-match "^->fullwidth" (symbol-name name))
1357                         (not (and (consp value)
1358                                   (characterp (car value))
1359                                   (encode-char
1360                                    (car value) '=ucs 'defined-only)))
1361                         )
1362                        (t)))
1363                     ))
1364                )
1365               ((or (eq name 'ideographic-structure)
1366                    (eq name 'ideographic-combination)
1367                    (eq name 'ideographic-)
1368                    (eq name '=decomposition)
1369                    (char-feature-base-name= '=decomposition name)
1370                    (char-feature-base-name= '=>decomposition name)
1371                    ;; (string-match "^=>*decomposition\\(@[^*]+\\)?$"
1372                    ;;               (symbol-name name))
1373                    (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
1374                    (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
1375                                  (symbol-name name))
1376                    )
1377                (char-db-insert-relation-feature char name value
1378                                                 line-breaking
1379                                                 ccss readable))
1380               ((memq name '(ideograph=
1381                             original-ideograph-of
1382                             ancient-ideograph-of
1383                             vulgar-ideograph-of
1384                             wrong-ideograph-of
1385                             ;; simplified-ideograph-of
1386                             ideographic-variants
1387                             ;; ideographic-different-form-of
1388                             ))
1389                (insert (format "(%-18s%s " name line-breaking))
1390                (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1391                      separator nil)
1392                (while (consp value)
1393                  (setq cell (car value))
1394                  (if (and (consp cell)
1395                           (consp (car cell)))
1396                      (progn
1397                        (if separator
1398                            (insert lbs))
1399                        (char-db-insert-alist cell readable)
1400                        (setq separator lbs))
1401                    (if separator
1402                        (insert separator))
1403                    (insert (prin1-to-string cell))
1404                    (setq separator " "))
1405                  (setq value (cdr value)))
1406                (insert ")")
1407                (insert line-breaking))
1408               ((consp value)
1409                (insert (format "(%-18s " name))
1410                (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1411                      separator nil)
1412                (while (consp value)
1413                  (setq cell (car value))
1414                  (if (and (consp cell)
1415                           (consp (car cell))
1416                           (setq ret (condition-case nil
1417                                         (find-char cell)
1418                                       (error nil))))
1419                      (progn
1420                        (setq rest cell
1421                              al nil
1422                              cal nil)
1423                        (while rest
1424                          (setq key (car (car rest)))
1425                          (if (find-charset key)
1426                              (setq cal (cons key cal))
1427                            (setq al (cons key al)))
1428                          (setq rest (cdr rest)))
1429                        (if separator
1430                            (insert lbs))
1431                        (insert-char-attributes ret
1432                                                readable
1433                                                al ; cal
1434                                                nil 'for-sub-node)
1435                        (setq separator lbs))
1436                    (setq ret (prin1-to-string cell))
1437                    (if separator
1438                        (if (< (+ (current-column)
1439                                  (length ret)
1440                                  (length separator))
1441                               76)
1442                            (insert separator)
1443                          (insert lbs)))
1444                    (insert ret)
1445                    (setq separator " "))
1446                  (setq value (cdr value)))
1447                (insert ")")
1448                (insert line-breaking))
1449               (t
1450                (insert (format "(%-18s" name))
1451                (setq ret (prin1-to-string value))
1452                (unless (< (+ (current-column)
1453                              (length ret)
1454                              3)
1455                           76)
1456                  (insert line-breaking))
1457                (insert " . " ret ")" line-breaking)
1458                ;; (insert (format "(%-18s . %S)%s"
1459                ;;                 name value
1460                ;;                 line-breaking))
1461                )
1462               ))
1463       (setq attributes (cdr attributes)))
1464     (insert ")")))
1465
1466 (defun insert-char-data (char &optional readable
1467                               attributes)
1468   (save-restriction
1469     (narrow-to-region (point)(point))
1470     (insert "(define-char
1471   '")
1472     (insert-char-attributes char readable attributes)
1473     (insert ")\n")
1474     (goto-char (point-min))
1475     (while (re-search-forward "[ \t]+$" nil t)
1476       (replace-match ""))
1477     ;; from tabify.
1478     (goto-char (point-min))
1479     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1480       (let ((column (current-column))
1481             (indent-tabs-mode t))
1482         (delete-region (match-beginning 0) (point))
1483         (indent-to column)))
1484     (goto-char (point-max))
1485     ;; (tabify (point-min)(point-max))
1486     ))
1487
1488 (defun insert-char-data-with-variant (char &optional printable
1489                                            no-ucs-unified
1490                                            script excluded-script)
1491   (insert-char-data char printable)
1492   (let ((variants (char-variants char))
1493         rest
1494         variant vs ret)
1495     (setq variants (sort variants #'<))
1496     (setq rest variants)
1497     (setq variants (cons char variants))
1498     (while rest
1499       (setq variant (car rest))
1500       (unless (get-char-attribute variant '<-subsumptive)
1501         (if (and (or (null script)
1502                      (null (setq vs (get-char-attribute variant 'script)))
1503                      (memq script vs))
1504                  (or (null excluded-script)
1505                      (null (setq vs (get-char-attribute variant 'script)))
1506                      (not (memq excluded-script vs))))
1507             (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1508               (insert-char-data variant printable)
1509               (if (setq ret (char-variants variant))
1510                   (while ret
1511                     (or (memq (car ret) variants)
1512                         ;; (get-char-attribute (car ret) '<-subsumptive)
1513                         (setq rest (nconc rest (list (car ret)))))
1514                     (setq ret (cdr ret)))))))
1515       (setq rest (cdr rest)))))
1516
1517 (defun insert-char-range-data (min max &optional script excluded-script)
1518   (let ((code min)
1519         char)
1520     (while (<= code max)
1521       (setq char (decode-char '=ucs code))
1522       (if (encode-char char '=ucs 'defined-only)
1523           (insert-char-data-with-variant char nil 'no-ucs-unified
1524                                          script excluded-script))
1525       (setq code (1+ code)))))
1526
1527 (defun write-char-range-data-to-file (min max file
1528                                           &optional script excluded-script)
1529   (let ((coding-system-for-write char-db-file-coding-system))
1530     (with-temp-buffer
1531       (insert (format ";; -*- coding: %s -*-\n"
1532                       char-db-file-coding-system))
1533       (insert-char-range-data min max script excluded-script)
1534       (write-region (point-min)(point-max) file))))
1535
1536 (defvar what-character-original-window-configuration)
1537
1538 ;;;###autoload
1539 (defun what-char-definition (char)
1540   (interactive (list (char-after)))
1541   (let ((buf (get-buffer-create "*Character Description*"))
1542         (the-buf (current-buffer))
1543         (win-conf (current-window-configuration)))
1544     (pop-to-buffer buf)
1545     (make-local-variable 'what-character-original-window-configuration)
1546     (setq what-character-original-window-configuration win-conf)
1547     (setq buffer-read-only nil)
1548     (erase-buffer)
1549     (condition-case err
1550         (progn
1551           (insert-char-data-with-variant char 'printable)
1552           (unless (char-attribute-alist char)
1553             (insert (format ";; = %c\n"
1554                             (let* ((rest (split-char char))
1555                                    (ccs (pop rest))
1556                                    (code (pop rest)))
1557                               (while rest
1558                                 (setq code (logior (lsh code 8)
1559                                                    (pop rest))))
1560                               (decode-char ccs code)))))
1561           ;; (char-db-update-comment)
1562           (set-buffer-modified-p nil)
1563           (view-mode the-buf (lambda (buf)
1564                                (set-window-configuration
1565                                 what-character-original-window-configuration)
1566                                ))
1567           (goto-char (point-min)))
1568       (error (progn
1569                (set-window-configuration
1570                 what-character-original-window-configuration)
1571                (signal (car err) (cdr err)))))))
1572
1573
1574 ;;; @ end
1575 ;;;
1576
1577 (provide 'char-db-util)
1578
1579 ;;; char-db-util.el ends here