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