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 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-016
 383     =ucs-itaiji-018
 384     =+>ucs-var-003
 385     =>ucs-itaiji-001
 386     =>ucs-itaiji-002
 387     =>ucs-itaiji-003
 388     =>ucs-itaiji-004
 389     =>ucs-itaiji-005
 390     =>ucs-itaiji-006
 391     =>ucs-itaiji-007
 392     =>ucs-itaiji-008
 393     =>ucs-itaiji-009
 394     =>ucs-itaiji-010
 395     =>ucs-itaiji-011
 396     =>ucs-itaiji-012
 397     =>ucs-itaiji-014
 398     =>ucs-itaiji-016
 399     =>ucs-var-001
 400     =big5-cdp-var-001
 401     =big5-cdp-var-002
 402     =big5-cdp-var-003
 403     =big5-cdp-var-004
 404     =big5-cdp-var-005
 405     =big5-cdp-var-007
 406     =big5-cdp-var-008
 407     =big5-cdp-var-010
 408     =big5-cdp-itaiji-001
 409     =big5-cdp-itaiji-002
 410     =big5-cdp-itaiji-003
 411     =big5-cdp-itaiji-004
 412     =big5-cdp-itaiji-005
 413     =>big5-cdp-itaiji-001
 414     =>big5-cdp-itaiji-002
 415     =>big5-cdp-itaiji-003
 416     =>big5-cdp-itaiji-004
 417     =>big5-cdp-itaiji-005
 418     =>big5-cdp-itaiji-006
 419     =>big5-cdp-var-001
 420     =>ucs@iwds-1
 421     =>ucs@cognate
 422     =>ucs@component
 423     =>ucs@iwds-1/normalized
 424     =>ucs-itaiji-001@iwds-1
 425     =>ucs-itaiji-002@iwds-1
 426     =>ucs-itaiji-003@iwds-1
 427     =>ucs-itaiji-006@iwds-1
 428     =>big5-cdp@component
 429     =>big5-cdp@cognate
 430     ==ucs@gb
 431     =ucs@gb
 432     ==ucs-var-002
 433     ==ucs-itaiji-002
 434     =ucs@JP/hanazono
 435     =koseki
 436     =shuowen-jiguge
 437     =>shuowen-jiguge
 438     ===shuowen-jiguge5
 439     ===shuowen-jiguge4
 440     ===chise-hdic-ktb-seal))
 441
 442
 443 ;;; @ char-db formatters
 444 ;;;
 445
 446 (defun char-db-make-char-spec (char)
 447   (let (ret char-spec)
 448     (cond ((characterp char)
 449            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 450                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 451                   (setq char-spec (list (cons '=ucs ret)))
 452                   (cond ((setq ret (get-char-attribute char 'name))
 453                          (setq char-spec (cons (cons 'name ret) char-spec))
 454                          )
 455                         ((setq ret (get-char-attribute char 'name*))
 456                          (setq char-spec (cons (cons 'name* ret) char-spec))
 457                          ))
 458                   )
 459                  ((encode-char char '=mj 'defined-only)
 460                   (setq char-spec nil)
 461                   (dolist (ccs (charset-list))
 462                     (if (and (or (eq ccs '=mj)
 463                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 464                                  (string-match "=ucs@" (symbol-name ccs))
 465                                  )
 466                              (setq ccs (charset-name ccs))
 467                              (null (assq ccs char-spec))
 468                              (setq ret (encode-char char ccs 'defined-only)))
 469                         (setq char-spec (cons (cons ccs ret) char-spec))))
 470                   )
 471                  ((encode-char char '==mj 'defined-only)
 472                   (setq char-spec nil)
 473                   (dolist (ccs (charset-list))
 474                     (if (and (or (eq ccs '==mj)
 475                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 476                                  (string-match "=ucs@" (symbol-name ccs))
 477                                  )
 478                              (setq ccs (charset-name ccs))
 479                              (null (assq ccs char-spec))
 480                              (setq ret (encode-char char ccs 'defined-only)))
 481                         (setq char-spec (cons (cons ccs ret) char-spec))))
 482                   )
 483                  ((encode-char char '=adobe-japan1 'defined-only)
 484                   (setq char-spec nil)
 485                   (dolist (ccs (charset-list))
 486                     (if (and (or (memq ccs
 487                                        '(=adobe-japan1-0
 488                                          =adobe-japan1-1
 489                                          =adobe-japan1-2
 490                                          =adobe-japan1-3
 491                                          =adobe-japan1-4
 492                                          =adobe-japan1-5
 493                                          =adobe-japan1-6
 494                                          ))
 495                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 496                                  (string-match "=ucs@" (symbol-name ccs))
 497                                  )
 498                              (setq ccs (charset-name ccs))
 499                              (null (assq ccs char-spec))
 500                              (setq ret (encode-char char ccs 'defined-only)))
 501                         (setq char-spec (cons (cons ccs ret) char-spec))))
 502                   )
 503                  ((encode-char char '==adobe-japan1 'defined-only)
 504                   (setq char-spec nil)
 505                   (dolist (ccs (charset-list))
 506                     (if (and (or (memq ccs
 507                                        '(==adobe-japan1-0
 508                                          ==adobe-japan1-1
 509                                          ==adobe-japan1-2
 510                                          ==adobe-japan1-3
 511                                          ==adobe-japan1-4
 512                                          ==adobe-japan1-5
 513                                          ==adobe-japan1-6
 514                                          ))
 515                                  ;; (eq (charset-property ccs 'iso-ir) 177)
 516                                  (string-match "=ucs@" (symbol-name ccs))
 517                                  )
 518                              (setq ccs (charset-name ccs))
 519                              (null (assq ccs char-spec))
 520                              (setq ret (encode-char char ccs 'defined-only)))
 521                         (setq char-spec (cons (cons ccs ret) char-spec))))
 522                   )
 523                  ((setq ret
 524                         (catch 'tag
 525                           (let ((rest char-db-coded-charset-priority-list)
 526                                 ccs)
 527                             (while rest
 528                               (setq ccs (charset-name
 529                                          (find-charset (car rest))))
 530                               (if (setq ret
 531                                         (encode-char char ccs
 532                                                      'defined-only))
 533                                   (throw 'tag (cons ccs ret)))
 534                               (setq rest (cdr rest))))))
 535                   (setq char-spec (list ret))
 536                   (dolist (ccs (delq (car ret) (charset-list)))
 537                     (if (and (or (charset-iso-final-char ccs)
 538                                  (memq ccs
 539                                        '(=daikanwa
 540                                          =daikanwa@rev2
 541                                          ;; =gt-k
 542                                          =jis-x0208@1997
 543                                          ))
 544                                  (and (eq (charset-property ccs 'iso-ir) 177)
 545                                       (not (eq (charset-name ccs) '=ucs@big5)))
 546                                  ;; (string-match "=ucs@" (symbol-name ccs))
 547                                  )
 548                              (setq ccs (charset-name ccs))
 549                              (null (assq ccs char-spec))
 550                              (setq ret (encode-char char ccs 'defined-only)))
 551                         (setq char-spec (cons (cons ccs ret) char-spec))))
 552                   (if (null char-spec)
 553                       (setq char-spec (split-char char)))
 554                   (cond ((setq ret (get-char-attribute char 'name))
 555                          (setq char-spec (cons (cons 'name ret) char-spec))
 556                          )
 557                         ((setq ret (get-char-attribute char 'name*))
 558                          (setq char-spec (cons (cons 'name* ret) char-spec))
 559                          ))
 560                   )
 561                  ((setq ret (get-char-attribute
 562                              char 'ideographic-combination))
 563                   (setq char-spec
 564                         (cons (cons 'ideographic-combination ret)
 565                               char-spec))
 566                   ))
 567            char-spec)
 568           ((consp char)
 569            char))))
 570
 571 (defun char-db-insert-char-spec (char &optional readable column
 572                                       required-features)
 573   (unless column
 574     (setq column (current-column)))
 575   (let (char-spec temp-char)
 576     (setq char-spec (char-db-make-char-spec char))
 577     (unless (or (characterp char) ; char
 578                 (condition-case nil
 579                     (setq char (find-char char-spec))
 580                   (error nil)))
 581       ;; define temporary character
 582       ;;   Current implementation is dirty.
 583       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 584                                          char-spec)))
 585       (remove-char-attribute temp-char 'ideograph-daikanwa)
 586       (setq char temp-char))
 587     (insert-char-attributes char
 588                             readable
 589                             (union (mapcar #'car char-spec)
 590                                    required-features)
 591                             nil 'for-sub-node)
 592     (when temp-char
 593       ;; undefine temporary character
 594       ;;   Current implementation is dirty.
 595       (setq char-spec (char-attribute-alist temp-char))
 596       (while char-spec
 597         (remove-char-attribute temp-char (car (car char-spec)))
 598         (setq char-spec (cdr char-spec))))))
 599
 600 (defun char-db-insert-alist (alist &optional readable column)
 601   (unless column
 602     (setq column (current-column)))
 603   (let ((line-breaking
 604          (concat "\n" (make-string (1+ column) ?\ )))
 605         name value
 606         ret al ; cal
 607         key
 608         lbs cell rest separator)
 609     (insert "(")
 610     (while alist
 611       (setq name (car (car alist))
 612             value (cdr (car alist)))
 613       (cond ((eq name 'char)
 614              (insert "(char . ")
 615              (if (setq ret (condition-case nil
 616                                (find-char value)
 617                              (error nil)))
 618                  (progn
 619                    (setq al nil
 620                          ;; cal nil
 621                          )
 622                    (while value
 623                      (setq key (car (car value)))
 624                      ;; (if (find-charset key)
 625                      ;;     (setq cal (cons key cal))
 626                      (setq al (cons key al))
 627                      ;; )
 628                      (setq value (cdr value)))
 629                    (insert-char-attributes ret
 630                                            readable
 631                                            (or al 'none) ; cal
 632                                            nil 'for-sub-node))
 633                (insert (prin1-to-string value)))
 634              (insert ")")
 635              (insert line-breaking))
 636             ((consp value)
 637              (insert (format "(%-18s " name))
 638              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 639              (while (consp value)
 640                (setq cell (car value))
 641                (if (and (consp cell)
 642                         (consp (car cell))
 643                         (setq ret (condition-case nil
 644                                       (find-char cell)
 645                                     (error nil)))
 646                         )
 647                    (progn
 648                      (setq rest cell
 649                            al nil
 650                            ;; cal nil
 651                            )
 652                      (while rest
 653                        (setq key (car (car rest)))
 654                        ;; (if (find-charset key)
 655                        ;;     (setq cal (cons key cal))
 656                        (setq al (cons key al))
 657                        ;; )
 658                        (setq rest (cdr rest)))
 659                      (if separator
 660                          (insert lbs))
 661                      (insert-char-attributes ret
 662                                              readable
 663                                              al ; cal
 664                                              nil 'for-sub-node)
 665                      (setq separator lbs))
 666                  (if separator
 667                      (insert separator))
 668                  (insert (prin1-to-string cell))
 669                  (setq separator " "))
 670                (setq value (cdr value)))
 671              (insert ")")
 672              (insert line-breaking))
 673             (t
 674              (insert (format "(%-18s . %S)%s"
 675                              name value
 676                              line-breaking))))
 677       (setq alist (cdr alist))))
 678   (insert ")"))
 679
 680 (defun char-db-insert-char-reference (plist &optional readable column)
 681   (unless column
 682     (setq column (current-column)))
 683   (let ((line-breaking
 684          (concat "\n" (make-string (1+ column) ?\ )))
 685         (separator "")
 686         name value)
 687     (insert "(")
 688     (while plist
 689       (setq name (pop plist))
 690       (setq value (pop plist))
 691       (cond ((eq name :char)
 692              (insert separator)
 693              (insert ":char\t")
 694              (cond ((numberp value)
 695                     (setq value (decode-char '=ucs value)))
 696                    ;; ((consp value)
 697                    ;;  (setq value (or (find-char value)
 698                    ;;                  value)))
 699                    )
 700              (char-db-insert-char-spec value readable)
 701              (insert line-breaking)
 702              (setq separator ""))
 703             ((eq name :radical)
 704              (insert (format "%s%s\t%d ; %c%s"
 705                              separator
 706                              name value
 707                              (ideographic-radical value)
 708                              line-breaking))
 709              (setq separator ""))
 710             (t
 711              (insert (format "%s%s\t%S" separator name value))
 712              (setq separator line-breaking)))
 713       ))
 714   (insert ")"))
 715
 716 (defun char-db-decode-isolated-char (ccs code-point)
 717   (let (ret)
 718     (setq ret
 719           (cond ((eq ccs 'arabic-iso8859-6)
 720                  (decode-char ccs code-point))
 721                 ;; ((eq ccs '=gt)
 722                 ;;  (decode-builtin-char '==gt code-point))
 723                 ((and (memq ccs '(=gt-pj-1
 724                                   =gt-pj-2
 725                                   =gt-pj-3
 726                                   =gt-pj-4
 727                                   =gt-pj-5
 728                                   =gt-pj-6
 729                                   =gt-pj-7
 730                                   =gt-pj-8
 731                                   =gt-pj-9
 732                                   =gt-pj-10
 733                                   =gt-pj-11))
 734                       (setq ret (decode-char ccs code-point))
 735                       (setq ret (encode-char ret '=gt 'defined-only)))
 736                  (decode-builtin-char '=gt ret))
 737                 (t
 738                  (decode-builtin-char ccs code-point))))
 739     (cond ((null ret)
 740            (or (decode-char ccs code-point)
 741                (define-char (list (cons ccs code-point)))))
 742           ((and (<= 0 (char-int ret))
 743                 (<= (char-int ret) #x1F))
 744            (decode-char '=ucs (+ #x2400 (char-int ret))))
 745           ((= (char-int ret) #x7F)
 746            ?\u2421)
 747           (t ret))))
 748
 749 (defvar char-db-convert-obsolete-format t)
 750
 751 (defun char-db-insert-ccs-feature (name value line-breaking)
 752   (cond
 753    ((integerp value)
 754     (insert
 755      (format
 756       (cond
 757        ((memq name '(=>iwds-1
 758                      ==shinjigen
 759                      =shinjigen
 760                      =shinjigen@1ed ==shinjigen@1ed
 761                      =shinjigen@rev ==shinjigen@rev
 762                      =shinjigen/+p@rev ==shinjigen/+p@rev
 763                      ===daikanwa/ho ==daikanwa/ho
 764                      =daikanwa/ho =>>daikanwa/ho =>daikanwa/ho))
 765         "(%-18s .  %04d)\t; %c")
 766        ((eq name '=shinjigen@1ed/24pr)
 767         "(%-18s . %04d)\t; %c")
 768        ((or
 769          (memq name
 770                '(===daikanwa
 771                  ==daikanwa =daikanwa =>>daikanwa =>daikanwa
 772                  =daikanwa@rev1 =daikanwa@rev2
 773                  =daikanwa/+p ==daikanwa/+p ===daikanwa/+p
 774                  =>>daikanwa/+p
 775                  =daikanwa/+2p =>>daikanwa/+2p
 776                  =gt ==gt ===gt
 777                  =>>gt =+>gt =>gt
 778                  =gt-k ==gt-k ===gt-k
 779                  =>>gt-k =>gt-k
 780                  =adobe-japan1-0 ==adobe-japan1-0 ===adobe-japan1-0
 781                  =adobe-japan1-1 ==adobe-japan1-1 ===adobe-japan1-1
 782                  =adobe-japan1-2 ==adobe-japan1-2 ===adobe-japan1-2
 783                  =adobe-japan1-3 ==adobe-japan1-3 ===adobe-japan1-3
 784                  =adobe-japan1-4 ==adobe-japan1-4 ===adobe-japan1-4
 785                  =adobe-japan1-5 ==adobe-japan1-5 ===adobe-japan1-5
 786                  =adobe-japan1-6 ==adobe-japan1-6 ===adobe-japan1-6
 787                  =>>adobe-japan1-0 =+>adobe-japan1-0
 788                  =>>adobe-japan1-1 =+>adobe-japan1-1
 789                  =>>adobe-japan1-2 =+>adobe-japan1-2
 790                  =>>adobe-japan1-3 =+>adobe-japan1-3
 791                  =>>adobe-japan1-4 =+>adobe-japan1-4
 792                  =>>adobe-japan1-5 =+>adobe-japan1-5
 793                  =>>adobe-japan1-6 =+>adobe-japan1-6
 794                  =>cbeta =cbeta =>>cbeta ==cbeta ===cbeta
 795                  =zinbun-oracle =>zinbun-oracle
 796                  =daijiten ==daijiten ===daijiten ==>daijiten
 797                  ===hng-jou ===hng-keg ===hng-dng ===hng-mam
 798                  ===hng-drt ===hng-kgk ===hng-myz ===hng-kda
 799                  ===hng-khi ===hng-khm ===hng-fhs ===hng-hok
 800                  ===hng-kyd ===hng-sok
 801                  ===hng-yhk ===hng-kak ===hng-kar ===hng-kae
 802                  ===hng-sys ===hng-tsu ===hng-tzj
 803                  ===hng-hos ===hng-kkh ===hng-nak ===hng-jhk
 804                  ===hng-hod ===hng-gok ===hng-ink ===hng-nto
 805                  ===hng-nkm ===hng-k24 ===hng-ini ===hng-nkk
 806                  ===hng-kcc ===hng-kcj ===hng-kbk ===hng-sik
 807                  ===hng-skk ===hng-kyu ===hng-ksk ===hng-wan
 808                  ===hng-okd ===hng-wad ===hng-kmi
 809                  ===hng-zkd ===hng-doh ===hng-jyu ===hng-tzs
 810                  ===hng-sai ===hng-kad ===hng-kss
 811                  ===hng-kyo ===hng-ykk ===hng-saa
 812                  ===hng-sab ===hng-wks ===hng-wke ===hng-smk
 813                  ===hng-sgs ===hng-sts ===hng-kkd
 814                  =>shuowen-jiguge =shuowen-jiguge
 815                  ===shuowen-jiguge4 ===shuowen-jiguge5 ===shuowen-jiguge-A30))
 816          ;; (string-match "^=adobe-" (symbol-name name))
 817          )
 818         "(%-18s . %05d)\t; %c")
 819        ((memq name '(=hanyo-denshi/ks
 820                      ==hanyo-denshi/ks ===hanyo-denshi/ks
 821                      =>>hanyo-denshi/ks
 822                      =koseki ==koseki
 823                      =mj ==mj ===mj =>>mj =>mj
 824                      =zihai mojikyo))
 825         "(%-18s . %06d)\t; %c")
 826        ((memq name '(=hanyo-denshi/tk =>hanyo-denshi/tk ==hanyo-denshi/tk))
 827         "(%-18s . %08d)\t; %c")
 828        ((>= (charset-dimension name) 2)
 829         "(%-18s . #x%04X)\t; %c")
 830        (t
 831         "(%-18s . #x%02X)\t; %c"))
 832       name
 833       (if (= (charset-iso-graphic-plane name) 1)
 834           (logior value
 835                   (cond ((= (charset-dimension name) 1)
 836                          #x80)
 837                         ((= (charset-dimension name) 2)
 838                          #x8080)
 839                         ((= (charset-dimension name) 3)
 840                          #x808080)
 841                         (t 0)))
 842         value)
 843       (char-db-decode-isolated-char name value)))
 844     (if (and (= (charset-chars name) 94)
 845              (= (charset-dimension name) 2))
 846         (insert (format " [%02d-%02d]"
 847                         (- (lsh value -8) 32)
 848                         (- (logand value 255) 32))))
 849     )
 850    (t
 851     (insert (format "(%-18s . %s)" name value))
 852     ))
 853   (insert line-breaking))
 854
 855 (defun char-db-insert-relation-feature (char name value line-breaking
 856                                              ccss readable)
 857   (insert (format "(%-18s%s " name line-breaking))
 858   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 859         separator cell sources required-features
 860         ret)
 861     (while (consp value)
 862       (setq cell (car value))
 863       (if (integerp cell)
 864           (setq cell (decode-char '=ucs cell)))
 865       (cond
 866        ((eq name '->subsumptive)
 867         (when (or (not (some (lambda (atr)
 868                                (get-char-attribute cell atr))
 869                              char-db-ignored-attributes))
 870                   (some (lambda (ccs)
 871                           (encode-char cell ccs 'defined-only))
 872                         ccss))
 873           (if separator
 874               (insert lbs))
 875           (let ((char-db-ignored-attributes
 876                  (cons '<-subsumptive
 877                        char-db-ignored-attributes)))
 878             (insert-char-attributes cell readable nil nil 'for-sub-node))
 879           (setq separator lbs))
 880         )
 881        ((characterp cell)
 882         (setq sources
 883               (get-char-attribute
 884                char (intern (format "%s*sources" name))))
 885         (setq required-features nil)
 886         (dolist (source sources)
 887           (cond
 888            ((memq source '(JP
 889                            JP/Jouyou
 890                            shinjigen shinjigen@1ed shinjigen@rev))
 891             (setq required-features
 892                   (union required-features
 893                          '(=jis-x0208
 894                            =jis-x0208@1990
 895                            =jis-x0213-1@2000
 896                            =jis-x0213-1@2004
 897                            =jis-x0213-2
 898                            =jis-x0212
 899                            =jis-x0208@1983
 900                            =jis-x0208@1978
 901                            =shinjigen
 902                            =shinjigen@1ed
 903                            =shinjigen@rev
 904                            =shinjigen/+p@rev))))
 905            ((eq source 'CN)
 906             (setq required-features
 907                   (union required-features
 908                          '(=gb2312
 909                            =gb12345
 910                            =iso-ir165)))))
 911           (cond
 912            ((find-charset (setq ret (intern (format "=%s" source))))
 913             (setq required-features
 914                   (cons ret required-features)))
 915            (t (setq required-features
 916                     (cons source required-features)))))
 917         (cond ((string-match "@JP" (symbol-name name))
 918                (setq required-features
 919                      (union required-features
 920                             '(=jis-x0208
 921                               =jis-x0208@1990
 922                               =jis-x0213-1-2000
 923                               =jis-x0213-2-2000
 924                               =jis-x0212
 925                               =jis-x0208@1983
 926                               =jis-x0208@1978))))
 927               ((string-match "@CN" (symbol-name name))
 928                (setq required-features
 929                      (union required-features
 930                             '(=gb2312
 931                               =gb12345
 932                               =iso-ir165)))))
 933         (if separator
 934             (insert lbs))
 935         (if readable
 936             (insert (format "%S" cell))
 937           (char-db-insert-char-spec cell readable
 938                                     nil
 939                                     required-features))
 940         (setq separator lbs))
 941        ((consp cell)
 942         (if separator
 943             (insert lbs))
 944         (if (consp (car cell))
 945             (char-db-insert-char-spec cell readable)
 946           (char-db-insert-char-reference cell readable))
 947         (setq separator lbs))
 948        (t
 949         (if separator
 950             (insert separator))
 951         (insert (prin1-to-string cell))
 952         (setq separator " ")))
 953       (setq value (cdr value)))
 954     (insert ")")
 955     (insert line-breaking)))
 956
 957 (defun insert-char-attributes (char &optional readable attributes column
 958                                     for-sub-node)
 959   (unless column
 960     (setq column (current-column)))
 961   (let (name value ; has-long-ccs-name
 962         rest
 963         radical strokes
 964         (line-breaking
 965          (concat "\n" (make-string (1+ column) ?\ )))
 966         lbs cell separator ret
 967         key al cal
 968         dest-ccss ; sources required-features
 969         ccss)
 970     (let (atr-d)
 971       (setq attributes
 972             (sort (if attributes
 973                       (if (consp attributes)
 974                           (progn
 975                             (dolist (name attributes)
 976                               (unless (memq name char-db-ignored-attributes)
 977                                 (if (find-charset name)
 978                                     (push name ccss))
 979                                 (push name atr-d)))
 980                             atr-d))
 981                     (dolist (name (char-attribute-list))
 982                       (unless (memq name char-db-ignored-attributes)
 983                         (if (find-charset name)
 984                             (push name ccss))
 985                         (push name atr-d)))
 986                     atr-d)
 987                   #'char-attribute-name<)))
 988     (insert "(")
 989     (when (memq '<-subsumptive attributes)
 990       (when (or readable (not for-sub-node))
 991         (when (setq value (get-char-attribute char '<-subsumptive))
 992           (char-db-insert-relation-feature char '<-subsumptive value
 993                                            line-breaking
 994                                            ccss readable)))
 995       (setq attributes (delq '<-subsumptive attributes)))
 996     (when (and (memq '<-denotational attributes)
 997                (setq value (get-char-attribute char '<-denotational)))
 998       (char-db-insert-relation-feature char '<-denotational value
 999                                        line-breaking
1000                                        ccss readable)
1001       (setq attributes (delq '<-denotational attributes)))
1002     (when (and (memq '<-denotational@component attributes)
1003                (setq value (get-char-attribute char '<-denotational@component)))
1004       (char-db-insert-relation-feature char '<-denotational@component value
1005                                        line-breaking
1006                                        ccss readable)
1007       (setq attributes (delq '<-denotational@component attributes)))
1008     (when (and (memq '<-denotational@usage attributes)
1009                (setq value (get-char-attribute char '<-denotational@usage)))
1010       (char-db-insert-relation-feature char '<-denotational@usage value
1011                                        line-breaking
1012                                        ccss readable)
1013       (setq attributes (delq '<-denotational@usage attributes)))
1014     (when (and (memq 'name attributes)
1015                (setq value (get-char-attribute char 'name)))
1016       (insert (format
1017                (if (> (+ (current-column) (length value)) 48)
1018                    "(name . %S)%s"
1019                  "(name               . %S)%s")
1020                value line-breaking))
1021       (setq attributes (delq 'name attributes))
1022       )
1023     (when (and (memq 'name* attributes)
1024                (setq value (get-char-attribute char 'name*)))
1025       (insert (format
1026                (if (> (+ (current-column) (length value)) 48)
1027                    "(name* . %S)%s"
1028                  "(name*              . %S)%s")
1029                value line-breaking))
1030       (setq attributes (delq 'name* attributes))
1031       )
1032     (when (and (memq 'script attributes)
1033                (setq value (get-char-attribute char 'script)))
1034       (insert (format "(script\t\t%s)%s"
1035                       (mapconcat (function prin1-to-string)
1036                                  value " ")
1037                       line-breaking))
1038       (setq attributes (delq 'script attributes))
1039       )
1040     (dolist (name '(=>ucs =>ucs*))
1041       (when (and (memq name attributes)
1042                  (setq value (get-char-attribute char name)))
1043         (insert (format "(%-18s . #x%04X)\t; %c%s"
1044                         name value (decode-char '=ucs value)
1045                         line-breaking))
1046         (setq attributes (delq name attributes))))
1047     (dolist (name '(=>ucs@gb =>ucs@big5))
1048       (when (and (memq name attributes)
1049                  (setq value (get-char-attribute char name)))
1050         (insert (format "(%-18s . #x%04X)\t; %c%s"
1051                         name value
1052                         (decode-char (intern
1053                                       (concat "="
1054                                               (substring
1055                                                (symbol-name name) 2)))
1056                                      value)
1057                         line-breaking))
1058         (setq attributes (delq name attributes))
1059         ))
1060     ;; (dolist (name '(=>daikanwa))
1061     ;;   (when (and (memq name attributes)
1062     ;;              (setq value (get-char-attribute char name)))
1063     ;;     (insert
1064     ;;      (if (integerp value)
1065     ;;          (format "(%-18s . %05d)\t; %c%s"
1066     ;;                  name value (decode-char '=daikanwa value)
1067     ;;                  line-breaking)
1068     ;;        (format "(%-18s %s)\t; %c%s"
1069     ;;                name
1070     ;;                (mapconcat (function prin1-to-string)
1071     ;;                           value " ")
1072     ;;                (char-representative-of-daikanwa char)
1073     ;;                line-breaking)))
1074     ;;     (setq attributes (delq name attributes))))
1075     (when (and (memq 'general-category attributes)
1076                (setq value (get-char-attribute char 'general-category)))
1077       (insert (format
1078                "(general-category\t%s) ; %s%s"
1079                (mapconcat (lambda (cell)
1080                             (format "%S" cell))
1081                           value " ")
1082                (cond ((rassoc value unidata-normative-category-alist)
1083                       "Normative Category")
1084                      ((rassoc value unidata-informative-category-alist)
1085                       "Informative Category")
1086                      (t
1087                       "Unknown Category"))
1088                line-breaking))
1089       (setq attributes (delq 'general-category attributes))
1090       )
1091     (when (and (memq 'bidi-category attributes)
1092                (setq value (get-char-attribute char 'bidi-category)))
1093       (insert (format "(bidi-category\t. %S)%s"
1094                       value
1095                       line-breaking))
1096       (setq attributes (delq 'bidi-category attributes))
1097       )
1098     (unless (or (not (memq 'mirrored attributes))
1099                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
1100                     'empty))
1101       (insert (format "(mirrored\t\t. %S)%s"
1102                       value
1103                       line-breaking))
1104       (setq attributes (delq 'mirrored attributes))
1105       )
1106     (cond
1107      ((and (memq 'decimal-digit-value attributes)
1108            (setq value (get-char-attribute char 'decimal-digit-value)))
1109       (insert (format "(decimal-digit-value . %S)%s"
1110                       value
1111                       line-breaking))
1112       (setq attributes (delq 'decimal-digit-value attributes))
1113       (when (and (memq 'digit-value attributes)
1114                  (setq value (get-char-attribute char 'digit-value)))
1115         (insert (format "(digit-value\t . %S)%s"
1116                         value
1117                         line-breaking))
1118         (setq attributes (delq 'digit-value attributes))
1119         )
1120       (when (and (memq 'numeric-value attributes)
1121                  (setq value (get-char-attribute char 'numeric-value)))
1122         (insert (format "(numeric-value\t . %S)%s"
1123                         value
1124                         line-breaking))
1125         (setq attributes (delq 'numeric-value attributes))
1126         )
1127       )
1128      (t
1129       (when (and (memq 'digit-value attributes)
1130                  (setq value (get-char-attribute char 'digit-value)))
1131         (insert (format "(digit-value\t. %S)%s"
1132                         value
1133                         line-breaking))
1134         (setq attributes (delq 'digit-value attributes))
1135         )
1136       (when (and (memq 'numeric-value attributes)
1137                  (setq value (get-char-attribute char 'numeric-value)))
1138         (insert (format "(numeric-value\t. %S)%s"
1139                         value
1140                         line-breaking))
1141         (setq attributes (delq 'numeric-value attributes))
1142         )))
1143     (when (and (memq 'iso-10646-comment attributes)
1144                (setq value (get-char-attribute char 'iso-10646-comment)))
1145       (insert (format "(iso-10646-comment\t. %S)%s"
1146                       value
1147                       line-breaking))
1148       (setq attributes (delq 'iso-10646-comment attributes))
1149       )
1150     (when (and (memq 'morohashi-daikanwa attributes)
1151                (setq value (get-char-attribute char 'morohashi-daikanwa)))
1152       (insert (format "(morohashi-daikanwa\t%s)%s"
1153                       (mapconcat (function prin1-to-string) value " ")
1154                       line-breaking))
1155       (setq attributes (delq 'morohashi-daikanwa attributes))
1156       )
1157     (setq radical nil
1158           strokes nil)
1159     (when (and (memq 'ideographic-radical attributes)
1160                (setq value (get-char-attribute char 'ideographic-radical)))
1161       (setq radical value)
1162       (insert (format "(ideographic-radical . %S)\t; %c%s"
1163                       radical
1164                       (ideographic-radical radical)
1165                       line-breaking))
1166       (setq attributes (delq 'ideographic-radical attributes))
1167       )
1168     (when (and (memq 'shuowen-radical attributes)
1169                (setq value (get-char-attribute char 'shuowen-radical)))
1170       (insert (format "(shuowen-radical\t. %S)\t; %c%s"
1171                       value
1172                       (shuowen-radical value)
1173                       line-breaking))
1174       (setq attributes (delq 'shuowen-radical attributes))
1175       )
1176     (let (key)
1177       (dolist (domain
1178                (append
1179                 char-db-feature-domains
1180                 (let (dest domain)
1181                   (dolist (feature (char-attribute-list))
1182                     (setq feature (symbol-name feature))
1183                     (when (string-match
1184                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
1185                            feature)
1186                       (setq domain (intern (match-string 2 feature)))
1187                      (unless (memq domain dest)
1188                        (setq dest (cons domain dest)))))
1189                   (sort dest #'string<))))
1190         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
1191         (when (and (memq key attributes)
1192                    (setq value (get-char-attribute char key)))
1193           (setq radical value)
1194           (insert (format "(%s . %S)\t; %c%s"
1195                           key
1196                           radical
1197                           (ideographic-radical radical)
1198                           line-breaking))
1199           (setq attributes (delq key attributes))
1200           )
1201         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
1202         (when (and (memq key attributes)
1203                    (setq value (get-char-attribute char key)))
1204           (setq strokes value)
1205           (insert (format "(%s . %S)%s"
1206                           key
1207                           strokes
1208                           line-breaking))
1209           (setq attributes (delq key attributes))
1210           )
1211         (setq key (intern (format "%s@%s" 'total-strokes domain)))
1212         (when (and (memq key attributes)
1213                    (setq value (get-char-attribute char key)))
1214           (insert (format "(%s       . %S)%s"
1215                           key
1216                           value
1217                           line-breaking))
1218           (setq attributes (delq key attributes))
1219           )
1220         (dolist (feature '(ideographic-radical
1221                            ideographic-strokes
1222                            total-strokes))
1223           (setq key (intern (format "%s@%s*sources" feature domain)))
1224           (when (and (memq key attributes)
1225                      (setq value (get-char-attribute char key)))
1226             (insert (format "(%s%s" key line-breaking))
1227             (dolist (cell value)
1228               (insert (format " %s" cell)))
1229             (insert ")")
1230             (insert line-breaking)
1231             (setq attributes (delq key attributes))
1232             ))
1233         ))
1234     (when (and (memq 'ideographic-strokes attributes)
1235                (setq value (get-char-attribute char 'ideographic-strokes)))
1236       (setq strokes value)
1237       (insert (format "(ideographic-strokes . %S)%s"
1238                       strokes
1239                       line-breaking))
1240       (setq attributes (delq 'ideographic-strokes attributes))
1241       )
1242     (when (and (memq 'kangxi-radical attributes)
1243                (setq value (get-char-attribute char 'kangxi-radical)))
1244       (unless (eq value radical)
1245         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
1246                         value
1247                         (ideographic-radical value)
1248                         line-breaking))
1249         (or radical
1250             (setq radical value)))
1251       (setq attributes (delq 'kangxi-radical attributes))
1252       )
1253     (when (and (memq 'kangxi-strokes attributes)
1254                (setq value (get-char-attribute char 'kangxi-strokes)))
1255       (unless (eq value strokes)
1256         (insert (format "(kangxi-strokes\t . %S)%s"
1257                         value
1258                         line-breaking))
1259         (or strokes
1260             (setq strokes value)))
1261       (setq attributes (delq 'kangxi-strokes attributes))
1262       )
1263     ;; (when (and (memq 'japanese-radical attributes)
1264     ;;            (setq value (get-char-attribute char 'japanese-radical)))
1265     ;;   (unless (eq value radical)
1266     ;;     (insert (format "(japanese-radical\t . %S)\t; %c%s"
1267     ;;                     value
1268     ;;                     (ideographic-radical value)
1269     ;;                     line-breaking))
1270     ;;     (or radical
1271     ;;         (setq radical value)))
1272     ;;   (setq attributes (delq 'japanese-radical attributes))
1273     ;;   )
1274     (when (and (memq 'japanese-strokes attributes)
1275                (setq value (get-char-attribute char 'japanese-strokes)))
1276       (unless (eq value strokes)
1277         (insert (format "(japanese-strokes\t . %S)%s"
1278                         value
1279                         line-breaking))
1280         (or strokes
1281             (setq strokes value)))
1282       (setq attributes (delq 'japanese-strokes attributes))
1283       )
1284     (when (and (memq 'cns-radical attributes)
1285                (setq value (get-char-attribute char 'cns-radical)))
1286       (insert (format "(cns-radical\t . %S)\t; %c%s"
1287                       value
1288                       (ideographic-radical value)
1289                       line-breaking))
1290       (setq attributes (delq 'cns-radical attributes))
1291       )
1292     (when (and (memq 'cns-strokes attributes)
1293                (setq value (get-char-attribute char 'cns-strokes)))
1294       (unless (eq value strokes)
1295         (insert (format "(cns-strokes\t . %S)%s"
1296                         value
1297                         line-breaking))
1298         (or strokes
1299             (setq strokes value)))
1300       (setq attributes (delq 'cns-strokes attributes))
1301       )
1302     ;; (when (and (memq 'ideographic- attributes)
1303     ;;            (setq value (get-char-attribute char 'ideographic-)))
1304     ;;   (insert "(ideographic-       ")
1305     ;;   (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1306     ;;         separator nil)
1307     ;;   (while (consp value)
1308     ;;     (setq cell (car value))
1309     ;;     (if (integerp cell)
1310     ;;         (setq cell (decode-char '=ucs cell)))
1311     ;;     (cond ((characterp cell)
1312     ;;            (if separator
1313     ;;                (insert lbs))
1314     ;;            (if readable
1315     ;;                (insert (format "%S" cell))
1316     ;;              (char-db-insert-char-spec cell readable))
1317     ;;            (setq separator lbs))
1318     ;;           ((consp cell)
1319     ;;            (if separator
1320     ;;                (insert lbs))
1321     ;;            (if (consp (car cell))
1322     ;;                (char-db-insert-char-spec cell readable)
1323     ;;              (char-db-insert-char-reference cell readable))
1324     ;;            (setq separator lbs))
1325     ;;           (t
1326     ;;            (if separator
1327     ;;                (insert separator))
1328     ;;            (insert (prin1-to-string cell))
1329     ;;            (setq separator " ")))
1330     ;;     (setq value (cdr value)))
1331     ;;   (insert ")")
1332     ;;   (insert line-breaking)
1333     ;;   (setq attributes (delq 'ideographic- attributes)))
1334     (when (and (memq 'total-strokes attributes)
1335                (setq value (get-char-attribute char 'total-strokes)))
1336       (insert (format "(total-strokes       . %S)%s"
1337                       value
1338                       line-breaking))
1339       (setq attributes (delq 'total-strokes attributes))
1340       )
1341     ;; (when (and (memq '->ideograph attributes)
1342     ;;            (setq value (get-char-attribute char '->ideograph)))
1343     ;;   (insert (format "(->ideograph\t%s)%s"
1344     ;;                   (mapconcat (lambda (code)
1345     ;;                                (cond ((symbolp code)
1346     ;;                                       (symbol-name code))
1347     ;;                                      ((integerp code)
1348     ;;                                       (format "#x%04X" code))
1349     ;;                                      (t
1350     ;;                                       (format "%s %S"
1351     ;;                                               line-breaking code))))
1352     ;;                              value " ")
1353     ;;                   line-breaking))
1354     ;;   (setq attributes (delq '->ideograph attributes))
1355     ;;   )
1356     ;; (when (and (memq '->decomposition attributes)
1357     ;;            (setq value (get-char-attribute char '->decomposition)))
1358     ;;   (insert (format "(->decomposition\t%s)%s"
1359     ;;                   (mapconcat (lambda (code)
1360     ;;                                (cond ((symbolp code)
1361     ;;                                       (symbol-name code))
1362     ;;                                      ((characterp code)
1363     ;;                                       (if readable
1364     ;;                                           (format "%S" code)
1365     ;;                                         (format "#x%04X"
1366     ;;                                                 (char-int code))
1367     ;;                                         ))
1368     ;;                                      ((integerp code)
1369     ;;                                       (format "#x%04X" code))
1370     ;;                                      (t
1371     ;;                                       (format "%s%S" line-breaking code))))
1372     ;;                              value " ")
1373     ;;                   line-breaking))
1374     ;;   (setq attributes (delq '->decomposition attributes))
1375     ;;   )
1376     (if (equal (get-char-attribute char '->titlecase)
1377                (get-char-attribute char '->uppercase))
1378         (setq attributes (delq '->titlecase attributes)))
1379     (when (and (memq '->mojikyo attributes)
1380                (setq value (get-char-attribute char '->mojikyo)))
1381       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
1382                       value (decode-char 'mojikyo value)
1383                       line-breaking))
1384       (setq attributes (delq '->mojikyo attributes))
1385       )
1386     (unless readable
1387       (dolist (ignored '(composition
1388                          ->denotational <-subsumptive ->ucs-unified
1389                          ;; ->ideographic-component-forms
1390                          ))
1391         (setq attributes (delq ignored attributes))))
1392     (while attributes
1393       (setq name (car attributes))
1394       (unless (eq (setq value (get-char-attribute char name 'value-is-empty))
1395                   'value-is-empty)
1396         (cond ((setq ret (find-charset name))
1397                (setq name (charset-name ret))
1398                (when (not (memq name dest-ccss))
1399                  (setq dest-ccss (cons name dest-ccss))
1400                  (char-db-insert-ccs-feature name value line-breaking))
1401                )
1402               ((string-match "^=>ucs@" (symbol-name name))
1403                (insert (format "(%-18s . #x%04X)\t; %c%s"
1404                                name value (decode-char '=ucs value)
1405                                line-breaking))
1406                )
1407               ((eq name 'jisx0208-1978/4X)
1408                (insert (format "(%-18s . #x%04X)%s"
1409                                name value
1410                                line-breaking))
1411                )
1412               ((and
1413                 (not readable)
1414                 (not (eq name '->subsumptive))
1415                 (not (eq name '->uppercase))
1416                 (not (eq name '->lowercase))
1417                 (not (eq name '->titlecase))
1418                 (not (eq name '->canonical))
1419                 (not (eq name '->Bopomofo))
1420                 (not (eq name '->mistakable))
1421                 (not (eq name '->ideographic-variants))
1422                 (null (get-char-attribute
1423                        char (intern (format "%s*sources" name))))
1424                 (not (string-match "\\*sources$" (symbol-name name)))
1425                 (null (get-char-attribute
1426                        char (intern (format "%s*note" name))))
1427                 (not (string-match "\\*note$" (symbol-name name)))
1428                 (or (eq name '<-identical)
1429                     (eq name '<-uppercase)
1430                     (eq name '<-lowercase)
1431                     (eq name '<-titlecase)
1432                     (eq name '<-canonical)
1433                     (eq name '<-ideographic-variants)
1434                     ;; (eq name '<-synonyms)
1435                     (string-match "^<-synonyms" (symbol-name name))
1436                     (eq name '<-mistakable)
1437                     (when (string-match "^->" (symbol-name name))
1438                       (cond
1439                        ((string-match "^->fullwidth" (symbol-name name))
1440                         (not (and (consp value)
1441                                   (characterp (car value))
1442                                   (encode-char
1443                                    (car value) '=ucs 'defined-only)))
1444                         )
1445                        (t)))
1446                     ))
1447                )
1448               ((or (eq name 'ideographic-structure)
1449                    (eq name 'ideographic-structure@apparent)
1450                    (eq name 'ideographic-structure@apparent/leftmost)
1451                    (eq name 'ideographic-structure@apparent/rightmost)
1452                    (eq name 'ideographic-combination)
1453                    ;; (eq name 'ideographic-)
1454                    (eq name '=decomposition)
1455                    (char-feature-base-name= '=decomposition name)
1456                    (char-feature-base-name= '=>decomposition name)
1457                    ;; (string-match "^=>*decomposition\\(@[^*]+\\)?$"
1458                    ;;               (symbol-name name))
1459                    (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
1460                    (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
1461                                  (symbol-name name))
1462                    )
1463                (char-db-insert-relation-feature char name value
1464                                                 line-breaking
1465                                                 ccss readable))
1466               ;; ((memq name '(ideograph=
1467               ;;               original-ideograph-of
1468               ;;               ancient-ideograph-of
1469               ;;               vulgar-ideograph-of
1470               ;;               wrong-ideograph-of
1471               ;;               ;; simplified-ideograph-of
1472               ;;               ideographic-variants
1473               ;;               ;; ideographic-different-form-of
1474               ;;               ))
1475               ;;  (insert (format "(%-18s%s " name line-breaking))
1476               ;;  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1477               ;;        separator nil)
1478               ;;  (while (consp value)
1479               ;;    (setq cell (car value))
1480               ;;    (if (and (consp cell)
1481               ;;             (consp (car cell)))
1482               ;;        (progn
1483               ;;          (if separator
1484               ;;              (insert lbs))
1485               ;;          (char-db-insert-alist cell readable)
1486               ;;          (setq separator lbs))
1487               ;;      (if separator
1488               ;;          (insert separator))
1489               ;;      (insert (prin1-to-string cell))
1490               ;;      (setq separator " "))
1491               ;;    (setq value (cdr value)))
1492               ;;  (insert ")")
1493               ;;  (insert line-breaking))
1494               ((consp value)
1495                (insert (format "(%-18s " name))
1496                (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1497                      separator nil)
1498                (while (consp value)
1499                  (setq cell (car value))
1500                  (if (and (consp cell)
1501                           (consp (car cell))
1502                           (setq ret (condition-case nil
1503                                         (find-char cell)
1504                                       (error nil))))
1505                      (progn
1506                        (setq rest cell
1507                              al nil
1508                              cal nil)
1509                        (while rest
1510                          (setq key (car (car rest)))
1511                          (if (find-charset key)
1512                              (setq cal (cons key cal))
1513                            (setq al (cons key al)))
1514                          (setq rest (cdr rest)))
1515                        (if separator
1516                            (insert lbs))
1517                        (insert-char-attributes ret
1518                                                readable
1519                                                al ; cal
1520                                                nil 'for-sub-node)
1521                        (setq separator lbs))
1522                    (setq ret (prin1-to-string cell))
1523                    (if separator
1524                        (if (< (+ (current-column)
1525                                  (length ret)
1526                                  (length separator))
1527                               76)
1528                            (insert separator)
1529                          (insert lbs)))
1530                    (insert ret)
1531                    (setq separator " "))
1532                  (setq value (cdr value)))
1533                (insert ")")
1534                (insert line-breaking))
1535               (t
1536                (insert (format "(%-18s" name))
1537                (setq ret (prin1-to-string value))
1538                (unless (< (+ (current-column)
1539                              (length ret)
1540                              3)
1541                           76)
1542                  (insert line-breaking))
1543                (insert " . " ret ")" line-breaking)
1544                ;; (insert (format "(%-18s . %S)%s"
1545                ;;                 name value
1546                ;;                 line-breaking))
1547                )
1548               ))
1549       (setq attributes (cdr attributes)))
1550     (insert ")")))
1551
1552 (defun insert-char-data (char &optional readable
1553                               attributes)
1554   (save-restriction
1555     (narrow-to-region (point)(point))
1556     (insert "(define-char
1557   '")
1558     (insert-char-attributes char readable attributes)
1559     (insert ")\n")
1560     (goto-char (point-min))
1561     (while (re-search-forward "[ \t]+$" nil t)
1562       (replace-match ""))
1563     ;; from tabify.
1564     (goto-char (point-min))
1565     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1566       (let ((column (current-column))
1567             (indent-tabs-mode t))
1568         (delete-region (match-beginning 0) (point))
1569         (indent-to column)))
1570     (goto-char (point-max))
1571     ;; (tabify (point-min)(point-max))
1572     ))
1573
1574 (defun insert-char-data-with-variant (char &optional printable
1575                                            no-ucs-unified
1576                                            script excluded-script)
1577   (insert-char-data char printable)
1578   (let ((variants (char-variants char))
1579         rest
1580         variant vs ret)
1581     (setq variants (sort variants #'<))
1582     (setq rest variants)
1583     (setq variants (cons char variants))
1584     (while rest
1585       (setq variant (car rest))
1586       (unless (get-char-attribute variant '<-subsumptive)
1587         (if (and (or (null script)
1588                      (null (setq vs (get-char-attribute variant 'script)))
1589                      (memq script vs))
1590                  (or (null excluded-script)
1591                      (null (setq vs (get-char-attribute variant 'script)))
1592                      (not (memq excluded-script vs))))
1593             (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1594               (insert-char-data variant printable)
1595               (if (setq ret (char-variants variant))
1596                   (while ret
1597                     (or (memq (car ret) variants)
1598                         ;; (get-char-attribute (car ret) '<-subsumptive)
1599                         (setq rest (nconc rest (list (car ret)))))
1600                     (setq ret (cdr ret)))))))
1601       (setq rest (cdr rest)))))
1602
1603 (defun insert-char-range-data (min max &optional script excluded-script)
1604   (let ((code min)
1605         char)
1606     (while (<= code max)
1607       (setq char (decode-char '=ucs code))
1608       (if (encode-char char '=ucs 'defined-only)
1609           (insert-char-data-with-variant char nil 'no-ucs-unified
1610                                          script excluded-script))
1611       (setq code (1+ code)))))
1612
1613 (defun write-char-range-data-to-file (min max file
1614                                           &optional script excluded-script)
1615   (let ((coding-system-for-write char-db-file-coding-system))
1616     (with-temp-buffer
1617       (insert (format ";; -*- coding: %s -*-\n"
1618                       char-db-file-coding-system))
1619       (insert-char-range-data min max script excluded-script)
1620       (write-region (point-min)(point-max) file))))
1621
1622 (defvar what-character-original-window-configuration)
1623
1624 ;;;###autoload
1625 (defun what-char-definition (char)
1626   (interactive (list (char-after)))
1627   (let ((buf (get-buffer-create "*Character Description*"))
1628         (the-buf (current-buffer))
1629         (win-conf (current-window-configuration)))
1630     (pop-to-buffer buf)
1631     (make-local-variable 'what-character-original-window-configuration)
1632     (setq what-character-original-window-configuration win-conf)
1633     (setq buffer-read-only nil)
1634     (erase-buffer)
1635     (condition-case err
1636         (progn
1637           (insert-char-data-with-variant char 'printable)
1638           (unless (char-attribute-alist char)
1639             (insert (format ";; = %c\n"
1640                             (let* ((rest (split-char char))
1641                                    (ccs (pop rest))
1642                                    (code (pop rest)))
1643                               (while rest
1644                                 (setq code (logior (lsh code 8)
1645                                                    (pop rest))))
1646                               (decode-char ccs code)))))
1647           ;; (char-db-update-comment)
1648           (set-buffer-modified-p nil)
1649           (view-mode the-buf (lambda (buf)
1650                                (set-window-configuration
1651                                 what-character-original-window-configuration)
1652                                ))
1653           (goto-char (point-min)))
1654       (error (progn
1655                (set-window-configuration
1656                 what-character-original-window-configuration)
1657                (signal (car err) (cdr err)))))))
1658
1659
1660 ;;; @ end
1661 ;;;
1662
1663 (provide 'char-db-util)
1664
1665 ;;; char-db-util.el ends here