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-x0208
 177     =>>jis-x0213-1
 178     =>>jis-x0213-1@2000
 179     =>>jis-x0213-1@2004
 180     =>>jis-x0213-2
 181     =>>jis-x0208@1978
 182     =>>hanyo-denshi/ft
 183     =>>hanyo-denshi/ks
 184     =>>gt
 185     =>jis-x0208@usual
 186     =>jis-x0208
 187     =>jis-x0208@1997
 188     =>jis-x0213-1
 189     =>jis-x0213-1@2000
 190     =>jis-x0213-1@2004
 191     =>jis-x0213-2@usual
 192     =>jis-x0213-2
 193     ==>ucs@bucs
 194     =>ucs@iso
 195     =>ucs@unicode
 196     =>ucs@jis
 197     =>ucs@JP
 198     =>ucs@cns
 199     =>ucs@ks
 200     =>>ucs@iso
 201     =>>ucs@unicode
 202     =>>ucs@jis
 203     =>>ucs@cns
 204     =>>>ucs@iso
 205     =>>>ucs@unicode
 206     =ucs@iso
 207     =ucs@unicode
 208     =>>big5-cdp
 209     =>>gt-k
 210     =>gt
 211     =>big5-cdp
 212     =>daikanwa
 213     =big5
 214     =big5-eten
 215     =>gt-k
 216     =zinbun-oracle
 217     =>zinbun-oracle
 218     =ruimoku-v6
 219     =>>ruimoku-v6
 220     =jef-china3
 221     =shinjigen))
 222
 223
 224 ;;; @ char-db formatters
 225 ;;;
 226
 227 (defun char-db-make-char-spec (char)
 228   (let (ret char-spec)
 229     (cond ((characterp char)
 230            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 231                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 232                   (setq char-spec (list (cons '=ucs ret)))
 233                   (cond ((setq ret (get-char-attribute char 'name))
 234                          (setq char-spec (cons (cons 'name ret) char-spec))
 235                          )
 236                         ((setq ret (get-char-attribute char 'name*))
 237                          (setq char-spec (cons (cons 'name* ret) char-spec))
 238                          ))
 239                   )
 240                  ((setq ret
 241                         (catch 'tag
 242                           (let ((rest char-db-coded-charset-priority-list)
 243                                 ccs)
 244                             (while rest
 245                               (setq ccs (charset-name
 246                                          (find-charset (car rest))))
 247                               (if (setq ret
 248                                         (encode-char char ccs
 249                                                      'defined-only))
 250                                   (throw 'tag (cons ccs ret)))
 251                               (setq rest (cdr rest))))))
 252                   (setq char-spec (list ret))
 253                   (dolist (ccs (delq (car ret) (charset-list)))
 254                     (if (and (or (charset-iso-final-char ccs)
 255                                  (memq ccs
 256                                        '(=daikanwa
 257                                          =daikanwa@rev2
 258                                          ;; =gt-k
 259                                          =jis-x0208@1997
 260                                          ))
 261                                  (string-match "=ucs@" (symbol-name ccs)))
 262                              (setq ccs (charset-name ccs))
 263                              (null (assq ccs char-spec))
 264                              (setq ret (encode-char char ccs 'defined-only)))
 265                         (setq char-spec (cons (cons ccs ret) char-spec))))
 266                   (if (null char-spec)
 267                       (setq char-spec (split-char char)))
 268                   (cond ((setq ret (get-char-attribute char 'name))
 269                          (setq char-spec (cons (cons 'name ret) char-spec))
 270                          )
 271                         ((setq ret (get-char-attribute char 'name*))
 272                          (setq char-spec (cons (cons 'name* ret) char-spec))
 273                          ))
 274                   )
 275                  ((setq ret (get-char-attribute
 276                              char 'ideographic-combination))
 277                   (setq char-spec
 278                         (cons (cons 'ideographic-combination ret)
 279                               char-spec))
 280                   ))
 281            char-spec)
 282           ((consp char)
 283            char))))
 284
 285 (defun char-db-insert-char-spec (char &optional readable column
 286                                       required-features)
 287   (unless column
 288     (setq column (current-column)))
 289   (let (char-spec temp-char)
 290     (setq char-spec (char-db-make-char-spec char))
 291     (unless (or (characterp char) ; char
 292                 (condition-case nil
 293                     (setq char (find-char char-spec))
 294                   (error nil)))
 295       ;; define temporary character
 296       ;;   Current implementation is dirty.
 297       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 298                                          char-spec)))
 299       (remove-char-attribute temp-char 'ideograph-daikanwa)
 300       (setq char temp-char))
 301     (insert-char-attributes char
 302                             readable
 303                             (union (mapcar #'car char-spec)
 304                                    required-features))
 305     (when temp-char
 306       ;; undefine temporary character
 307       ;;   Current implementation is dirty.
 308       (setq char-spec (char-attribute-alist temp-char))
 309       (while char-spec
 310         (remove-char-attribute temp-char (car (car char-spec)))
 311         (setq char-spec (cdr char-spec))))))
 312
 313 (defun char-db-insert-alist (alist &optional readable column)
 314   (unless column
 315     (setq column (current-column)))
 316   (let ((line-breaking
 317          (concat "\n" (make-string (1+ column) ?\ )))
 318         name value
 319         ret al ; cal
 320         key
 321         lbs cell rest separator)
 322     (insert "(")
 323     (while alist
 324       (setq name (car (car alist))
 325             value (cdr (car alist)))
 326       (cond ((eq name 'char)
 327              (insert "(char . ")
 328              (if (setq ret (condition-case nil
 329                                (find-char value)
 330                              (error nil)))
 331                  (progn
 332                    (setq al nil
 333                          ;; cal nil
 334                          )
 335                    (while value
 336                      (setq key (car (car value)))
 337                      ;; (if (find-charset key)
 338                      ;;     (setq cal (cons key cal))
 339                      (setq al (cons key al))
 340                      ;; )
 341                      (setq value (cdr value)))
 342                    (insert-char-attributes ret
 343                                            readable
 344                                            (or al 'none) ; cal
 345                                            ))
 346                (insert (prin1-to-string value)))
 347              (insert ")")
 348              (insert line-breaking))
 349             ((consp value)
 350              (insert (format "(%-18s " name))
 351              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 352              (while (consp value)
 353                (setq cell (car value))
 354                (if (and (consp cell)
 355                         (consp (car cell))
 356                         (setq ret (condition-case nil
 357                                       (find-char cell)
 358                                     (error nil)))
 359                         )
 360                    (progn
 361                      (setq rest cell
 362                            al nil
 363                            ;; cal nil
 364                            )
 365                      (while rest
 366                        (setq key (car (car rest)))
 367                        ;; (if (find-charset key)
 368                        ;;     (setq cal (cons key cal))
 369                        (setq al (cons key al))
 370                        ;; )
 371                        (setq rest (cdr rest)))
 372                      (if separator
 373                          (insert lbs))
 374                      (insert-char-attributes ret
 375                                              readable
 376                                              al ; cal
 377                                              )
 378                      (setq separator lbs))
 379                  (if separator
 380                      (insert separator))
 381                  (insert (prin1-to-string cell))
 382                  (setq separator " "))
 383                (setq value (cdr value)))
 384              (insert ")")
 385              (insert line-breaking))
 386             (t
 387              (insert (format "(%-18s . %S)%s"
 388                              name value
 389                              line-breaking))))
 390       (setq alist (cdr alist))))
 391   (insert ")"))
 392
 393 (defun char-db-insert-char-reference (plist &optional readable column)
 394   (unless column
 395     (setq column (current-column)))
 396   (let ((line-breaking
 397          (concat "\n" (make-string (1+ column) ?\ )))
 398         (separator "")
 399         name value)
 400     (insert "(")
 401     (while plist
 402       (setq name (pop plist))
 403       (setq value (pop plist))
 404       (cond ((eq name :char)
 405              (insert separator)
 406              (insert ":char\t")
 407              (cond ((numberp value)
 408                     (setq value (decode-char '=ucs value)))
 409                    ;; ((consp value)
 410                    ;;  (setq value (or (find-char value)
 411                    ;;                  value)))
 412                    )
 413              (char-db-insert-char-spec value readable)
 414              (insert line-breaking)
 415              (setq separator ""))
 416             ((eq name :radical)
 417              (insert (format "%s%s\t%d ; %c%s"
 418                              separator
 419                              name value
 420                              (ideographic-radical value)
 421                              line-breaking))
 422              (setq separator ""))
 423             (t
 424              (insert (format "%s%s\t%S" separator name value))
 425              (setq separator line-breaking)))
 426       ))
 427   (insert ")"))
 428
 429 (defun char-db-decode-isolated-char (ccs code-point)
 430   (let (ret)
 431     (setq ret
 432           (cond ((eq ccs 'arabic-iso8859-6)
 433                  (decode-char ccs code-point))
 434                 ((and (memq ccs '(=gt-pj-1
 435                                   =gt-pj-2
 436                                   =gt-pj-3
 437                                   =gt-pj-4
 438                                   =gt-pj-5
 439                                   =gt-pj-6
 440                                   =gt-pj-7
 441                                   =gt-pj-8
 442                                   =gt-pj-9
 443                                   =gt-pj-10
 444                                   =gt-pj-11))
 445                       (setq ret (decode-char ccs code-point))
 446                       (setq ret (encode-char ret '=gt 'defined-only)))
 447                  (decode-builtin-char '=gt ret))
 448                 (t
 449                  (decode-builtin-char ccs code-point))))
 450     (cond ((and (<= 0 (char-int ret))
 451                 (<= (char-int ret) #x1F))
 452            (decode-char '=ucs (+ #x2400 (char-int ret))))
 453           ((= (char-int ret) #x7F)
 454            ?\u2421)
 455           (t ret))))
 456
 457 (defvar char-db-convert-obsolete-format t)
 458
 459 (defun char-db-insert-ccs-feature (name value line-breaking)
 460   (insert
 461    (format
 462     (cond ((memq name '(=shinjigen
 463                         =shinjigen@1ed
 464                         =shinjigen@rev =shinjigen/+p@rev
 465                         =daikanwa/ho))
 466            "(%-18s .  %04d)\t; %c")
 467           ((eq name '=shinjigen@1ed/24pr)
 468            "(%-18s . %04d)\t; %c")
 469           ((or (memq name '(=daikanwa
 470                             =daikanwa@rev1 =daikanwa@rev2
 471                             =daikanwa/+p =daikanwa/+2p
 472                             =>>daikanwa =>daikanwa
 473                             =gt =>>gt =>gt =gt-k =>>gt-k =>gt-k =cbeta
 474                             =zinbun-oracle =>zinbun-oracle))
 475                (string-match "^=adobe-" (symbol-name name)))
 476            "(%-18s . %05d)\t; %c")
 477           ((memq name '(=hanyo-denshi/ks =>>hanyo-denshi/ks mojikyo))
 478            "(%-18s . %06d)\t; %c")
 479           ((>= (charset-dimension name) 2)
 480            "(%-18s . #x%04X)\t; %c")
 481           (t
 482            "(%-18s . #x%02X)\t; %c"))
 483     name
 484     (if (= (charset-iso-graphic-plane name) 1)
 485         (logior value
 486                 (cond ((= (charset-dimension name) 1)
 487                        #x80)
 488                       ((= (charset-dimension name) 2)
 489                        #x8080)
 490                       ((= (charset-dimension name) 3)
 491                        #x808080)
 492                       (t 0)))
 493       value)
 494     (char-db-decode-isolated-char name value)))
 495   (if (and (= (charset-chars name) 94)
 496            (= (charset-dimension name) 2))
 497       (insert (format " [%02d-%02d]"
 498                       (- (lsh value -8) 32)
 499                       (- (logand value 255) 32))))
 500   (insert line-breaking))
 501
 502 (defun char-db-insert-relation-feature (char name value line-breaking
 503                                              ccss readable)
 504   (insert (format "(%-18s%s " name line-breaking))
 505   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 506         separator cell sources required-features
 507         ret)
 508     (while (consp value)
 509       (setq cell (car value))
 510       (if (integerp cell)
 511           (setq cell (decode-char '=ucs cell)))
 512       (cond
 513        ((eq name '->subsumptive)
 514         (when (or (not (some (lambda (atr)
 515                                (get-char-attribute cell atr))
 516                              char-db-ignored-attributes))
 517                   (some (lambda (ccs)
 518                           (encode-char cell ccs 'defined-only))
 519                         ccss))
 520           (if separator
 521               (insert lbs))
 522           (let ((char-db-ignored-attributes
 523                  (cons '<-subsumptive
 524                        char-db-ignored-attributes)))
 525             (insert-char-attributes cell readable))
 526           (setq separator lbs))
 527         )
 528        ((characterp cell)
 529         (setq sources
 530               (get-char-attribute
 531                char (intern (format "%s*sources" name))))
 532         (setq required-features nil)
 533         (dolist (source sources)
 534           (cond
 535            ((memq source '(JP
 536                            JP/Jouyou
 537                            shinjigen shinjigen@1ed shinjigen@rev))
 538             (setq required-features
 539                   (union required-features
 540                          '(=jis-x0208
 541                            =jis-x0208@1990
 542                            =jis-x0213-1@2000
 543                            =jis-x0213-1@2004
 544                            =jis-x0213-2
 545                            =jis-x0212
 546                            =jis-x0208@1983
 547                            =jis-x0208@1978
 548                            =shinjigen))))
 549            ((eq source 'CN)
 550             (setq required-features
 551                   (union required-features
 552                          '(=gb2312
 553                            =gb12345
 554                            =iso-ir165)))))
 555           (cond
 556            ((find-charset (setq ret (intern (format "=%s" source))))
 557             (setq required-features
 558                   (cons ret required-features)))
 559            (t (setq required-features
 560                     (cons source required-features)))))
 561         (cond ((string-match "@JP" (symbol-name name))
 562                (setq required-features
 563                      (union required-features
 564                             '(=jis-x0208
 565                               =jis-x0208@1990
 566                               =jis-x0213-1-2000
 567                               =jis-x0213-2-2000
 568                               =jis-x0212
 569                               =jis-x0208@1983
 570                               =jis-x0208@1978))))
 571               ((string-match "@CN" (symbol-name name))
 572                (setq required-features
 573                      (union required-features
 574                             '(=gb2312
 575                               =gb12345
 576                               =iso-ir165)))))
 577         (if separator
 578             (insert lbs))
 579         (if readable
 580             (insert (format "%S" cell))
 581           (char-db-insert-char-spec cell readable
 582                                     nil
 583                                     required-features))
 584         (setq separator lbs))
 585        ((consp cell)
 586         (if separator
 587             (insert lbs))
 588         (if (consp (car cell))
 589             (char-db-insert-char-spec cell readable)
 590           (char-db-insert-char-reference cell readable))
 591         (setq separator lbs))
 592        (t
 593         (if separator
 594             (insert separator))
 595         (insert (prin1-to-string cell))
 596         (setq separator " ")))
 597       (setq value (cdr value)))
 598     (insert ")")
 599     (insert line-breaking)))
 600
 601 (defun insert-char-attributes (char &optional readable attributes column)
 602   (unless column
 603     (setq column (current-column)))
 604   (let (name value ; has-long-ccs-name
 605         rest
 606         radical strokes
 607         (line-breaking
 608          (concat "\n" (make-string (1+ column) ?\ )))
 609         lbs cell separator ret
 610         key al cal
 611         dest-ccss ; sources required-features
 612         ccss)
 613     (let (atr-d)
 614       (setq attributes
 615             (sort (if attributes
 616                       (if (consp attributes)
 617                           (progn
 618                             (dolist (name attributes)
 619                               (unless (memq name char-db-ignored-attributes)
 620                                 (if (find-charset name)
 621                                     (push name ccss))
 622                                 (push name atr-d)))
 623                             atr-d))
 624                     (dolist (name (char-attribute-list))
 625                       (unless (memq name char-db-ignored-attributes)
 626                         (if (find-charset name)
 627                             (push name ccss))
 628                         (push name atr-d)))
 629                     atr-d)
 630                   #'char-attribute-name<)))
 631     (insert "(")
 632     (when (memq '<-subsumptive attributes)
 633       (when readable
 634         (when (setq value (get-char-attribute char '<-subsumptive))
 635           (char-db-insert-relation-feature char '<-subsumptive value
 636                                            line-breaking
 637                                            ccss readable)))
 638       (setq attributes (delq '<-subsumptive attributes)))
 639     (when (and (memq '<-denotational attributes)
 640                (setq value (get-char-attribute char '<-denotational)))
 641       (char-db-insert-relation-feature char '<-denotational value
 642                                        line-breaking
 643                                        ccss readable)
 644       (setq attributes (delq '<-denotational attributes)))
 645     (when (and (memq 'name attributes)
 646                (setq value (get-char-attribute char 'name)))
 647       (insert (format
 648                (if (> (+ (current-column) (length value)) 48)
 649                    "(name . %S)%s"
 650                  "(name               . %S)%s")
 651                value line-breaking))
 652       (setq attributes (delq 'name attributes))
 653       )
 654     (when (and (memq 'name* attributes)
 655                (setq value (get-char-attribute char 'name*)))
 656       (insert (format
 657                (if (> (+ (current-column) (length value)) 48)
 658                    "(name* . %S)%s"
 659                  "(name*              . %S)%s")
 660                value line-breaking))
 661       (setq attributes (delq 'name* attributes))
 662       )
 663     (when (and (memq 'script attributes)
 664                (setq value (get-char-attribute char 'script)))
 665       (insert (format "(script\t\t%s)%s"
 666                       (mapconcat (function prin1-to-string)
 667                                  value " ")
 668                       line-breaking))
 669       (setq attributes (delq 'script attributes))
 670       )
 671     (dolist (name '(=>ucs =>ucs*))
 672       (when (and (memq name attributes)
 673                  (setq value (get-char-attribute char name)))
 674         (insert (format "(%-18s . #x%04X)\t; %c%s"
 675                         name value (decode-char '=ucs value)
 676                         line-breaking))
 677         (setq attributes (delq name attributes))))
 678     (dolist (name '(=>ucs@gb =>ucs@big5))
 679       (when (and (memq name attributes)
 680                  (setq value (get-char-attribute char name)))
 681         (insert (format "(%-18s . #x%04X)\t; %c%s"
 682                         name value
 683                         (decode-char (intern
 684                                       (concat "="
 685                                               (substring
 686                                                (symbol-name name) 2)))
 687                                      value)
 688                         line-breaking))
 689         (setq attributes (delq name attributes))
 690         ))
 691     ;; (dolist (name '(=>daikanwa))
 692     ;;   (when (and (memq name attributes)
 693     ;;              (setq value (get-char-attribute char name)))
 694     ;;     (insert
 695     ;;      (if (integerp value)
 696     ;;          (format "(%-18s . %05d)\t; %c%s"
 697     ;;                  name value (decode-char '=daikanwa value)
 698     ;;                  line-breaking)
 699     ;;        (format "(%-18s %s)\t; %c%s"
 700     ;;                name
 701     ;;                (mapconcat (function prin1-to-string)
 702     ;;                           value " ")
 703     ;;                (char-representative-of-daikanwa char)
 704     ;;                line-breaking)))
 705     ;;     (setq attributes (delq name attributes))))
 706     (when (and (memq 'general-category attributes)
 707                (setq value (get-char-attribute char 'general-category)))
 708       (insert (format
 709                "(general-category\t%s) ; %s%s"
 710                (mapconcat (lambda (cell)
 711                             (format "%S" cell))
 712                           value " ")
 713                (cond ((rassoc value unidata-normative-category-alist)
 714                       "Normative Category")
 715                      ((rassoc value unidata-informative-category-alist)
 716                       "Informative Category")
 717                      (t
 718                       "Unknown Category"))
 719                line-breaking))
 720       (setq attributes (delq 'general-category attributes))
 721       )
 722     (when (and (memq 'bidi-category attributes)
 723                (setq value (get-char-attribute char 'bidi-category)))
 724       (insert (format "(bidi-category\t. %S)%s"
 725                       value
 726                       line-breaking))
 727       (setq attributes (delq 'bidi-category attributes))
 728       )
 729     (unless (or (not (memq 'mirrored attributes))
 730                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 731                     'empty))
 732       (insert (format "(mirrored\t\t. %S)%s"
 733                       value
 734                       line-breaking))
 735       (setq attributes (delq 'mirrored attributes))
 736       )
 737     (cond
 738      ((and (memq 'decimal-digit-value attributes)
 739            (setq value (get-char-attribute char 'decimal-digit-value)))
 740       (insert (format "(decimal-digit-value . %S)%s"
 741                       value
 742                       line-breaking))
 743       (setq attributes (delq 'decimal-digit-value attributes))
 744       (when (and (memq 'digit-value attributes)
 745                  (setq value (get-char-attribute char 'digit-value)))
 746         (insert (format "(digit-value\t . %S)%s"
 747                         value
 748                         line-breaking))
 749         (setq attributes (delq 'digit-value attributes))
 750         )
 751       (when (and (memq 'numeric-value attributes)
 752                  (setq value (get-char-attribute char 'numeric-value)))
 753         (insert (format "(numeric-value\t . %S)%s"
 754                         value
 755                         line-breaking))
 756         (setq attributes (delq 'numeric-value attributes))
 757         )
 758       )
 759      (t
 760       (when (and (memq 'digit-value attributes)
 761                  (setq value (get-char-attribute char 'digit-value)))
 762         (insert (format "(digit-value\t. %S)%s"
 763                         value
 764                         line-breaking))
 765         (setq attributes (delq 'digit-value attributes))
 766         )
 767       (when (and (memq 'numeric-value attributes)
 768                  (setq value (get-char-attribute char 'numeric-value)))
 769         (insert (format "(numeric-value\t. %S)%s"
 770                         value
 771                         line-breaking))
 772         (setq attributes (delq 'numeric-value attributes))
 773         )))
 774     (when (and (memq 'iso-10646-comment attributes)
 775                (setq value (get-char-attribute char 'iso-10646-comment)))
 776       (insert (format "(iso-10646-comment\t. %S)%s"
 777                       value
 778                       line-breaking))
 779       (setq attributes (delq 'iso-10646-comment attributes))
 780       )
 781     (when (and (memq 'morohashi-daikanwa attributes)
 782                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 783       (insert (format "(morohashi-daikanwa\t%s)%s"
 784                       (mapconcat (function prin1-to-string) value " ")
 785                       line-breaking))
 786       (setq attributes (delq 'morohashi-daikanwa attributes))
 787       )
 788     (setq radical nil
 789           strokes nil)
 790     (when (and (memq 'ideographic-radical attributes)
 791                (setq value (get-char-attribute char 'ideographic-radical)))
 792       (setq radical value)
 793       (insert (format "(ideographic-radical . %S)\t; %c%s"
 794                       radical
 795                       (ideographic-radical radical)
 796                       line-breaking))
 797       (setq attributes (delq 'ideographic-radical attributes))
 798       )
 799     (when (and (memq 'shuowen-radical attributes)
 800                (setq value (get-char-attribute char 'shuowen-radical)))
 801       (insert (format "(shuowen-radical\t. %S)\t; %c%s"
 802                       value
 803                       (shuowen-radical value)
 804                       line-breaking))
 805       (setq attributes (delq 'shuowen-radical attributes))
 806       )
 807     (let (key)
 808       (dolist (domain
 809                (append
 810                 char-db-feature-domains
 811                 (let (dest domain)
 812                   (dolist (feature (char-attribute-list))
 813                     (setq feature (symbol-name feature))
 814                     (when (string-match
 815                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
 816                            feature)
 817                       (setq domain (intern (match-string 2 feature)))
 818                      (unless (memq domain dest)
 819                        (setq dest (cons domain dest)))))
 820                   (sort dest #'string<))))
 821         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
 822         (when (and (memq key attributes)
 823                    (setq value (get-char-attribute char key)))
 824           (setq radical value)
 825           (insert (format "(%s . %S)\t; %c%s"
 826                           key
 827                           radical
 828                           (ideographic-radical radical)
 829                           line-breaking))
 830           (setq attributes (delq key attributes))
 831           )
 832         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
 833         (when (and (memq key attributes)
 834                    (setq value (get-char-attribute char key)))
 835           (setq strokes value)
 836           (insert (format "(%s . %S)%s"
 837                           key
 838                           strokes
 839                           line-breaking))
 840           (setq attributes (delq key attributes))
 841           )
 842         (setq key (intern (format "%s@%s" 'total-strokes domain)))
 843         (when (and (memq key attributes)
 844                    (setq value (get-char-attribute char key)))
 845           (insert (format "(%s       . %S)%s"
 846                           key
 847                           value
 848                           line-breaking))
 849           (setq attributes (delq key attributes))
 850           )
 851         (dolist (feature '(ideographic-radical
 852                            ideographic-strokes
 853                            total-strokes))
 854           (setq key (intern (format "%s@%s*sources" feature domain)))
 855           (when (and (memq key attributes)
 856                      (setq value (get-char-attribute char key)))
 857             (insert (format "(%s%s" key line-breaking))
 858             (dolist (cell value)
 859               (insert (format " %s" cell)))
 860             (insert ")")
 861             (insert line-breaking)
 862             (setq attributes (delq key attributes))
 863             ))
 864         ))
 865     (when (and (memq 'ideographic-strokes attributes)
 866                (setq value (get-char-attribute char 'ideographic-strokes)))
 867       (setq strokes value)
 868       (insert (format "(ideographic-strokes . %S)%s"
 869                       strokes
 870                       line-breaking))
 871       (setq attributes (delq 'ideographic-strokes attributes))
 872       )
 873     (when (and (memq 'kangxi-radical attributes)
 874                (setq value (get-char-attribute char 'kangxi-radical)))
 875       (unless (eq value radical)
 876         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 877                         value
 878                         (ideographic-radical value)
 879                         line-breaking))
 880         (or radical
 881             (setq radical value)))
 882       (setq attributes (delq 'kangxi-radical attributes))
 883       )
 884     (when (and (memq 'kangxi-strokes attributes)
 885                (setq value (get-char-attribute char 'kangxi-strokes)))
 886       (unless (eq value strokes)
 887         (insert (format "(kangxi-strokes\t . %S)%s"
 888                         value
 889                         line-breaking))
 890         (or strokes
 891             (setq strokes value)))
 892       (setq attributes (delq 'kangxi-strokes attributes))
 893       )
 894     (when (and (memq 'japanese-radical attributes)
 895                (setq value (get-char-attribute char 'japanese-radical)))
 896       (unless (eq value radical)
 897         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 898                         value
 899                         (ideographic-radical value)
 900                         line-breaking))
 901         (or radical
 902             (setq radical value)))
 903       (setq attributes (delq 'japanese-radical attributes))
 904       )
 905     (when (and (memq 'japanese-strokes attributes)
 906                (setq value (get-char-attribute char 'japanese-strokes)))
 907       (unless (eq value strokes)
 908         (insert (format "(japanese-strokes\t . %S)%s"
 909                         value
 910                         line-breaking))
 911         (or strokes
 912             (setq strokes value)))
 913       (setq attributes (delq 'japanese-strokes attributes))
 914       )
 915     (when (and (memq 'cns-radical attributes)
 916                (setq value (get-char-attribute char 'cns-radical)))
 917       (insert (format "(cns-radical\t . %S)\t; %c%s"
 918                       value
 919                       (ideographic-radical value)
 920                       line-breaking))
 921       (setq attributes (delq 'cns-radical attributes))
 922       )
 923     (when (and (memq 'cns-strokes attributes)
 924                (setq value (get-char-attribute char 'cns-strokes)))
 925       (unless (eq value strokes)
 926         (insert (format "(cns-strokes\t . %S)%s"
 927                         value
 928                         line-breaking))
 929         (or strokes
 930             (setq strokes value)))
 931       (setq attributes (delq 'cns-strokes attributes))
 932       )
 933     (when (and (memq 'shinjigen-1-radical attributes)
 934                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 935       (unless (eq value radical)
 936         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 937                         value
 938                         (ideographic-radical value)
 939                         line-breaking))
 940         (or radical
 941             (setq radical value)))
 942       (setq attributes (delq 'shinjigen-1-radical attributes))
 943       )
 944     (when (and (memq 'ideographic- attributes)
 945                (setq value (get-char-attribute char 'ideographic-)))
 946       (insert "(ideographic-       ")
 947       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 948             separator nil)
 949       (while (consp value)
 950         (setq cell (car value))
 951         (if (integerp cell)
 952             (setq cell (decode-char '=ucs cell)))
 953         (cond ((characterp cell)
 954                (if separator
 955                    (insert lbs))
 956                (if readable
 957                    (insert (format "%S" cell))
 958                  (char-db-insert-char-spec cell readable))
 959                (setq separator lbs))
 960               ((consp cell)
 961                (if separator
 962                    (insert lbs))
 963                (if (consp (car cell))
 964                    (char-db-insert-char-spec cell readable)
 965                  (char-db-insert-char-reference cell readable))
 966                (setq separator lbs))
 967               (t
 968                (if separator
 969                    (insert separator))
 970                (insert (prin1-to-string cell))
 971                (setq separator " ")))
 972         (setq value (cdr value)))
 973       (insert ")")
 974       (insert line-breaking)
 975       (setq attributes (delq 'ideographic- attributes)))
 976     (when (and (memq 'total-strokes attributes)
 977                (setq value (get-char-attribute char 'total-strokes)))
 978       (insert (format "(total-strokes       . %S)%s"
 979                       value
 980                       line-breaking))
 981       (setq attributes (delq 'total-strokes attributes))
 982       )
 983     (when (and (memq '->ideograph attributes)
 984                (setq value (get-char-attribute char '->ideograph)))
 985       (insert (format "(->ideograph\t%s)%s"
 986                       (mapconcat (lambda (code)
 987                                    (cond ((symbolp code)
 988                                           (symbol-name code))
 989                                          ((integerp code)
 990                                           (format "#x%04X" code))
 991                                          (t
 992                                           (format "%s %S"
 993                                                   line-breaking code))))
 994                                  value " ")
 995                       line-breaking))
 996       (setq attributes (delq '->ideograph attributes))
 997       )
 998     ;; (when (and (memq '->decomposition attributes)
 999     ;;            (setq value (get-char-attribute char '->decomposition)))
1000     ;;   (insert (format "(->decomposition\t%s)%s"
1001     ;;                   (mapconcat (lambda (code)
1002     ;;                                (cond ((symbolp code)
1003     ;;                                       (symbol-name code))
1004     ;;                                      ((characterp code)
1005     ;;                                       (if readable
1006     ;;                                           (format "%S" code)
1007     ;;                                         (format "#x%04X"
1008     ;;                                                 (char-int code))
1009     ;;                                         ))
1010     ;;                                      ((integerp code)
1011     ;;                                       (format "#x%04X" code))
1012     ;;                                      (t
1013     ;;                                       (format "%s%S" line-breaking code))))
1014     ;;                              value " ")
1015     ;;                   line-breaking))
1016     ;;   (setq attributes (delq '->decomposition attributes))
1017     ;;   )
1018     (if (equal (get-char-attribute char '->titlecase)
1019                (get-char-attribute char '->uppercase))
1020         (setq attributes (delq '->titlecase attributes)))
1021     (when (and (memq '->mojikyo attributes)
1022                (setq value (get-char-attribute char '->mojikyo)))
1023       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
1024                       value (decode-char 'mojikyo value)
1025                       line-breaking))
1026       (setq attributes (delq '->mojikyo attributes))
1027       )
1028     (when (and (memq 'hanyu-dazidian-vol attributes)
1029                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
1030       (insert (format "(hanyu-dazidian-vol  . %d)%s"
1031                       value line-breaking))
1032       (setq attributes (delq 'hanyu-dazidian-vol attributes))
1033       )
1034     (when (and (memq 'hanyu-dazidian-page attributes)
1035                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
1036       (insert (format "(hanyu-dazidian-page . %d)%s"
1037                       value line-breaking))
1038       (setq attributes (delq 'hanyu-dazidian-page attributes))
1039       )
1040     (when (and (memq 'hanyu-dazidian-char attributes)
1041                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
1042       (insert (format "(hanyu-dazidian-char . %d)%s"
1043                       value line-breaking))
1044       (setq attributes (delq 'hanyu-dazidian-char attributes))
1045       )
1046     (unless readable
1047       (dolist (ignored '(composition
1048                          ->denotational <-subsumptive ->ucs-unified
1049                          ->ideographic-component-forms))
1050         (setq attributes (delq ignored attributes))))
1051     (while attributes
1052       (setq name (car attributes))
1053       (if (setq value (get-char-attribute char name))
1054           (cond ((setq ret (find-charset name))
1055                  (setq name (charset-name ret))
1056                  (if (and (not (memq name dest-ccss))
1057                           (prog1
1058                               (setq value (get-char-attribute char name))
1059                             (setq dest-ccss (cons name dest-ccss))))
1060                      (char-db-insert-ccs-feature name value line-breaking))
1061                  )
1062                 ((string-match "^=>ucs@" (symbol-name name))
1063                  (insert (format "(%-18s . #x%04X)\t; %c%s"
1064                                  name value (decode-char '=ucs value)
1065                                  line-breaking))
1066                  )
1067                 ((eq name 'jisx0208-1978/4X)
1068                  (insert (format "(%-18s . #x%04X)%s"
1069                                  name value
1070                                  line-breaking))
1071                  )
1072                 ((and
1073                   (not readable)
1074                   (not (eq name '->subsumptive))
1075                   (not (eq name '->uppercase))
1076                   (not (eq name '->lowercase))
1077                   (not (eq name '->titlecase))
1078                   (not (eq name '->canonical))
1079                   (not (eq name '->Bopomofo))
1080                   (not (eq name '->mistakable))
1081                   (not (eq name '->ideographic-variants))
1082                   (null (get-char-attribute
1083                          char (intern (format "%s*sources" name))))
1084                   (not (string-match "\\*sources$" (symbol-name name)))
1085                   (null (get-char-attribute
1086                          char (intern (format "%s*note" name))))
1087                   (not (string-match "\\*note$" (symbol-name name)))
1088                   (or (eq name '<-identical)
1089                       (eq name '<-uppercase)
1090                       (eq name '<-lowercase)
1091                       (eq name '<-titlecase)
1092                       (eq name '<-canonical)
1093                       (eq name '<-ideographic-variants)
1094                       ;; (eq name '<-synonyms)
1095                       (string-match "^<-synonyms" (symbol-name name))
1096                       (eq name '<-mistakable)
1097                       (when (string-match "^->" (symbol-name name))
1098                         (cond
1099                          ((string-match "^->fullwidth" (symbol-name name))
1100                           (not (and (consp value)
1101                                     (characterp (car value))
1102                                     (encode-char
1103                                      (car value) '=ucs 'defined-only)))
1104                           )
1105                          (t)))
1106                       ))
1107                  )
1108                 ((or (eq name 'ideographic-structure)
1109                      (eq name 'ideographic-combination)
1110                      (eq name 'ideographic-)
1111                      (eq name '=decomposition)
1112                      (string-match "^=>*decomposition\\(@[^*]+\\)?$"
1113                                    (symbol-name name))
1114                      (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
1115                      (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
1116                                    (symbol-name name))
1117                      )
1118                  (char-db-insert-relation-feature char name value
1119                                                   line-breaking
1120                                                   ccss readable))
1121                 ((memq name '(ideograph=
1122                               original-ideograph-of
1123                               ancient-ideograph-of
1124                               vulgar-ideograph-of
1125                               wrong-ideograph-of
1126                               ;; simplified-ideograph-of
1127                               ideographic-variants
1128                               ;; ideographic-different-form-of
1129                               ))
1130                  (insert (format "(%-18s%s " name line-breaking))
1131                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1132                        separator nil)
1133                  (while (consp value)
1134                    (setq cell (car value))
1135                    (if (and (consp cell)
1136                             (consp (car cell)))
1137                        (progn
1138                          (if separator
1139                              (insert lbs))
1140                          (char-db-insert-alist cell readable)
1141                          (setq separator lbs))
1142                      (if separator
1143                          (insert separator))
1144                      (insert (prin1-to-string cell))
1145                      (setq separator " "))
1146                    (setq value (cdr value)))
1147                  (insert ")")
1148                  (insert line-breaking))
1149                 ((consp value)
1150                  (insert (format "(%-18s " name))
1151                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1152                        separator nil)
1153                  (while (consp value)
1154                    (setq cell (car value))
1155                    (if (and (consp cell)
1156                             (consp (car cell))
1157                             (setq ret (condition-case nil
1158                                           (find-char cell)
1159                                         (error nil))))
1160                        (progn
1161                          (setq rest cell
1162                                al nil
1163                                cal nil)
1164                          (while rest
1165                            (setq key (car (car rest)))
1166                            (if (find-charset key)
1167                                (setq cal (cons key cal))
1168                              (setq al (cons key al)))
1169                            (setq rest (cdr rest)))
1170                          (if separator
1171                              (insert lbs))
1172                          (insert-char-attributes ret
1173                                                  readable
1174                                                  al cal)
1175                          (setq separator lbs))
1176                      (setq ret (prin1-to-string cell))
1177                      (if separator
1178                          (if (< (+ (current-column)
1179                                    (length ret)
1180                                    (length separator))
1181                                 76)
1182                              (insert separator)
1183                            (insert lbs)))
1184                      (insert ret)
1185                      (setq separator " "))
1186                    (setq value (cdr value)))
1187                  (insert ")")
1188                  (insert line-breaking))
1189                 (t
1190                  (insert (format "(%-18s" name))
1191                  (setq ret (prin1-to-string value))
1192                  (unless (< (+ (current-column)
1193                                (length ret)
1194                                3)
1195                             76)
1196                    (insert line-breaking))
1197                  (insert " . " ret ")" line-breaking)
1198                  ;; (insert (format "(%-18s . %S)%s"
1199                  ;;                 name value
1200                  ;;                 line-breaking))
1201                  )
1202                 ))
1203       (setq attributes (cdr attributes)))
1204     (insert ")")))
1205
1206 (defun insert-char-data (char &optional readable
1207                               attributes)
1208   (save-restriction
1209     (narrow-to-region (point)(point))
1210     (insert "(define-char
1211   '")
1212     (insert-char-attributes char readable attributes)
1213     (insert ")\n")
1214     (goto-char (point-min))
1215     (while (re-search-forward "[ \t]+$" nil t)
1216       (replace-match ""))
1217     ;; from tabify.
1218     (goto-char (point-min))
1219     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1220       (let ((column (current-column))
1221             (indent-tabs-mode t))
1222         (delete-region (match-beginning 0) (point))
1223         (indent-to column)))
1224     (goto-char (point-max))
1225     ;; (tabify (point-min)(point-max))
1226     ))
1227
1228 (defun insert-char-data-with-variant (char &optional printable
1229                                            no-ucs-unified
1230                                            script excluded-script)
1231   (insert-char-data char printable)
1232   (let ((variants (char-variants char))
1233         rest
1234         variant vs ret)
1235     (setq variants (sort variants #'<))
1236     (setq rest variants)
1237     (setq variants (cons char variants))
1238     (while rest
1239       (setq variant (car rest))
1240       (unless (get-char-attribute variant '<-subsumptive)
1241         (if (and (or (null script)
1242                      (null (setq vs (get-char-attribute variant 'script)))
1243                      (memq script vs))
1244                  (or (null excluded-script)
1245                      (null (setq vs (get-char-attribute variant 'script)))
1246                      (not (memq excluded-script vs))))
1247             (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1248               (insert-char-data variant printable)
1249               (if (setq ret (char-variants variant))
1250                   (while ret
1251                     (or (memq (car ret) variants)
1252                         ;; (get-char-attribute (car ret) '<-subsumptive)
1253                         (setq rest (nconc rest (list (car ret)))))
1254                     (setq ret (cdr ret)))))))
1255       (setq rest (cdr rest)))))
1256
1257 (defun insert-char-range-data (min max &optional script excluded-script)
1258   (let ((code min)
1259         char)
1260     (while (<= code max)
1261       (setq char (decode-char '=ucs code))
1262       (if (encode-char char '=ucs 'defined-only)
1263           (insert-char-data-with-variant char nil 'no-ucs-unified
1264                                          script excluded-script))
1265       (setq code (1+ code)))))
1266
1267 (defun write-char-range-data-to-file (min max file
1268                                           &optional script excluded-script)
1269   (let ((coding-system-for-write char-db-file-coding-system))
1270     (with-temp-buffer
1271       (insert (format ";; -*- coding: %s -*-\n"
1272                       char-db-file-coding-system))
1273       (insert-char-range-data min max script excluded-script)
1274       (write-region (point-min)(point-max) file))))
1275
1276 (defvar what-character-original-window-configuration)
1277
1278 ;;;###autoload
1279 (defun what-char-definition (char)
1280   (interactive (list (char-after)))
1281   (let ((buf (get-buffer-create "*Character Description*"))
1282         (the-buf (current-buffer))
1283         (win-conf (current-window-configuration)))
1284     (pop-to-buffer buf)
1285     (make-local-variable 'what-character-original-window-configuration)
1286     (setq what-character-original-window-configuration win-conf)
1287     (setq buffer-read-only nil)
1288     (erase-buffer)
1289     (condition-case err
1290         (progn
1291           (insert-char-data-with-variant char 'printable)
1292           (unless (char-attribute-alist char)
1293             (insert (format ";; = %c\n"
1294                             (let* ((rest (split-char char))
1295                                    (ccs (pop rest))
1296                                    (code (pop rest)))
1297                               (while rest
1298                                 (setq code (logior (lsh code 8)
1299                                                    (pop rest))))
1300                               (decode-char ccs code)))))
1301           ;; (char-db-update-comment)
1302           (set-buffer-modified-p nil)
1303           (view-mode the-buf (lambda (buf)
1304                                (set-window-configuration
1305                                 what-character-original-window-configuration)
1306                                ))
1307           (goto-char (point-min)))
1308       (error (progn
1309                (set-window-configuration
1310                 what-character-original-window-configuration)
1311                (signal (car err) (cdr err)))))))
1312
1313
1314 ;;; @ end
1315 ;;;
1316
1317 (provide 'char-db-util)
1318
1319 ;;; char-db-util.el ends here