git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility -*- coding: utf-8-er; -*-
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009, 2010, 2011 MORIOKA Tomohiko.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
   8
   9 ;; This file is part of XEmacs CHISE.
  10
  11 ;; XEmacs CHISE is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'chise-subr)
  29 (require 'ideograph-subr)
  30
  31 (defconst unidata-normative-category-alist
  32   '(("Lu" letter        uppercase)
  33     ("Ll" letter        lowercase)
  34     ("Lt" letter        titlecase)
  35     ("Mn" mark          non-spacing)
  36     ("Mc" mark          spacing-combining)
  37     ("Me" mark          enclosing)
  38     ("Nd" number        decimal-digit)
  39     ("Nl" number        letter)
  40     ("No" number        other)
  41     ("Zs" separator     space)
  42     ("Zl" separator     line)
  43     ("Zp" separator     paragraph)
  44     ("Cc" other         control)
  45     ("Cf" other         format)
  46     ("Cs" other         surrogate)
  47     ("Co" other         private-use)
  48     ("Cn" other         not-assigned)))
  49
  50 (defconst unidata-informative-category-alist
  51   '(("Lm" letter        modifier)
  52     ("Lo" letter        other)
  53     ("Pc" punctuation   connector)
  54     ("Pd" punctuation   dash)
  55     ("Ps" punctuation   open)
  56     ("Pe" punctuation   close)
  57     ("Pi" punctuation   initial-quote)
  58     ("Pf" punctuation   final-quote)
  59     ("Po" punctuation   other)
  60     ("Sm" symbol        math)
  61     ("Sc" symbol        currency)
  62     ("Sk" symbol        modifier)
  63     ("So" symbol        other)
  64     ))
  65
  66 (defconst shuowen-radicals
  67   [?一 ?上 ?示 ?三 ?王 ?玉 ?玨 ?气 ?士 ?丨 ; 010
  68    ?屮 ?艸 ?蓐 ?茻 ?小 ?八 ?釆 ?半 ?牛 ?犛 ; 020
  69    ?告 ?口 ?凵 ?吅 ?哭 ?走 ?止 ?癶 ?步 ?此 ; 030
  70    ?正 ?是 ?辵 ?彳 ?廴 ?㢟 ?行 ?齒 ?牙 ?足 ; 040
  71    ?疋 ?品 ?龠 ?冊 ?㗊 ?舌 ?干 ?谷 ?只 ?㕯 ; 050
  72    ?句 ?丩 ?古 ?十 ?卅 ?言 ?誩 ?音 ?䇂 ?丵 ; 060
  73    ?菐 ?𠬞 ?廾 ?共 ?異 ?舁 ?𦥑 ?䢅 ?爨 ?革 ; 070
  74    ?鬲 ?䰜 ?爪 ?𠃨 ?鬥 ?又 ?𠂇 ?㕜 ?支 ?𦘒 ; 080
  75    ?聿 ?畫 ?隶 ?臤 ?臣 ?殳 ?殺 ?𠘧 ?寸 ?皮 ; 090
  76    ?㼱 ?攴 ?敎 ?卜 ?用 ?爻 ?㸚 ?𥄎 ?目 ?䀠 ; 100
  77    ?眉 ?盾 ?自 ?白 ?鼻 ?皕 ?習 ?羽 ?隹 ?奞 ; 110
  78    ?萑 ?𦫳 ?苜 ?羊 ?羴 ?瞿 ?雔 ?雥 ?鳥 ?烏 ; 120
  79    ?𠦒 ?冓 ?幺 ?𢆶 ?叀 ?玄 ?予 ?放 ?𠬪 ?𣦼 ; 130
  80    ?歺 ?死 ?冎 ?骨 ?肉 ?筋 ?刀 ?刃 ?㓞 ?丰 ; 140
  81    ?耒 ?𧢲 ?竹 ?箕 ?丌 ?左 ?工 ?㠭 ?巫 ?甘 ; 150
  82    ?曰 ?乃 ?丂 ?可 ?兮 ?号 ?亏 ?旨 ?喜 ?壴 ; 160
  83    ?鼓 ?豈 ?豆 ?豊 ?豐 ?䖒 ?虍 ?虎 ?虤 ?皿 ; 170
  84    ?𠙴 ?去 ?血 ?丶 ?丹 ?青 ?井 ?皀 ?鬯 ?食 ; 180
  85    ?亼 ?會 ?倉 ?入 ?缶 ?矢 ?高 ?冂 ?𩫏 ?京 ; 190
  86    ?亯 ?𣆪 ?畗 ?㐭 ?嗇 ?來 ?麥 ?夊 ?舛 ?䑞 ; 200
  87    ?韋 ?弟 ?夂 ?久 ?桀 ?木 ?東 ?林 ?才 ?叒 ; 210
  88    ?之 ?帀 ?出 ?𣎵 ?生 ?乇 ?𠂹 ?𠌶 ?華 ?𥝌 ; 220
  89    ?稽 ?巢 ?桼 ?束 ?㯻 ?囗 ?員 ?貝 ?邑 ?𨛜 ; 230
  90    ?日 ?旦 ?倝 ?㫃 ?冥 ?晶 ?月 ?有 ?明 ?囧 ; 240
  91    ?夕 ?多 ?毌 ?𢎘 ?𣐺 ?卣 ?齊 ?朿 ?片 ?鼎 ; 250
  92    ?克 ?彔 ?禾 ?秝 ?黍 ?香 ?米 ?毇 ?臼 ?凶 ; 260
  93    ?𣎳 ?林 ?麻 ?尗 ?耑 ?韭 ?瓜 ?瓠 ?宀 ?宮 ; 270
  94    ?呂 ?穴 ?㝱 ?𤕫 ?冖 ?𠔼 ?冃 ?㒳 ?网 ?襾 ; 280
  95    ?巾 ?巿 ?帛 ?白 ?㡀 ?黹 ?人 ?𠤎 ?匕 ?从 ; 290
  96    ])
  97
  98 (defun shuowen-radical (number)
  99   (aref shuowen-radicals (1- number)))
 100
 101 (defvar char-db-file-coding-system 'utf-8-mcs-er)
 102
 103 (defvar char-db-ignored-attributes '(ideographic-products))
 104
 105 (defvar char-db-coded-charset-priority-list
 106   '(ascii
 107     control-1
 108     latin-iso8859-1
 109     latin-iso8859-2
 110     latin-iso8859-3
 111     latin-iso8859-4
 112     latin-iso8859-9
 113     latin-jisx0201
 114     cyrillic-iso8859-5
 115     greek-iso8859-7
 116     thai-tis620
 117     =jis-x0208
 118     =jis-x0208@1978
 119     =jis-x0208@1983
 120     japanese-jisx0212
 121     chinese-gb2312
 122     =jis-x0208@1990
 123     chinese-cns11643-1
 124     chinese-cns11643-2
 125     chinese-cns11643-3
 126     chinese-cns11643-4
 127     chinese-cns11643-5
 128     chinese-cns11643-6
 129     chinese-cns11643-7
 130     =jis-x0213-1
 131     =jis-x0213-1@2000
 132     =jis-x0213-1@2004
 133     =jis-x0213-2
 134     korean-ksc5601
 135     chinese-isoir165
 136     katakana-jisx0201
 137     hebrew-iso8859-8
 138     chinese-gb12345
 139     latin-viscii
 140     ethiopic-ucs
 141     =big5-cdp
 142     =gt
 143     =adobe-japan1-0
 144     =adobe-japan1-1
 145     =adobe-japan1-2
 146     =adobe-japan1-3
 147     =adobe-japan1-4
 148     =adobe-japan1-5
 149     =adobe-japan1-6
 150     =hanyo-denshi/ja
 151     =hanyo-denshi/jb
 152     =hanyo-denshi/jc
 153     =hanyo-denshi/jd
 154     =hanyo-denshi/ft
 155     =hanyo-denshi/ia
 156     =hanyo-denshi/ib
 157     =hanyo-denshi/hg
 158     ideograph-daikanwa-2
 159     ideograph-daikanwa
 160     =cbeta
 161     =gt-k
 162     ideograph-hanziku-1
 163     ideograph-hanziku-2
 164     ideograph-hanziku-3
 165     ideograph-hanziku-4
 166     ideograph-hanziku-5
 167     ideograph-hanziku-6
 168     ideograph-hanziku-7
 169     ideograph-hanziku-8
 170     ideograph-hanziku-9
 171     ideograph-hanziku-10
 172     ideograph-hanziku-11
 173     ideograph-hanziku-12
 174     =>>jis-x0208
 175     =>>jis-x0213-1
 176     =>>jis-x0213-1@2000
 177     =>>jis-x0213-1@2004
 178     =>>jis-x0213-2
 179     =>>jis-x0208@1978
 180     =>>hanyo-denshi/ft
 181     =>>hanyo-denshi/ks
 182     =>>gt
 183     =>jis-x0208@usual
 184     =>jis-x0208
 185     =>jis-x0208@1997
 186     =>jis-x0213-1
 187     =>jis-x0213-1@2000
 188     =>jis-x0213-1@2004
 189     =>jis-x0213-2@usual
 190     =>jis-x0213-2
 191     ==>ucs@bucs
 192     =>ucs@iso
 193     =>ucs@unicode
 194     =>ucs@jis
 195     =>ucs@JP
 196     =>ucs@cns
 197     =>ucs@ks
 198     =>>ucs@iso
 199     =>>ucs@unicode
 200     =>>ucs@jis
 201     =>>ucs@cns
 202     =>>>ucs@iso
 203     =>>>ucs@unicode
 204     =ucs@iso
 205     =ucs@unicode
 206     =>>big5-cdp
 207     =>>gt-k
 208     =>gt
 209     =>big5-cdp
 210     =>daikanwa
 211     =big5
 212     =big5-eten
 213     =>gt-k
 214     =zinbun-oracle
 215     =>zinbun-oracle
 216     =ruimoku-v6
 217     =>>ruimoku-v6
 218     =jef-china3
 219     =shinjigen))
 220
 221
 222 ;;; @ char-db formatters
 223 ;;;
 224
 225 (defun char-db-make-char-spec (char)
 226   (let (ret char-spec)
 227     (cond ((characterp char)
 228            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 229                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 230                   (setq char-spec (list (cons '=ucs ret)))
 231                   (cond ((setq ret (get-char-attribute char 'name))
 232                          (setq char-spec (cons (cons 'name ret) char-spec))
 233                          )
 234                         ((setq ret (get-char-attribute char 'name*))
 235                          (setq char-spec (cons (cons 'name* ret) char-spec))
 236                          ))
 237                   )
 238                  ((setq ret
 239                         (catch 'tag
 240                           (let ((rest char-db-coded-charset-priority-list)
 241                                 ccs)
 242                             (while rest
 243                               (setq ccs (charset-name
 244                                          (find-charset (car rest))))
 245                               (if (setq ret
 246                                         (encode-char char ccs
 247                                                      'defined-only))
 248                                   (throw 'tag (cons ccs ret)))
 249                               (setq rest (cdr rest))))))
 250                   (setq char-spec (list ret))
 251                   (dolist (ccs (delq (car ret) (charset-list)))
 252                     (if (and (or (charset-iso-final-char ccs)
 253                                  (memq ccs
 254                                        '(=daikanwa
 255                                          =daikanwa@rev2
 256                                          ;; =gt-k
 257                                          =jis-x0208@1997
 258                                          ))
 259                                  (string-match "=ucs@" (symbol-name ccs)))
 260                              (setq ccs (charset-name ccs))
 261                              (null (assq ccs char-spec))
 262                              (setq ret (encode-char char ccs 'defined-only)))
 263                         (setq char-spec (cons (cons ccs ret) char-spec))))
 264                   (if (null char-spec)
 265                       (setq char-spec (split-char char)))
 266                   (cond ((setq ret (get-char-attribute char 'name))
 267                          (setq char-spec (cons (cons 'name ret) char-spec))
 268                          )
 269                         ((setq ret (get-char-attribute char 'name*))
 270                          (setq char-spec (cons (cons 'name* ret) char-spec))
 271                          ))
 272                   )
 273                  ((setq ret (get-char-attribute
 274                              char 'ideographic-combination))
 275                   (setq char-spec
 276                         (cons (cons 'ideographic-combination ret)
 277                               char-spec))
 278                   ))
 279            char-spec)
 280           ((consp char)
 281            char))))
 282
 283 (defun char-db-insert-char-spec (char &optional readable column
 284                                       required-features)
 285   (unless column
 286     (setq column (current-column)))
 287   (let (char-spec temp-char)
 288     (setq char-spec (char-db-make-char-spec char))
 289     (unless (or (characterp char) ; char
 290                 (condition-case nil
 291                     (setq char (find-char char-spec))
 292                   (error nil)))
 293       ;; define temporary character
 294       ;;   Current implementation is dirty.
 295       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 296                                          char-spec)))
 297       (remove-char-attribute temp-char 'ideograph-daikanwa)
 298       (setq char temp-char))
 299     (insert-char-attributes char
 300                             readable
 301                             (union (mapcar #'car char-spec)
 302                                    required-features))
 303     (when temp-char
 304       ;; undefine temporary character
 305       ;;   Current implementation is dirty.
 306       (setq char-spec (char-attribute-alist temp-char))
 307       (while char-spec
 308         (remove-char-attribute temp-char (car (car char-spec)))
 309         (setq char-spec (cdr char-spec))))))
 310
 311 (defun char-db-insert-alist (alist &optional readable column)
 312   (unless column
 313     (setq column (current-column)))
 314   (let ((line-breaking
 315          (concat "\n" (make-string (1+ column) ?\ )))
 316         name value
 317         ret al ; cal
 318         key
 319         lbs cell rest separator)
 320     (insert "(")
 321     (while alist
 322       (setq name (car (car alist))
 323             value (cdr (car alist)))
 324       (cond ((eq name 'char)
 325              (insert "(char . ")
 326              (if (setq ret (condition-case nil
 327                                (find-char value)
 328                              (error nil)))
 329                  (progn
 330                    (setq al nil
 331                          ;; cal nil
 332                          )
 333                    (while value
 334                      (setq key (car (car value)))
 335                      ;; (if (find-charset key)
 336                      ;;     (setq cal (cons key cal))
 337                      (setq al (cons key al))
 338                      ;; )
 339                      (setq value (cdr value)))
 340                    (insert-char-attributes ret
 341                                            readable
 342                                            (or al 'none) ; cal
 343                                            ))
 344                (insert (prin1-to-string value)))
 345              (insert ")")
 346              (insert line-breaking))
 347             ((consp value)
 348              (insert (format "(%-18s " name))
 349              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 350              (while (consp value)
 351                (setq cell (car value))
 352                (if (and (consp cell)
 353                         (consp (car cell))
 354                         (setq ret (condition-case nil
 355                                       (find-char cell)
 356                                     (error nil)))
 357                         )
 358                    (progn
 359                      (setq rest cell
 360                            al nil
 361                            ;; cal nil
 362                            )
 363                      (while rest
 364                        (setq key (car (car rest)))
 365                        ;; (if (find-charset key)
 366                        ;;     (setq cal (cons key cal))
 367                        (setq al (cons key al))
 368                        ;; )
 369                        (setq rest (cdr rest)))
 370                      (if separator
 371                          (insert lbs))
 372                      (insert-char-attributes ret
 373                                              readable
 374                                              al ; cal
 375                                              )
 376                      (setq separator lbs))
 377                  (if separator
 378                      (insert separator))
 379                  (insert (prin1-to-string cell))
 380                  (setq separator " "))
 381                (setq value (cdr value)))
 382              (insert ")")
 383              (insert line-breaking))
 384             (t
 385              (insert (format "(%-18s . %S)%s"
 386                              name value
 387                              line-breaking))))
 388       (setq alist (cdr alist))))
 389   (insert ")"))
 390
 391 (defun char-db-insert-char-reference (plist &optional readable column)
 392   (unless column
 393     (setq column (current-column)))
 394   (let ((line-breaking
 395          (concat "\n" (make-string (1+ column) ?\ )))
 396         (separator "")
 397         name value)
 398     (insert "(")
 399     (while plist
 400       (setq name (pop plist))
 401       (setq value (pop plist))
 402       (cond ((eq name :char)
 403              (insert separator)
 404              (insert ":char\t")
 405              (cond ((numberp value)
 406                     (setq value (decode-char '=ucs value)))
 407                    ;; ((consp value)
 408                    ;;  (setq value (or (find-char value)
 409                    ;;                  value)))
 410                    )
 411              (char-db-insert-char-spec value readable)
 412              (insert line-breaking)
 413              (setq separator ""))
 414             ((eq name :radical)
 415              (insert (format "%s%s\t%d ; %c%s"
 416                              separator
 417                              name value
 418                              (ideographic-radical value)
 419                              line-breaking))
 420              (setq separator ""))
 421             (t
 422              (insert (format "%s%s\t%S" separator name value))
 423              (setq separator line-breaking)))
 424       ))
 425   (insert ")"))
 426
 427 (defun char-db-decode-isolated-char (ccs code-point)
 428   (let (ret)
 429     (setq ret
 430           (cond ((eq ccs 'arabic-iso8859-6)
 431                  (decode-char ccs code-point))
 432                 ((and (memq ccs '(=gt-pj-1
 433                                   =gt-pj-2
 434                                   =gt-pj-3
 435                                   =gt-pj-4
 436                                   =gt-pj-5
 437                                   =gt-pj-6
 438                                   =gt-pj-7
 439                                   =gt-pj-8
 440                                   =gt-pj-9
 441                                   =gt-pj-10
 442                                   =gt-pj-11))
 443                       (setq ret (decode-char ccs code-point))
 444                       (setq ret (encode-char ret '=gt 'defined-only)))
 445                  (decode-builtin-char '=gt ret))
 446                 (t
 447                  (decode-builtin-char ccs code-point))))
 448     (cond ((and (<= 0 (char-int ret))
 449                 (<= (char-int ret) #x1F))
 450            (decode-char '=ucs (+ #x2400 (char-int ret))))
 451           ((= (char-int ret) #x7F)
 452            ?\u2421)
 453           (t ret))))
 454
 455 (defvar char-db-convert-obsolete-format t)
 456
 457 (defun char-db-insert-ccs-feature (name value line-breaking)
 458   (insert
 459    (format
 460     (cond ((memq name '(=shinjigen
 461                         =shinjigen@1ed
 462                         =shinjigen@rev =shinjigen/+p@rev
 463                         =daikanwa/ho))
 464            "(%-18s .  %04d)\t; %c")
 465           ((eq name '=shinjigen@1ed/24pr)
 466            "(%-18s . %04d)\t; %c")
 467           ((or (memq name '(=daikanwa
 468                             =daikanwa@rev1 =daikanwa@rev2
 469                             =daikanwa/+p =daikanwa/+2p
 470                             =>>daikanwa =>daikanwa
 471                             =gt =>>gt =>gt =gt-k =>>gt-k =>gt-k =cbeta
 472                             =zinbun-oracle =>zinbun-oracle))
 473                (string-match "^=adobe-" (symbol-name name)))
 474            "(%-18s . %05d)\t; %c")
 475           ((memq name '(=hanyo-denshi/ks =>>hanyo-denshi/ks mojikyo))
 476            "(%-18s . %06d)\t; %c")
 477           ((>= (charset-dimension name) 2)
 478            "(%-18s . #x%04X)\t; %c")
 479           (t
 480            "(%-18s . #x%02X)\t; %c"))
 481     name
 482     (if (= (charset-iso-graphic-plane name) 1)
 483         (logior value
 484                 (cond ((= (charset-dimension name) 1)
 485                        #x80)
 486                       ((= (charset-dimension name) 2)
 487                        #x8080)
 488                       ((= (charset-dimension name) 3)
 489                        #x808080)
 490                       (t 0)))
 491       value)
 492     (char-db-decode-isolated-char name value)))
 493   (if (and (= (charset-chars name) 94)
 494            (= (charset-dimension name) 2))
 495       (insert (format " [%02d-%02d]"
 496                       (- (lsh value -8) 32)
 497                       (- (logand value 255) 32))))
 498   (insert line-breaking))
 499
 500 (defun char-db-insert-relation-feature (char name value line-breaking
 501                                              ccss readable)
 502   (insert (format "(%-18s%s " name line-breaking))
 503   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 504         separator cell sources required-features
 505         ret)
 506     (while (consp value)
 507       (setq cell (car value))
 508       (if (integerp cell)
 509           (setq cell (decode-char '=ucs cell)))
 510       (cond
 511        ((eq name '->subsumptive)
 512         (when (or (not (some (lambda (atr)
 513                                (get-char-attribute cell atr))
 514                              char-db-ignored-attributes))
 515                   (some (lambda (ccs)
 516                           (encode-char cell ccs 'defined-only))
 517                         ccss))
 518           (if separator
 519               (insert lbs))
 520           (let ((char-db-ignored-attributes
 521                  (cons '<-subsumptive
 522                        char-db-ignored-attributes)))
 523             (insert-char-attributes cell readable))
 524           (setq separator lbs))
 525         )
 526        ((characterp cell)
 527         (setq sources
 528               (get-char-attribute
 529                char (intern (format "%s*sources" name))))
 530         (setq required-features nil)
 531         (dolist (source sources)
 532           (cond
 533            ((memq source '(JP
 534                            JP/Jouyou
 535                            shinjigen shinjigen@1ed shinjigen@rev))
 536             (setq required-features
 537                   (union required-features
 538                          '(=jis-x0208
 539                            =jis-x0208@1990
 540                            =jis-x0213-1@2000
 541                            =jis-x0213-1@2004
 542                            =jis-x0213-2
 543                            =jis-x0212
 544                            =jis-x0208@1983
 545                            =jis-x0208@1978
 546                            =shinjigen))))
 547            ((eq source 'CN)
 548             (setq required-features
 549                   (union required-features
 550                          '(=gb2312
 551                            =gb12345
 552                            =iso-ir165)))))
 553           (cond
 554            ((find-charset (setq ret (intern (format "=%s" source))))
 555             (setq required-features
 556                   (cons ret required-features)))
 557            (t (setq required-features
 558                     (cons source required-features)))))
 559         (cond ((string-match "@JP" (symbol-name name))
 560                (setq required-features
 561                      (union required-features
 562                             '(=jis-x0208
 563                               =jis-x0208@1990
 564                               =jis-x0213-1-2000
 565                               =jis-x0213-2-2000
 566                               =jis-x0212
 567                               =jis-x0208@1983
 568                               =jis-x0208@1978))))
 569               ((string-match "@CN" (symbol-name name))
 570                (setq required-features
 571                      (union required-features
 572                             '(=gb2312
 573                               =gb12345
 574                               =iso-ir165)))))
 575         (if separator
 576             (insert lbs))
 577         (if readable
 578             (insert (format "%S" cell))
 579           (char-db-insert-char-spec cell readable
 580                                     nil
 581                                     required-features))
 582         (setq separator lbs))
 583        ((consp cell)
 584         (if separator
 585             (insert lbs))
 586         (if (consp (car cell))
 587             (char-db-insert-char-spec cell readable)
 588           (char-db-insert-char-reference cell readable))
 589         (setq separator lbs))
 590        (t
 591         (if separator
 592             (insert separator))
 593         (insert (prin1-to-string cell))
 594         (setq separator " ")))
 595       (setq value (cdr value)))
 596     (insert ")")
 597     (insert line-breaking)))
 598
 599 (defun insert-char-attributes (char &optional readable attributes column)
 600   (unless column
 601     (setq column (current-column)))
 602   (let (name value ; has-long-ccs-name
 603         rest
 604         radical strokes
 605         (line-breaking
 606          (concat "\n" (make-string (1+ column) ?\ )))
 607         lbs cell separator ret
 608         key al cal
 609         dest-ccss ; sources required-features
 610         ccss)
 611     (let (atr-d)
 612       (setq attributes
 613             (sort (if attributes
 614                       (if (consp attributes)
 615                           (progn
 616                             (dolist (name attributes)
 617                               (unless (memq name char-db-ignored-attributes)
 618                                 (if (find-charset name)
 619                                     (push name ccss))
 620                                 (push name atr-d)))
 621                             atr-d))
 622                     (dolist (name (char-attribute-list))
 623                       (unless (memq name char-db-ignored-attributes)
 624                         (if (find-charset name)
 625                             (push name ccss))
 626                         (push name atr-d)))
 627                     atr-d)
 628                   #'char-attribute-name<)))
 629     (insert "(")
 630     (when (memq '<-subsumptive attributes)
 631       (when readable
 632         (when (setq value (get-char-attribute char '<-subsumptive))
 633           (char-db-insert-relation-feature char '<-subsumptive value
 634                                            line-breaking
 635                                            ccss readable)))
 636       (setq attributes (delq '<-subsumptive attributes)))
 637     (when (and (memq '<-denotational attributes)
 638                (setq value (get-char-attribute char '<-denotational)))
 639       (char-db-insert-relation-feature char '<-denotational value
 640                                        line-breaking
 641                                        ccss readable)
 642       (setq attributes (delq '<-denotational attributes)))
 643     (when (and (memq 'name attributes)
 644                (setq value (get-char-attribute char 'name)))
 645       (insert (format
 646                (if (> (+ (current-column) (length value)) 48)
 647                    "(name . %S)%s"
 648                  "(name               . %S)%s")
 649                value line-breaking))
 650       (setq attributes (delq 'name attributes))
 651       )
 652     (when (and (memq 'name* attributes)
 653                (setq value (get-char-attribute char 'name*)))
 654       (insert (format
 655                (if (> (+ (current-column) (length value)) 48)
 656                    "(name* . %S)%s"
 657                  "(name*              . %S)%s")
 658                value line-breaking))
 659       (setq attributes (delq 'name* attributes))
 660       )
 661     (when (and (memq 'script attributes)
 662                (setq value (get-char-attribute char 'script)))
 663       (insert (format "(script\t\t%s)%s"
 664                       (mapconcat (function prin1-to-string)
 665                                  value " ")
 666                       line-breaking))
 667       (setq attributes (delq 'script attributes))
 668       )
 669     (dolist (name '(=>ucs =>ucs*))
 670       (when (and (memq name attributes)
 671                  (setq value (get-char-attribute char name)))
 672         (insert (format "(%-18s . #x%04X)\t; %c%s"
 673                         name value (decode-char '=ucs value)
 674                         line-breaking))
 675         (setq attributes (delq name attributes))))
 676     (dolist (name '(=>ucs@gb =>ucs@big5))
 677       (when (and (memq name attributes)
 678                  (setq value (get-char-attribute char name)))
 679         (insert (format "(%-18s . #x%04X)\t; %c%s"
 680                         name value
 681                         (decode-char (intern
 682                                       (concat "="
 683                                               (substring
 684                                                (symbol-name name) 2)))
 685                                      value)
 686                         line-breaking))
 687         (setq attributes (delq name attributes))
 688         ))
 689     ;; (dolist (name '(=>daikanwa))
 690     ;;   (when (and (memq name attributes)
 691     ;;              (setq value (get-char-attribute char name)))
 692     ;;     (insert
 693     ;;      (if (integerp value)
 694     ;;          (format "(%-18s . %05d)\t; %c%s"
 695     ;;                  name value (decode-char '=daikanwa value)
 696     ;;                  line-breaking)
 697     ;;        (format "(%-18s %s)\t; %c%s"
 698     ;;                name
 699     ;;                (mapconcat (function prin1-to-string)
 700     ;;                           value " ")
 701     ;;                (char-representative-of-daikanwa char)
 702     ;;                line-breaking)))
 703     ;;     (setq attributes (delq name attributes))))
 704     (when (and (memq 'general-category attributes)
 705                (setq value (get-char-attribute char 'general-category)))
 706       (insert (format
 707                "(general-category\t%s) ; %s%s"
 708                (mapconcat (lambda (cell)
 709                             (format "%S" cell))
 710                           value " ")
 711                (cond ((rassoc value unidata-normative-category-alist)
 712                       "Normative Category")
 713                      ((rassoc value unidata-informative-category-alist)
 714                       "Informative Category")
 715                      (t
 716                       "Unknown Category"))
 717                line-breaking))
 718       (setq attributes (delq 'general-category attributes))
 719       )
 720     (when (and (memq 'bidi-category attributes)
 721                (setq value (get-char-attribute char 'bidi-category)))
 722       (insert (format "(bidi-category\t. %S)%s"
 723                       value
 724                       line-breaking))
 725       (setq attributes (delq 'bidi-category attributes))
 726       )
 727     (unless (or (not (memq 'mirrored attributes))
 728                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 729                     'empty))
 730       (insert (format "(mirrored\t\t. %S)%s"
 731                       value
 732                       line-breaking))
 733       (setq attributes (delq 'mirrored attributes))
 734       )
 735     (cond
 736      ((and (memq 'decimal-digit-value attributes)
 737            (setq value (get-char-attribute char 'decimal-digit-value)))
 738       (insert (format "(decimal-digit-value . %S)%s"
 739                       value
 740                       line-breaking))
 741       (setq attributes (delq 'decimal-digit-value attributes))
 742       (when (and (memq 'digit-value attributes)
 743                  (setq value (get-char-attribute char 'digit-value)))
 744         (insert (format "(digit-value\t . %S)%s"
 745                         value
 746                         line-breaking))
 747         (setq attributes (delq 'digit-value attributes))
 748         )
 749       (when (and (memq 'numeric-value attributes)
 750                  (setq value (get-char-attribute char 'numeric-value)))
 751         (insert (format "(numeric-value\t . %S)%s"
 752                         value
 753                         line-breaking))
 754         (setq attributes (delq 'numeric-value attributes))
 755         )
 756       )
 757      (t
 758       (when (and (memq 'digit-value attributes)
 759                  (setq value (get-char-attribute char 'digit-value)))
 760         (insert (format "(digit-value\t. %S)%s"
 761                         value
 762                         line-breaking))
 763         (setq attributes (delq 'digit-value attributes))
 764         )
 765       (when (and (memq 'numeric-value attributes)
 766                  (setq value (get-char-attribute char 'numeric-value)))
 767         (insert (format "(numeric-value\t. %S)%s"
 768                         value
 769                         line-breaking))
 770         (setq attributes (delq 'numeric-value attributes))
 771         )))
 772     (when (and (memq 'iso-10646-comment attributes)
 773                (setq value (get-char-attribute char 'iso-10646-comment)))
 774       (insert (format "(iso-10646-comment\t. %S)%s"
 775                       value
 776                       line-breaking))
 777       (setq attributes (delq 'iso-10646-comment attributes))
 778       )
 779     (when (and (memq 'morohashi-daikanwa attributes)
 780                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 781       (insert (format "(morohashi-daikanwa\t%s)%s"
 782                       (mapconcat (function prin1-to-string) value " ")
 783                       line-breaking))
 784       (setq attributes (delq 'morohashi-daikanwa attributes))
 785       )
 786     (setq radical nil
 787           strokes nil)
 788     (when (and (memq 'ideographic-radical attributes)
 789                (setq value (get-char-attribute char 'ideographic-radical)))
 790       (setq radical value)
 791       (insert (format "(ideographic-radical . %S)\t; %c%s"
 792                       radical
 793                       (ideographic-radical radical)
 794                       line-breaking))
 795       (setq attributes (delq 'ideographic-radical attributes))
 796       )
 797     (when (and (memq 'shuowen-radical attributes)
 798                (setq value (get-char-attribute char 'shuowen-radical)))
 799       (insert (format "(shuowen-radical\t. %S)\t; %c%s"
 800                       value
 801                       (shuowen-radical value)
 802                       line-breaking))
 803       (setq attributes (delq 'shuowen-radical attributes))
 804       )
 805     (let (key)
 806       (dolist (domain
 807                (append
 808                 char-db-feature-domains
 809                 (let (dest domain)
 810                   (dolist (feature (char-attribute-list))
 811                     (setq feature (symbol-name feature))
 812                     (when (string-match
 813                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
 814                            feature)
 815                       (setq domain (intern (match-string 2 feature)))
 816                      (unless (memq domain dest)
 817                        (setq dest (cons domain dest)))))
 818                   (sort dest #'string<))))
 819         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
 820         (when (and (memq key attributes)
 821                    (setq value (get-char-attribute char key)))
 822           (setq radical value)
 823           (insert (format "(%s . %S)\t; %c%s"
 824                           key
 825                           radical
 826                           (ideographic-radical radical)
 827                           line-breaking))
 828           (setq attributes (delq key attributes))
 829           )
 830         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
 831         (when (and (memq key attributes)
 832                    (setq value (get-char-attribute char key)))
 833           (setq strokes value)
 834           (insert (format "(%s . %S)%s"
 835                           key
 836                           strokes
 837                           line-breaking))
 838           (setq attributes (delq key attributes))
 839           )
 840         (setq key (intern (format "%s@%s" 'total-strokes domain)))
 841         (when (and (memq key attributes)
 842                    (setq value (get-char-attribute char key)))
 843           (insert (format "(%s       . %S)%s"
 844                           key
 845                           value
 846                           line-breaking))
 847           (setq attributes (delq key attributes))
 848           )
 849         (dolist (feature '(ideographic-radical
 850                            ideographic-strokes
 851                            total-strokes))
 852           (setq key (intern (format "%s@%s*sources" feature domain)))
 853           (when (and (memq key attributes)
 854                      (setq value (get-char-attribute char key)))
 855             (insert (format "(%s%s" key line-breaking))
 856             (dolist (cell value)
 857               (insert (format " %s" cell)))
 858             (insert ")")
 859             (insert line-breaking)
 860             (setq attributes (delq key attributes))
 861             ))
 862         ))
 863     (when (and (memq 'ideographic-strokes attributes)
 864                (setq value (get-char-attribute char 'ideographic-strokes)))
 865       (setq strokes value)
 866       (insert (format "(ideographic-strokes . %S)%s"
 867                       strokes
 868                       line-breaking))
 869       (setq attributes (delq 'ideographic-strokes attributes))
 870       )
 871     (when (and (memq 'kangxi-radical attributes)
 872                (setq value (get-char-attribute char 'kangxi-radical)))
 873       (unless (eq value radical)
 874         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 875                         value
 876                         (ideographic-radical value)
 877                         line-breaking))
 878         (or radical
 879             (setq radical value)))
 880       (setq attributes (delq 'kangxi-radical attributes))
 881       )
 882     (when (and (memq 'kangxi-strokes attributes)
 883                (setq value (get-char-attribute char 'kangxi-strokes)))
 884       (unless (eq value strokes)
 885         (insert (format "(kangxi-strokes\t . %S)%s"
 886                         value
 887                         line-breaking))
 888         (or strokes
 889             (setq strokes value)))
 890       (setq attributes (delq 'kangxi-strokes attributes))
 891       )
 892     (when (and (memq 'japanese-radical attributes)
 893                (setq value (get-char-attribute char 'japanese-radical)))
 894       (unless (eq value radical)
 895         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 896                         value
 897                         (ideographic-radical value)
 898                         line-breaking))
 899         (or radical
 900             (setq radical value)))
 901       (setq attributes (delq 'japanese-radical attributes))
 902       )
 903     (when (and (memq 'japanese-strokes attributes)
 904                (setq value (get-char-attribute char 'japanese-strokes)))
 905       (unless (eq value strokes)
 906         (insert (format "(japanese-strokes\t . %S)%s"
 907                         value
 908                         line-breaking))
 909         (or strokes
 910             (setq strokes value)))
 911       (setq attributes (delq 'japanese-strokes attributes))
 912       )
 913     (when (and (memq 'cns-radical attributes)
 914                (setq value (get-char-attribute char 'cns-radical)))
 915       (insert (format "(cns-radical\t . %S)\t; %c%s"
 916                       value
 917                       (ideographic-radical value)
 918                       line-breaking))
 919       (setq attributes (delq 'cns-radical attributes))
 920       )
 921     (when (and (memq 'cns-strokes attributes)
 922                (setq value (get-char-attribute char 'cns-strokes)))
 923       (unless (eq value strokes)
 924         (insert (format "(cns-strokes\t . %S)%s"
 925                         value
 926                         line-breaking))
 927         (or strokes
 928             (setq strokes value)))
 929       (setq attributes (delq 'cns-strokes attributes))
 930       )
 931     (when (and (memq 'shinjigen-1-radical attributes)
 932                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 933       (unless (eq value radical)
 934         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 935                         value
 936                         (ideographic-radical value)
 937                         line-breaking))
 938         (or radical
 939             (setq radical value)))
 940       (setq attributes (delq 'shinjigen-1-radical attributes))
 941       )
 942     (when (and (memq 'ideographic- attributes)
 943                (setq value (get-char-attribute char 'ideographic-)))
 944       (insert "(ideographic-       ")
 945       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 946             separator nil)
 947       (while (consp value)
 948         (setq cell (car value))
 949         (if (integerp cell)
 950             (setq cell (decode-char '=ucs cell)))
 951         (cond ((characterp cell)
 952                (if separator
 953                    (insert lbs))
 954                (if readable
 955                    (insert (format "%S" cell))
 956                  (char-db-insert-char-spec cell readable))
 957                (setq separator lbs))
 958               ((consp cell)
 959                (if separator
 960                    (insert lbs))
 961                (if (consp (car cell))
 962                    (char-db-insert-char-spec cell readable)
 963                  (char-db-insert-char-reference cell readable))
 964                (setq separator lbs))
 965               (t
 966                (if separator
 967                    (insert separator))
 968                (insert (prin1-to-string cell))
 969                (setq separator " ")))
 970         (setq value (cdr value)))
 971       (insert ")")
 972       (insert line-breaking)
 973       (setq attributes (delq 'ideographic- attributes)))
 974     (when (and (memq 'total-strokes attributes)
 975                (setq value (get-char-attribute char 'total-strokes)))
 976       (insert (format "(total-strokes       . %S)%s"
 977                       value
 978                       line-breaking))
 979       (setq attributes (delq 'total-strokes attributes))
 980       )
 981     (when (and (memq '->ideograph attributes)
 982                (setq value (get-char-attribute char '->ideograph)))
 983       (insert (format "(->ideograph\t%s)%s"
 984                       (mapconcat (lambda (code)
 985                                    (cond ((symbolp code)
 986                                           (symbol-name code))
 987                                          ((integerp code)
 988                                           (format "#x%04X" code))
 989                                          (t
 990                                           (format "%s %S"
 991                                                   line-breaking code))))
 992                                  value " ")
 993                       line-breaking))
 994       (setq attributes (delq '->ideograph attributes))
 995       )
 996     ;; (when (and (memq '->decomposition attributes)
 997     ;;            (setq value (get-char-attribute char '->decomposition)))
 998     ;;   (insert (format "(->decomposition\t%s)%s"
 999     ;;                   (mapconcat (lambda (code)
1000     ;;                                (cond ((symbolp code)
1001     ;;                                       (symbol-name code))
1002     ;;                                      ((characterp code)
1003     ;;                                       (if readable
1004     ;;                                           (format "%S" code)
1005     ;;                                         (format "#x%04X"
1006     ;;                                                 (char-int code))
1007     ;;                                         ))
1008     ;;                                      ((integerp code)
1009     ;;                                       (format "#x%04X" code))
1010     ;;                                      (t
1011     ;;                                       (format "%s%S" line-breaking code))))
1012     ;;                              value " ")
1013     ;;                   line-breaking))
1014     ;;   (setq attributes (delq '->decomposition attributes))
1015     ;;   )
1016     (if (equal (get-char-attribute char '->titlecase)
1017                (get-char-attribute char '->uppercase))
1018         (setq attributes (delq '->titlecase attributes)))
1019     (when (and (memq '->mojikyo attributes)
1020                (setq value (get-char-attribute char '->mojikyo)))
1021       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
1022                       value (decode-char 'mojikyo value)
1023                       line-breaking))
1024       (setq attributes (delq '->mojikyo attributes))
1025       )
1026     (when (and (memq 'hanyu-dazidian-vol attributes)
1027                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
1028       (insert (format "(hanyu-dazidian-vol  . %d)%s"
1029                       value line-breaking))
1030       (setq attributes (delq 'hanyu-dazidian-vol attributes))
1031       )
1032     (when (and (memq 'hanyu-dazidian-page attributes)
1033                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
1034       (insert (format "(hanyu-dazidian-page . %d)%s"
1035                       value line-breaking))
1036       (setq attributes (delq 'hanyu-dazidian-page attributes))
1037       )
1038     (when (and (memq 'hanyu-dazidian-char attributes)
1039                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
1040       (insert (format "(hanyu-dazidian-char . %d)%s"
1041                       value line-breaking))
1042       (setq attributes (delq 'hanyu-dazidian-char attributes))
1043       )
1044     (unless readable
1045       (dolist (ignored '(composition
1046                          ->denotational <-subsumptive ->ucs-unified
1047                          ->ideographic-component-forms))
1048         (setq attributes (delq ignored attributes))))
1049     (while attributes
1050       (setq name (car attributes))
1051       (if (setq value (get-char-attribute char name))
1052           (cond ((setq ret (find-charset name))
1053                  (setq name (charset-name ret))
1054                  (if (and (not (memq name dest-ccss))
1055                           (prog1
1056                               (setq value (get-char-attribute char name))
1057                             (setq dest-ccss (cons name dest-ccss))))
1058                      (char-db-insert-ccs-feature name value line-breaking))
1059                  )
1060                 ((string-match "^=>ucs@" (symbol-name name))
1061                  (insert (format "(%-18s . #x%04X)\t; %c%s"
1062                                  name value (decode-char '=ucs value)
1063                                  line-breaking))
1064                  )
1065                 ((eq name 'jisx0208-1978/4X)
1066                  (insert (format "(%-18s . #x%04X)%s"
1067                                  name value
1068                                  line-breaking))
1069                  )
1070                 ((and
1071                   (not readable)
1072                   (not (eq name '->subsumptive))
1073                   (not (eq name '->uppercase))
1074                   (not (eq name '->lowercase))
1075                   (not (eq name '->titlecase))
1076                   (not (eq name '->canonical))
1077                   (not (eq name '->Bopomofo))
1078                   (not (eq name '->mistakable))
1079                   (not (eq name '->ideographic-variants))
1080                   (null (get-char-attribute
1081                          char (intern (format "%s*sources" name))))
1082                   (not (string-match "\\*sources$" (symbol-name name)))
1083                   (null (get-char-attribute
1084                          char (intern (format "%s*note" name))))
1085                   (not (string-match "\\*note$" (symbol-name name)))
1086                   (or (eq name '<-identical)
1087                       (eq name '<-uppercase)
1088                       (eq name '<-lowercase)
1089                       (eq name '<-titlecase)
1090                       (eq name '<-canonical)
1091                       (eq name '<-ideographic-variants)
1092                       ;; (eq name '<-synonyms)
1093                       (string-match "^<-synonyms" (symbol-name name))
1094                       (eq name '<-mistakable)
1095                       (when (string-match "^->" (symbol-name name))
1096                         (cond
1097                          ((string-match "^->fullwidth" (symbol-name name))
1098                           (not (and (consp value)
1099                                     (characterp (car value))
1100                                     (encode-char
1101                                      (car value) '=ucs 'defined-only)))
1102                           )
1103                          (t)))
1104                       ))
1105                  )
1106                 ((or (eq name 'ideographic-structure)
1107                      (eq name 'ideographic-combination)
1108                      (eq name 'ideographic-)
1109                      (eq name '=decomposition)
1110                      (string-match "^=>*decomposition\\(@[^*]+\\)?$"
1111                                    (symbol-name name))
1112                      (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
1113                      (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
1114                                    (symbol-name name))
1115                      )
1116                  (char-db-insert-relation-feature char name value
1117                                                   line-breaking
1118                                                   ccss readable))
1119                 ((memq name '(ideograph=
1120                               original-ideograph-of
1121                               ancient-ideograph-of
1122                               vulgar-ideograph-of
1123                               wrong-ideograph-of
1124                               ;; simplified-ideograph-of
1125                               ideographic-variants
1126                               ;; ideographic-different-form-of
1127                               ))
1128                  (insert (format "(%-18s%s " name line-breaking))
1129                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1130                        separator nil)
1131                  (while (consp value)
1132                    (setq cell (car value))
1133                    (if (and (consp cell)
1134                             (consp (car cell)))
1135                        (progn
1136                          (if separator
1137                              (insert lbs))
1138                          (char-db-insert-alist cell readable)
1139                          (setq separator lbs))
1140                      (if separator
1141                          (insert separator))
1142                      (insert (prin1-to-string cell))
1143                      (setq separator " "))
1144                    (setq value (cdr value)))
1145                  (insert ")")
1146                  (insert line-breaking))
1147                 ((consp value)
1148                  (insert (format "(%-18s " name))
1149                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1150                        separator nil)
1151                  (while (consp value)
1152                    (setq cell (car value))
1153                    (if (and (consp cell)
1154                             (consp (car cell))
1155                             (setq ret (condition-case nil
1156                                           (find-char cell)
1157                                         (error nil))))
1158                        (progn
1159                          (setq rest cell
1160                                al nil
1161                                cal nil)
1162                          (while rest
1163                            (setq key (car (car rest)))
1164                            (if (find-charset key)
1165                                (setq cal (cons key cal))
1166                              (setq al (cons key al)))
1167                            (setq rest (cdr rest)))
1168                          (if separator
1169                              (insert lbs))
1170                          (insert-char-attributes ret
1171                                                  readable
1172                                                  al cal)
1173                          (setq separator lbs))
1174                      (setq ret (prin1-to-string cell))
1175                      (if separator
1176                          (if (< (+ (current-column)
1177                                    (length ret)
1178                                    (length separator))
1179                                 76)
1180                              (insert separator)
1181                            (insert lbs)))
1182                      (insert ret)
1183                      (setq separator " "))
1184                    (setq value (cdr value)))
1185                  (insert ")")
1186                  (insert line-breaking))
1187                 (t
1188                  (insert (format "(%-18s" name))
1189                  (setq ret (prin1-to-string value))
1190                  (unless (< (+ (current-column)
1191                                (length ret)
1192                                3)
1193                             76)
1194                    (insert line-breaking))
1195                  (insert " . " ret ")" line-breaking)
1196                  ;; (insert (format "(%-18s . %S)%s"
1197                  ;;                 name value
1198                  ;;                 line-breaking))
1199                  )
1200                 ))
1201       (setq attributes (cdr attributes)))
1202     (insert ")")))
1203
1204 (defun insert-char-data (char &optional readable
1205                               attributes)
1206   (save-restriction
1207     (narrow-to-region (point)(point))
1208     (insert "(define-char
1209   '")
1210     (insert-char-attributes char readable attributes)
1211     (insert ")\n")
1212     (goto-char (point-min))
1213     (while (re-search-forward "[ \t]+$" nil t)
1214       (replace-match ""))
1215     ;; from tabify.
1216     (goto-char (point-min))
1217     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1218       (let ((column (current-column))
1219             (indent-tabs-mode t))
1220         (delete-region (match-beginning 0) (point))
1221         (indent-to column)))
1222     (goto-char (point-max))
1223     ;; (tabify (point-min)(point-max))
1224     ))
1225
1226 (defun insert-char-data-with-variant (char &optional printable
1227                                            no-ucs-unified
1228                                            script excluded-script)
1229   (insert-char-data char printable)
1230   (let ((variants (char-variants char))
1231         rest
1232         variant vs ret)
1233     (setq variants (sort variants #'<))
1234     (setq rest variants)
1235     (setq variants (cons char variants))
1236     (while rest
1237       (setq variant (car rest))
1238       (unless (get-char-attribute variant '<-subsumptive)
1239         (if (and (or (null script)
1240                      (null (setq vs (get-char-attribute variant 'script)))
1241                      (memq script vs))
1242                  (or (null excluded-script)
1243                      (null (setq vs (get-char-attribute variant 'script)))
1244                      (not (memq excluded-script vs))))
1245             (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1246               (insert-char-data variant printable)
1247               (if (setq ret (char-variants variant))
1248                   (while ret
1249                     (or (memq (car ret) variants)
1250                         ;; (get-char-attribute (car ret) '<-subsumptive)
1251                         (setq rest (nconc rest (list (car ret)))))
1252                     (setq ret (cdr ret)))))))
1253       (setq rest (cdr rest)))))
1254
1255 (defun insert-char-range-data (min max &optional script excluded-script)
1256   (let ((code min)
1257         char)
1258     (while (<= code max)
1259       (setq char (decode-char '=ucs code))
1260       (if (encode-char char '=ucs 'defined-only)
1261           (insert-char-data-with-variant char nil 'no-ucs-unified
1262                                          script excluded-script))
1263       (setq code (1+ code)))))
1264
1265 (defun write-char-range-data-to-file (min max file
1266                                           &optional script excluded-script)
1267   (let ((coding-system-for-write char-db-file-coding-system))
1268     (with-temp-buffer
1269       (insert (format ";; -*- coding: %s -*-\n"
1270                       char-db-file-coding-system))
1271       (insert-char-range-data min max script excluded-script)
1272       (write-region (point-min)(point-max) file))))
1273
1274 (defvar what-character-original-window-configuration)
1275
1276 ;;;###autoload
1277 (defun what-char-definition (char)
1278   (interactive (list (char-after)))
1279   (let ((buf (get-buffer-create "*Character Description*"))
1280         (the-buf (current-buffer))
1281         (win-conf (current-window-configuration)))
1282     (pop-to-buffer buf)
1283     (make-local-variable 'what-character-original-window-configuration)
1284     (setq what-character-original-window-configuration win-conf)
1285     (setq buffer-read-only nil)
1286     (erase-buffer)
1287     (condition-case err
1288         (progn
1289           (insert-char-data-with-variant char 'printable)
1290           (unless (char-attribute-alist char)
1291             (insert (format ";; = %c\n"
1292                             (let* ((rest (split-char char))
1293                                    (ccs (pop rest))
1294                                    (code (pop rest)))
1295                               (while rest
1296                                 (setq code (logior (lsh code 8)
1297                                                    (pop rest))))
1298                               (decode-char ccs code)))))
1299           ;; (char-db-update-comment)
1300           (set-buffer-modified-p nil)
1301           (view-mode the-buf (lambda (buf)
1302                                (set-window-configuration
1303                                 what-character-original-window-configuration)
1304                                ))
1305           (goto-char (point-min)))
1306       (error (progn
1307                (set-window-configuration
1308                 what-character-original-window-configuration)
1309                (signal (car err) (cdr err)))))))
1310
1311
1312 ;;; @ end
1313 ;;;
1314
1315 (provide 'char-db-util)
1316
1317 ;;; char-db-util.el ends here