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