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