lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility
   2
   3 ;; Copyright (C) 1998,1999,2000,2001 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'alist)
  28
  29 (defconst unidata-normative-category-alist
  30   '(("Lu" letter        uppercase)
  31     ("Ll" letter        lowercase)
  32     ("Lt" letter        titlecase)
  33     ("Mn" mark          non-spacing)
  34     ("Mc" mark          spacing-combining)
  35     ("Me" mark          enclosing)
  36     ("Nd" number        decimal-digit)
  37     ("Nl" number        letter)
  38     ("No" number        other)
  39     ("Zs" separator     space)
  40     ("Zl" separator     line)
  41     ("Zp" separator     paragraph)
  42     ("Cc" other         control)
  43     ("Cf" other         format)
  44     ("Cs" other         surrogate)
  45     ("Co" other         private-use)
  46     ("Cn" other         not-assigned)))
  47
  48 (defconst unidata-informative-category-alist
  49   '(("Lm" letter        modifier)
  50     ("Lo" letter        other)
  51     ("Pc" punctuation   connector)
  52     ("Pd" punctuation   dash)
  53     ("Ps" punctuation   open)
  54     ("Pe" punctuation   close)
  55     ("Pi" punctuation   initial-quote)
  56     ("Pf" punctuation   final-quote)
  57     ("Po" punctuation   other)
  58     ("Sm" symbol        math)
  59     ("Sc" symbol        currency)
  60     ("Sk" symbol        modifier)
  61     ("So" symbol        other)
  62     ))
  63
  64 (defconst ideographic-radicals
  65   (let ((v (make-vector 215 nil))
  66         (i 1))
  67     (while (< i 215)
  68       (aset v i (int-char (+ #x2EFF i)))
  69       (setq i (1+ i)))
  70     (if (< (charset-iso-final-char (car (split-char (aref v 34)))) ?0)
  71         (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
  72     v))
  73
  74 (defun char-attribute-name< (ka kb)
  75   (cond
  76    ((find-charset ka)
  77     (cond
  78      ((find-charset kb)
  79       (cond
  80        ((= (charset-dimension ka)
  81            (charset-dimension kb))
  82         (cond ((= (charset-chars ka)(charset-chars kb))
  83                (cond
  84                 ((>= (charset-iso-final-char ka) ?@)
  85                  (if (>= (charset-iso-final-char kb) ?@)
  86                      (< (charset-iso-final-char ka)
  87                         (charset-iso-final-char kb))
  88                    t))
  89                 ((>= (charset-iso-final-char ka) ?0)
  90                  (cond
  91                   ((>= (charset-iso-final-char kb) ?@)
  92                    nil)
  93                   ((>= (charset-iso-final-char kb) ?0)
  94                    (< (charset-iso-final-char ka)
  95                       (charset-iso-final-char kb)))
  96                   (t)))
  97                 (t (if (>= (charset-iso-final-char kb) ?0)
  98                        nil
  99                      (> (charset-id ka)(charset-id kb))))))
 100               ((<= (charset-chars ka)(charset-chars kb)))))
 101        (t
 102         (< (charset-dimension ka)
 103            (charset-dimension kb))
 104         )))
 105      ((symbolp kb)
 106       nil)
 107      (t
 108       t)))
 109    ((find-charset kb)
 110     t)
 111    ((symbolp ka)
 112     (cond ((symbolp kb)
 113            (string< (symbol-name ka)
 114                     (symbol-name kb)))
 115           (t)))
 116    ((symbolp kb)
 117     nil)))
 118
 119 (defun char-db-insert-char-spec (char &optional readable column)
 120   (unless column
 121     (setq column (current-column)))
 122   (let (char-spec ret al cal key temp-char)
 123     (cond ((characterp char)
 124            (cond ((setq ret (get-char-attribute char 'ucs))
 125                   (unless (and (<= #xE000 ret)(<= ret #xF8FF))
 126                     (setq char-spec (list (cons 'ucs ret))))
 127                   (if (setq ret (get-char-attribute char 'chinese-big5-cdp))
 128                       (setq char-spec (cons (cons 'chinese-big5-cdp ret)
 129                                             char-spec)))
 130                   (if (setq ret (get-char-attribute char 'name))
 131                       (setq char-spec (cons (cons 'name ret) char-spec)))
 132                   )
 133                  ((setq ret (split-char char))
 134                   (setq char-spec (list ret))
 135                   (dolist (ccs (delq (car ret) (charset-list)))
 136                     (if (or (and (>= (charset-iso-final-char ccs) ?0)
 137                                  (setq ret (get-char-attribute char ccs)))
 138                             (eq ccs 'ideograph-daikanwa))
 139                         (setq char-spec (cons (cons ccs ret) char-spec))))
 140                   (if (setq ret (get-char-attribute char 'name))
 141                       (setq char-spec (cons (cons 'name ret) char-spec)))
 142                   )))
 143           ((consp char)
 144            (setq char-spec char)
 145            (setq char nil)))
 146     (unless (or char
 147                 (condition-case nil
 148                     (setq char (find-char char-spec))
 149                   (error nil)))
 150       ;; define temporary character
 151       ;;   Current implementation is dirty.
 152       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 153                                          char-spec)))
 154       (remove-char-attribute temp-char 'ideograph-daikanwa)
 155       (setq char temp-char))
 156     (setq al nil
 157           cal nil)
 158     (while char-spec
 159       (setq key (car (car char-spec)))
 160       (if (find-charset key)
 161           (setq cal (cons key cal))
 162         (setq al (cons key al)))
 163       (setq char-spec (cdr char-spec)))
 164     (insert-char-attributes char
 165                             readable
 166                             (or al 'none) cal)
 167     (when temp-char
 168       ;; undefine temporary character
 169       ;;   Current implementation is dirty.
 170       (setq char-spec (char-attribute-alist temp-char))
 171       (while char-spec
 172         (remove-char-attribute temp-char (car (car char-spec)))
 173         (setq char-spec (cdr char-spec))))))
 174
 175 (defun char-db-insert-alist (alist &optional readable column)
 176   (unless column
 177     (setq column (current-column)))
 178   (let ((line-breaking
 179          (concat "\n" (make-string (1+ column) ?\ )))
 180         name value
 181         ret al cal key
 182         lbs cell rest separator)
 183     (insert "(")
 184     (while alist
 185       (setq name (car (car alist))
 186             value (cdr (car alist)))
 187       (cond ((eq name 'char)
 188              (insert "(char . ")
 189              (if (setq ret (condition-case nil
 190                                (find-char value)
 191                              (error nil)))
 192                  (progn
 193                    (setq al nil
 194                          cal nil)
 195                    (while value
 196                      (setq key (car (car value)))
 197                      (if (find-charset key)
 198                          (setq cal (cons key cal))
 199                        (setq al (cons key al)))
 200                      (setq value (cdr value)))
 201                    (insert-char-attributes ret
 202                                            readable
 203                                            (or al 'none) cal))
 204                (insert (prin1-to-string value)))
 205              (insert ")")
 206              (insert line-breaking))
 207             ((consp value)
 208              (insert (format "(%-18s " name))
 209              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 210              (while (consp value)
 211                (setq cell (car value))
 212                (if (and (consp cell)
 213                         (consp (car cell))
 214                         (setq ret (condition-case nil
 215                                       (find-char cell)
 216                                     (error nil)))
 217                         )
 218                    (progn
 219                      (setq rest cell
 220                            al nil
 221                            cal nil)
 222                      (while rest
 223                        (setq key (car (car rest)))
 224                        (if (find-charset key)
 225                            (setq cal (cons key cal))
 226                          (setq al (cons key al)))
 227                        (setq rest (cdr rest)))
 228                      (if separator
 229                          (insert lbs))
 230                      (insert-char-attributes ret
 231                                              readable
 232                                              al cal)
 233                      (setq separator lbs))
 234                  (if separator
 235                      (insert separator))
 236                  (insert (prin1-to-string cell))
 237                  (setq separator " "))
 238                (setq value (cdr value)))
 239              (insert ")")
 240              (insert line-breaking))
 241             (t
 242              (insert (format "(%-18s . %S)%s"
 243                              name value
 244                              line-breaking))))
 245       (setq alist (cdr alist))))
 246   (insert ")"))
 247
 248 (defun char-db-insert-char-reference (plist &optional readable column)
 249   (unless column
 250     (setq column (current-column)))
 251   (let ((line-breaking
 252          (concat "\n" (make-string (1+ column) ?\ )))
 253         name value)
 254     (insert "(")
 255     (while plist
 256       (setq name (pop plist))
 257       (setq value (pop plist))
 258       (cond ((eq name :char)
 259              (insert ":char\t")
 260              (cond ((numberp value)
 261                     (setq value (decode-char 'ucs value)))
 262                    ;; ((consp value)
 263                    ;;  (setq value (or (find-char value)
 264                    ;;                  value)))
 265                    )
 266              (char-db-insert-char-spec value readable)
 267              (insert line-breaking))
 268             (t
 269              (insert (format "%s\t%S%s"
 270                              name value
 271                              line-breaking))))
 272       ))
 273   (insert ")"))
 274
 275 (defun char-db-decode-isolated-char (ccs code-point)
 276   (let (ret)
 277     (setq ret
 278           (cond ((eq ccs 'arabic-iso8859-6)
 279                  (decode-char ccs code-point))
 280                 ((and (memq ccs '(ideograph-gt-pj-1
 281                                   ideograph-gt-pj-2
 282                                   ideograph-gt-pj-3
 283                                   ideograph-gt-pj-4
 284                                   ideograph-gt-pj-5
 285                                   ideograph-gt-pj-6
 286                                   ideograph-gt-pj-7
 287                                   ideograph-gt-pj-8
 288                                   ideograph-gt-pj-9
 289                                   ideograph-gt-pj-10
 290                                   ideograph-gt-pj-11))
 291                       (setq ret (decode-char ccs code-point))
 292                       (setq ret (get-char-attribute ret 'ideograph-gt)))
 293                  (decode-builtin-char 'ideograph-gt ret))
 294                 (t
 295                  (decode-builtin-char ccs code-point))))
 296     (cond ((and (<= 0 (char-int ret))
 297                 (<= (char-int ret) #x1F))
 298            (decode-char 'ucs (+ #x2400 (char-int ret))))
 299           ((= (char-int ret) #x7F)
 300            ?\u2421)
 301           (t ret))))
 302
 303 (defvar char-db-convert-obsolete-format t)
 304
 305 (defun insert-char-attributes (char &optional readable
 306                                     attributes ccs-attributes
 307                                     column)
 308   (setq attributes
 309         (sort (if attributes
 310                   (if (consp attributes)
 311                       (copy-sequence attributes))
 312                 (char-attribute-list))
 313               #'char-attribute-name<))
 314   (setq ccs-attributes
 315         (sort (if ccs-attributes
 316                   (copy-sequence ccs-attributes)
 317                 (charset-list))
 318               #'char-attribute-name<))
 319   (unless column
 320     (setq column (current-column)))
 321   (let (name value has-long-ccs-name rest
 322         radical strokes
 323         (line-breaking
 324          (concat "\n" (make-string (1+ column) ?\ )))
 325         lbs cell separator ret
 326         key al cal)
 327     (insert "(")
 328     (when (and (memq 'name attributes)
 329                (setq value (get-char-attribute char 'name)))
 330       (insert (format
 331                (if (> (+ (current-column) (length value)) 48)
 332                    "(name . %S)%s"
 333                  "(name               . %S)%s")
 334                value line-breaking))
 335       (setq attributes (delq 'name attributes))
 336       )
 337     (when (and (memq 'script attributes)
 338                (setq value (get-char-attribute char 'script)))
 339       (insert (format "(script\t\t%s)%s"
 340                       (mapconcat (function prin1-to-string)
 341                                  value " ")
 342                       line-breaking))
 343       (setq attributes (delq 'script attributes))
 344       )
 345     (when (and (memq '=>ucs attributes)
 346                (setq value (get-char-attribute char '=>ucs)))
 347       (insert (format "(=>ucs\t\t. #x%04X)\t; %c%s"
 348                       value (decode-char 'ucs value)
 349                       line-breaking))
 350       (setq attributes (delq '=>ucs attributes))
 351       )
 352     (when (and (memq '->ucs attributes)
 353                (setq value (get-char-attribute char '->ucs)))
 354       (insert (format (if char-db-convert-obsolete-format
 355                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 356                         "(->ucs\t\t. #x%04X)\t; %c%s")
 357                       value (decode-char 'ucs value)
 358                       line-breaking))
 359       (setq attributes (delq '->ucs attributes))
 360       )
 361     (when (and (memq 'general-category attributes)
 362                (setq value (get-char-attribute char 'general-category)))
 363       (insert (format
 364                "(general-category\t%s) ; %s%s"
 365                (mapconcat (lambda (cell)
 366                             (format "%S" cell))
 367                           value " ")
 368                (cond ((rassoc value unidata-normative-category-alist)
 369                       "Normative Category")
 370                      ((rassoc value unidata-informative-category-alist)
 371                       "Informative Category")
 372                      (t
 373                       "Unknown Category"))
 374                line-breaking))
 375       (setq attributes (delq 'general-category attributes))
 376       )
 377     (when (and (memq 'bidi-category attributes)
 378                (setq value (get-char-attribute char 'bidi-category)))
 379       (insert (format "(bidi-category\t. %S)%s"
 380                       value
 381                       line-breaking))
 382       (setq attributes (delq 'bidi-category attributes))
 383       )
 384     (unless (or (not (memq 'mirrored attributes))
 385                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 386                     'empty))
 387       (insert (format "(mirrored\t\t. %S)%s"
 388                       value
 389                       line-breaking))
 390       (setq attributes (delq 'mirrored attributes))
 391       )
 392     (cond
 393      ((and (memq 'decimal-digit-value attributes)
 394            (setq value (get-char-attribute char 'decimal-digit-value)))
 395       (insert (format "(decimal-digit-value . %S)%s"
 396                       value
 397                       line-breaking))
 398       (setq attributes (delq 'decimal-digit-value attributes))
 399       (when (and (memq 'digit-value attributes)
 400                  (setq value (get-char-attribute char 'digit-value)))
 401         (insert (format "(digit-value\t . %S)%s"
 402                         value
 403                         line-breaking))
 404         (setq attributes (delq 'digit-value attributes))
 405         )
 406       (when (and (memq 'numeric-value attributes)
 407                  (setq value (get-char-attribute char 'numeric-value)))
 408         (insert (format "(numeric-value\t . %S)%s"
 409                         value
 410                         line-breaking))
 411         (setq attributes (delq 'numeric-value attributes))
 412         )
 413       )
 414      (t
 415       (when (and (memq 'digit-value attributes)
 416                  (setq value (get-char-attribute char 'digit-value)))
 417         (insert (format "(digit-value\t. %S)%s"
 418                         value
 419                         line-breaking))
 420         (setq attributes (delq 'digit-value attributes))
 421         )
 422       (when (and (memq 'numeric-value attributes)
 423                  (setq value (get-char-attribute char 'numeric-value)))
 424         (insert (format "(numeric-value\t. %S)%s"
 425                         value
 426                         line-breaking))
 427         (setq attributes (delq 'numeric-value attributes))
 428         )))
 429     (when (and (memq 'iso-10646-comment attributes)
 430                (setq value (get-char-attribute char 'iso-10646-comment)))
 431       (insert (format "(iso-10646-comment\t. %S)%s"
 432                       value
 433                       line-breaking))
 434       (setq attributes (delq 'iso-10646-comment attributes))
 435       )
 436     (when (and (memq 'morohashi-daikanwa attributes)
 437                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 438       (insert (format "(morohashi-daikanwa\t%s)%s"
 439                       (mapconcat (function prin1-to-string) value " ")
 440                       line-breaking))
 441       (setq attributes (delq 'morohashi-daikanwa attributes))
 442       )
 443     (setq radical nil
 444           strokes nil)
 445     (when (and (memq 'ideographic-radical attributes)
 446                (setq value (get-char-attribute char 'ideographic-radical)))
 447       (setq radical value)
 448       (insert (format "(ideographic-radical . %S)\t; %c%s"
 449                       radical
 450                       (aref ideographic-radicals radical)
 451                       line-breaking))
 452       (setq attributes (delq 'ideographic-radical attributes))
 453       )
 454     (when (and (memq 'ideographic-strokes attributes)
 455                (setq value (get-char-attribute char 'ideographic-strokes)))
 456       (setq strokes value)
 457       (insert (format "(ideographic-strokes . %S)%s"
 458                       strokes
 459                       line-breaking))
 460       (setq attributes (delq 'ideographic-strokes attributes))
 461       )
 462     (when (and (memq 'kangxi-radical attributes)
 463                (setq value (get-char-attribute char 'kangxi-radical)))
 464       (unless (eq value radical)
 465         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 466                         value
 467                         (aref ideographic-radicals value)
 468                         line-breaking))
 469         (or radical
 470             (setq radical value)))
 471       (setq attributes (delq 'kangxi-radical attributes))
 472       )
 473     (when (and (memq 'kangxi-strokes attributes)
 474                (setq value (get-char-attribute char 'kangxi-strokes)))
 475       (unless (eq value strokes)
 476         (insert (format "(kangxi-strokes\t . %S)%s"
 477                         value
 478                         line-breaking))
 479         (or strokes
 480             (setq strokes value)))
 481       (setq attributes (delq 'kangxi-strokes attributes))
 482       )
 483     (when (and (memq 'japanese-radical attributes)
 484                (setq value (get-char-attribute char 'japanese-radical)))
 485       (unless (eq value radical)
 486         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 487                         value
 488                         (aref ideographic-radicals value)
 489                         line-breaking))
 490         (or radical
 491             (setq radical value)))
 492       (setq attributes (delq 'japanese-radical attributes))
 493       )
 494     (when (and (memq 'japanese-strokes attributes)
 495                (setq value (get-char-attribute char 'japanese-strokes)))
 496       (unless (eq value strokes)
 497         (insert (format "(japanese-strokes\t . %S)%s"
 498                         value
 499                         line-breaking))
 500         (or strokes
 501             (setq strokes value)))
 502       (setq attributes (delq 'japanese-strokes attributes))
 503       )
 504     (when (and (memq 'cns-radical attributes)
 505                (setq value (get-char-attribute char 'cns-radical)))
 506       (insert (format "(cns-radical\t . %S)\t; %c%s"
 507                       value
 508                       (aref ideographic-radicals value)
 509                       line-breaking))
 510       (setq attributes (delq 'cns-radical attributes))
 511       )
 512     (when (and (memq 'cns-strokes attributes)
 513                (setq value (get-char-attribute char 'cns-strokes)))
 514       (unless (eq value strokes)
 515         (insert (format "(cns-strokes\t . %S)%s"
 516                         value
 517                         line-breaking))
 518         (or strokes
 519             (setq strokes value)))
 520       (setq attributes (delq 'cns-strokes attributes))
 521       )
 522     (when (and (memq 'shinjigen-1-radical attributes)
 523                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 524       (unless (eq value radical)
 525         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 526                         value
 527                         (aref ideographic-radicals value)
 528                         line-breaking))
 529         (or radical
 530             (setq radical value)))
 531       (setq attributes (delq 'shinjigen-1-radical attributes))
 532       )
 533     (when (and (memq 'total-strokes attributes)
 534                (setq value (get-char-attribute char 'total-strokes)))
 535       (insert (format "(total-strokes       . %S)%s"
 536                       value
 537                       line-breaking))
 538       (setq attributes (delq 'total-strokes attributes))
 539       )
 540     (when (and (memq '->ideograph attributes)
 541                (setq value (get-char-attribute char '->ideograph)))
 542       (insert (format "(->ideograph\t%s)%s"
 543                       (mapconcat (lambda (code)
 544                                    (cond ((symbolp code)
 545                                           (symbol-name code))
 546                                          ((integerp code)
 547                                           (format "#x%04X" code))
 548                                          (t
 549                                           (format "%s %S"
 550                                                   line-breaking code))))
 551                                  value " ")
 552                       line-breaking))
 553       (setq attributes (delq '->ideograph attributes))
 554       )
 555     (when (and (memq '->decomposition attributes)
 556                (setq value (get-char-attribute char '->decomposition)))
 557       (insert (format "(->decomposition\t%s)%s"
 558                       (mapconcat (lambda (code)
 559                                    (cond ((symbolp code)
 560                                           (symbol-name code))
 561                                          ((characterp code)
 562                                           (if readable
 563                                               (format "%S" code)
 564                                             (format "#x%04X"
 565                                                     (char-int code))
 566                                             ))
 567                                          ((integerp code)
 568                                           (format "#x%04X" code))
 569                                          (t
 570                                           (format "%s%S" line-breaking code))))
 571                                  value " ")
 572                       line-breaking))
 573       (setq attributes (delq '->decomposition attributes))
 574       )
 575     (if (equal (get-char-attribute char '->titlecase)
 576                (get-char-attribute char '->uppercase))
 577         (setq attributes (delq '->titlecase attributes)))
 578     (when (and (memq '->mojikyo attributes)
 579                (setq value (get-char-attribute char '->mojikyo)))
 580       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 581                       value (decode-char 'mojikyo value)
 582                       line-breaking))
 583       (setq attributes (delq '->mojikyo attributes))
 584       )
 585     (setq rest ccs-attributes)
 586     (while (and rest
 587                 (progn
 588                   (setq value (get-char-attribute char (car rest)))
 589                   (if value
 590                       (if (>= (length (symbol-name (car rest))) 19)
 591                           (progn
 592                             (setq has-long-ccs-name t)
 593                             nil)
 594                         t)
 595                     t)))
 596       (setq rest (cdr rest)))
 597     (while attributes
 598       (setq name (car attributes))
 599       (if (setq value (get-char-attribute char name))
 600           (cond ((eq name 'jisx0208-1978/4X)
 601                  (insert (format "(%-18s . #x%04X)%s"
 602                                  name value
 603                                  line-breaking)))
 604                 ((memq name '(->lowercase
 605                               ->uppercase ->titlecase
 606                               ->fullwidth <-fullwidth
 607                               ->vulgar-ideograph <-vulgar-ideograph
 608                               ->ancient-ideograph <-ancient-ideograph
 609                               ->original-ideograph <-original-ideograph
 610                               ->simplified-ideograph <-simplified-ideograph
 611                               ->wrong-ideograph <-wrong-ideograph
 612                               ->same-ideograph
 613                               ->ideographic-variants
 614                               ->synonyms
 615                               ->radical <-radical
 616                               ->bopomofo <-bopomofo
 617                               ->ideographic <-ideographic
 618                               ideographic-structure))
 619                  (insert (format "(%-18s%s " name line-breaking))
 620                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 621                        separator nil)
 622                  (while (consp value)
 623                    (setq cell (car value))
 624                    (if (integerp cell)
 625                        (setq cell (decode-char 'ucs cell)))
 626                    (cond ((characterp cell)
 627                           (if separator
 628                               (insert lbs))
 629                           (char-db-insert-char-spec cell readable)
 630                           (setq separator lbs))
 631                          ((consp cell)
 632                           (if separator
 633                               (insert lbs))
 634                           (if (consp (car cell))
 635                               (char-db-insert-char-spec cell readable)
 636                             (char-db-insert-char-reference cell readable))
 637                           (setq separator lbs))
 638                          (t
 639                           (if separator
 640                               (insert separator))
 641                           (insert (prin1-to-string cell))
 642                           (setq separator " ")))
 643                    (setq value (cdr value)))
 644                  (insert ")")
 645                  (insert line-breaking))
 646                 ((memq name '(ideograph=
 647                               original-ideograph-of
 648                               ancient-ideograph-of
 649                               vulgar-ideograph-of
 650                               wrong-ideograph-of
 651                               simplified-ideograph-of
 652                               ideographic-variants
 653                               ideographic-different-form-of))
 654                  (insert (format "(%-18s%s " name line-breaking))
 655                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 656                        separator nil)
 657                  (while (consp value)
 658                    (setq cell (car value))
 659                    (if (and (consp cell)
 660                             (consp (car cell)))
 661                        (progn
 662                          (if separator
 663                              (insert lbs))
 664                          (char-db-insert-alist cell readable)
 665                          (setq separator lbs))
 666                      (if separator
 667                          (insert separator))
 668                      (insert (prin1-to-string cell))
 669                      (setq separator " "))
 670                    (setq value (cdr value)))
 671                  (insert ")")
 672                  (insert line-breaking))
 673                 ((string-match "^->" (symbol-name name))
 674                  (insert
 675                   (format "(%-18s %s)%s"
 676                           name
 677                           (mapconcat (lambda (code)
 678                                        (cond ((symbolp code)
 679                                               (symbol-name code))
 680                                              ((integerp code)
 681                                               (format "#x%04X" code))
 682                                              (t
 683                                               (format "%s%S"
 684                                                       line-breaking code))))
 685                                      value " ")
 686                           line-breaking)))
 687                 ((consp value)
 688                  (insert (format "(%-18s " name))
 689                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 690                        separator nil)
 691                  (while (consp value)
 692                    (setq cell (car value))
 693                    (if (and (consp cell)
 694                             (consp (car cell))
 695                             (setq ret (condition-case nil
 696                                           (find-char cell)
 697                                         (error nil))))
 698                        (progn
 699                          (setq rest cell
 700                                al nil
 701                                cal nil)
 702                          (while rest
 703                            (setq key (car (car rest)))
 704                            (if (find-charset key)
 705                                (setq cal (cons key cal))
 706                              (setq al (cons key al)))
 707                            (setq rest (cdr rest)))
 708                          (if separator
 709                              (insert lbs))
 710                          (insert-char-attributes ret
 711                                                  readable
 712                                                  al cal)
 713                          (setq separator lbs))
 714                      (if separator
 715                          (insert separator))
 716                      (insert (prin1-to-string cell))
 717                      (setq separator " "))
 718                    (setq value (cdr value)))
 719                  (insert ")")
 720                  (insert line-breaking))
 721                 (t
 722                  (insert (format "(%-18s . %S)%s"
 723                                  name value
 724                                  line-breaking)))
 725                 ))
 726       (setq attributes (cdr attributes)))
 727     (while ccs-attributes
 728       (setq name (car ccs-attributes))
 729       (if (and (eq name (charset-name name))
 730                (setq value (get-char-attribute char name)))
 731           (insert
 732            (format
 733             (cond ((memq name '(ideograph-daikanwa ideograph-gt))
 734                    (if has-long-ccs-name
 735                        "(%-26s . %05d)\t; %c%s"
 736                      "(%-18s . %05d)\t; %c%s"))
 737                   ((eq name 'mojikyo)
 738                    (if has-long-ccs-name
 739                        "(%-26s . %06d)\t; %c%s"
 740                      "(%-18s . %06d)\t; %c%s"))
 741                   ((eq name 'ucs)
 742                    (if has-long-ccs-name
 743                        "(%-26s . #x%04X)\t; %c%s"
 744                      "(%-18s . #x%04X)\t; %c%s"))
 745                   (t
 746                    (if has-long-ccs-name
 747                        "(%-26s . #x%02X)\t; %c%s"
 748                      "(%-18s . #x%02X)\t; %c%s")))
 749             name
 750             (if (= (charset-iso-graphic-plane name) 1)
 751                 (logior value
 752                         (cond ((= (charset-dimension name) 1)
 753                                #x80)
 754                               ((= (charset-dimension name) 2)
 755                                #x8080)
 756                               ((= (charset-dimension name) 3)
 757                                #x808080)
 758                               (t 0)))
 759               value)
 760             (char-db-decode-isolated-char name value)
 761             line-breaking)))
 762       (setq ccs-attributes (cdr ccs-attributes)))
 763     (insert ")")))
 764
 765 (defun insert-char-data (char &optional readable
 766                               attributes ccs-attributes)
 767   (save-restriction
 768     (narrow-to-region (point)(point))
 769     (insert "(define-char
 770   '")
 771     (insert-char-attributes char readable
 772                             attributes ccs-attributes)
 773     (insert ")\n")
 774     (goto-char (point-min))
 775     (while (re-search-forward "[ \t]+$" nil t)
 776       (replace-match ""))
 777     (goto-char (point-max))
 778     (tabify (point-min)(point-max))
 779     ))
 780
 781 ;;;###autoload
 782 (defun char-db-update-comment ()
 783   (interactive)
 784   (save-excursion
 785     (goto-char (point-min))
 786     (let (cdef table char)
 787       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 788         (goto-char (match-beginning 1))
 789         (setq cdef (read (current-buffer)))
 790         (when (find-charset (car cdef))
 791           (goto-char (match-end 0))
 792           (setq char
 793                 (if (and
 794                      (not (eq (car cdef) 'ideograph-daikanwa))
 795                      (or (memq (car cdef) '(ascii latin-viscii-upper
 796                                                   latin-viscii-lower
 797                                                   arabic-iso8859-6
 798                                                   japanese-jisx0213-1
 799                                                   japanese-jisx0213-2))
 800                          (= (char-int (charset-iso-final-char (car cdef)))
 801                             0)))
 802                     (apply (function make-char) cdef)
 803                   (if (setq table (charset-mapping-table (car cdef)))
 804                       (set-charset-mapping-table (car cdef) nil))
 805                   (prog1
 806                       (apply (function make-char) cdef)
 807                     (if table
 808                         (set-charset-mapping-table (car cdef) table)))))
 809           (when (not (or (< (char-int char) 32)
 810                          (and (<= 128 (char-int char))
 811                               (< (char-int char) 160))))
 812             (delete-region (point) (point-at-eol))
 813             (insert (format "\t; %c" char)))
 814           )))))
 815
 816 (defun insert-char-data-with-variant (char &optional printable
 817                                            no-ucs-variant
 818                                            script excluded-script)
 819   (insert-char-data char printable)
 820   (let ((variants (or (char-variants char)
 821                       (let ((ucs (get-char-attribute char '->ucs)))
 822                         (if ucs
 823                             (delete char (char-variants (int-char ucs)))))))
 824         variant vs)
 825     (setq variants (sort variants #'<))
 826     (while variants
 827       (setq variant (car variants))
 828       (if (and (or (null script)
 829                    (null (setq vs (get-char-attribute variant 'script)))
 830                    (memq script vs))
 831                (or (null excluded-script)
 832                    (null (setq vs (get-char-attribute variant 'script)))
 833                    (not (memq excluded-script vs))))
 834           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 835               (insert-char-data variant printable)))
 836       (setq variants (cdr variants))
 837       )))
 838
 839 (defun insert-char-range-data (min max &optional script excluded-script)
 840   (let ((code min)
 841         char)
 842     (while (<= code max)
 843       (setq char (decode-char 'ucs code))
 844       (if (get-char-attribute char 'ucs)
 845           (insert-char-data-with-variant char nil 'no-ucs-variant
 846                                          script excluded-script))
 847       (setq code (1+ code))
 848       )))
 849
 850 (defun write-char-range-data-to-file (min max file
 851                                           &optional script excluded-script)
 852   (let ((coding-system-for-write 'utf-8))
 853     (with-temp-buffer
 854       (insert-char-range-data min max script excluded-script)
 855       (write-region (point-min)(point-max) file))))
 856
 857 (defvar what-character-original-window-configuration)
 858
 859 ;;;###autoload
 860 (defun what-char-definition (char)
 861   (interactive (list (char-after)))
 862   (let ((buf (get-buffer-create "*Character Description*"))
 863         (the-buf (current-buffer))
 864         (win-conf (current-window-configuration)))
 865     (pop-to-buffer buf)
 866     (make-local-variable 'what-character-original-window-configuration)
 867     (setq what-character-original-window-configuration win-conf)
 868     (setq buffer-read-only nil)
 869     (erase-buffer)
 870     (condition-case err
 871         (progn
 872           (insert-char-data-with-variant char 'printable)
 873           ;; (char-db-update-comment)
 874           (set-buffer-modified-p nil)
 875           (view-mode the-buf (lambda (buf)
 876                                (set-window-configuration
 877                                 what-character-original-window-configuration)
 878                                ))
 879           (goto-char (point-min)))
 880       (error (progn
 881                (set-window-configuration
 882                 what-character-original-window-configuration)
 883                (signal (car err) (cdr err)))))))
 884
 885 (provide 'char-db-util)
 886
 887 ;;; char-db-util.el ends here