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 ((and (setq ret (get-char-attribute char 'ucs))
 125                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 126                   (setq char-spec (list (cons 'ucs ret)))
 127                   (if (setq ret (get-char-attribute char 'name))
 128                       (setq char-spec (cons (cons 'name ret) char-spec)))
 129                   )
 130                  ((setq ret (split-char char))
 131                   (setq char-spec (list ret))
 132                   (dolist (ccs (delq (car ret) (charset-list)))
 133                     (if (or (and (>= (charset-iso-final-char ccs) ?0)
 134                                  (setq ret (get-char-attribute char ccs)))
 135                             (eq ccs 'ideograph-daikanwa))
 136                         (setq char-spec (cons (cons ccs ret) char-spec))))
 137                   (if (setq ret (get-char-attribute char 'name))
 138                       (setq char-spec (cons (cons 'name ret) char-spec)))
 139                   )))
 140           ((consp char)
 141            (setq char-spec char)
 142            (setq char nil)))
 143     (unless (or char
 144                 (condition-case nil
 145                     (setq char (find-char char-spec))
 146                   (error nil)))
 147       ;; define temporary character
 148       ;;   Current implementation is dirty.
 149       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 150                                          char-spec)))
 151       (remove-char-attribute temp-char 'ideograph-daikanwa)
 152       (setq char temp-char))
 153     (setq al nil
 154           cal nil)
 155     (while char-spec
 156       (setq key (car (car char-spec)))
 157       (if (find-charset key)
 158           (setq cal (cons key cal))
 159         (setq al (cons key al)))
 160       (setq char-spec (cdr char-spec)))
 161     (insert-char-attributes char
 162                             readable
 163                             (or al 'none) cal)
 164     (when temp-char
 165       ;; undefine temporary character
 166       ;;   Current implementation is dirty.
 167       (setq char-spec (char-attribute-alist temp-char))
 168       (while char-spec
 169         (remove-char-attribute temp-char (car (car char-spec)))
 170         (setq char-spec (cdr char-spec))))))
 171
 172 (defun char-db-insert-alist (alist &optional readable column)
 173   (unless column
 174     (setq column (current-column)))
 175   (let ((line-breaking
 176          (concat "\n" (make-string (1+ column) ?\ )))
 177         name value
 178         ret al cal key
 179         lbs cell rest separator)
 180     (insert "(")
 181     (while alist
 182       (setq name (car (car alist))
 183             value (cdr (car alist)))
 184       (cond ((eq name 'char)
 185              (insert "(char . ")
 186              (if (setq ret (condition-case nil
 187                                (find-char value)
 188                              (error nil)))
 189                  (progn
 190                    (setq al nil
 191                          cal nil)
 192                    (while value
 193                      (setq key (car (car value)))
 194                      (if (find-charset key)
 195                          (setq cal (cons key cal))
 196                        (setq al (cons key al)))
 197                      (setq value (cdr value)))
 198                    (insert-char-attributes ret
 199                                            readable
 200                                            (or al 'none) cal))
 201                (insert (prin1-to-string value)))
 202              (insert ")")
 203              (insert line-breaking))
 204             ((consp value)
 205              (insert (format "(%-18s " name))
 206              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 207              (while (consp value)
 208                (setq cell (car value))
 209                (if (and (consp cell)
 210                         (consp (car cell))
 211                         (setq ret (condition-case nil
 212                                       (find-char cell)
 213                                     (error nil)))
 214                         )
 215                    (progn
 216                      (setq rest cell
 217                            al nil
 218                            cal nil)
 219                      (while rest
 220                        (setq key (car (car rest)))
 221                        (if (find-charset key)
 222                            (setq cal (cons key cal))
 223                          (setq al (cons key al)))
 224                        (setq rest (cdr rest)))
 225                      (if separator
 226                          (insert lbs))
 227                      (insert-char-attributes ret
 228                                              readable
 229                                              al cal)
 230                      (setq separator lbs))
 231                  (if separator
 232                      (insert separator))
 233                  (insert (prin1-to-string cell))
 234                  (setq separator " "))
 235                (setq value (cdr value)))
 236              (insert ")")
 237              (insert line-breaking))
 238             (t
 239              (insert (format "(%-18s . %S)%s"
 240                              name value
 241                              line-breaking))))
 242       (setq alist (cdr alist))))
 243   (insert ")"))
 244
 245 (defun char-db-insert-char-reference (plist &optional readable column)
 246   (unless column
 247     (setq column (current-column)))
 248   (let ((line-breaking
 249          (concat "\n" (make-string (1+ column) ?\ )))
 250         name value)
 251     (insert "(")
 252     (while plist
 253       (setq name (pop plist))
 254       (setq value (pop plist))
 255       (cond ((eq name :char)
 256              (insert ":char\t")
 257              (cond ((numberp value)
 258                     (setq value (decode-char 'ucs value)))
 259                    ;; ((consp value)
 260                    ;;  (setq value (or (find-char value)
 261                    ;;                  value)))
 262                    )
 263              (char-db-insert-char-spec value readable)
 264              (insert line-breaking))
 265             (t
 266              (insert (format "%s\t%S%s"
 267                              name value
 268                              line-breaking))))
 269       ))
 270   (insert ")"))
 271
 272 (defun char-db-decode-isolated-char (ccs code-point)
 273   (let (ret)
 274     (setq ret
 275           (cond ((eq ccs 'arabic-iso8859-6)
 276                  (decode-char ccs code-point))
 277                 ((and (memq ccs '(ideograph-gt-pj-1
 278                                   ideograph-gt-pj-2
 279                                   ideograph-gt-pj-3
 280                                   ideograph-gt-pj-4
 281                                   ideograph-gt-pj-5
 282                                   ideograph-gt-pj-6
 283                                   ideograph-gt-pj-7
 284                                   ideograph-gt-pj-8
 285                                   ideograph-gt-pj-9
 286                                   ideograph-gt-pj-10
 287                                   ideograph-gt-pj-11))
 288                       (setq ret (decode-char ccs code-point))
 289                       (setq ret (get-char-attribute ret 'ideograph-gt)))
 290                  (decode-builtin-char 'ideograph-gt ret))
 291                 (t
 292                  (decode-builtin-char ccs code-point))))
 293     (cond ((and (<= 0 (char-int ret))
 294                 (<= (char-int ret) #x1F))
 295            (decode-char 'ucs (+ #x2400 (char-int ret))))
 296           ((= (char-int ret) #x7F)
 297            ?\u2421)
 298           (t ret))))
 299
 300 (defvar char-db-convert-obsolete-format t)
 301
 302 (defun insert-char-attributes (char &optional readable
 303                                     attributes ccs-attributes
 304                                     column)
 305   (setq attributes
 306         (sort (if attributes
 307                   (if (consp attributes)
 308                       (copy-sequence attributes))
 309                 (char-attribute-list))
 310               #'char-attribute-name<))
 311   (setq ccs-attributes
 312         (sort (if ccs-attributes
 313                   (copy-sequence ccs-attributes)
 314                 (charset-list))
 315               #'char-attribute-name<))
 316   (unless column
 317     (setq column (current-column)))
 318   (let (name value has-long-ccs-name rest
 319         radical strokes
 320         (line-breaking
 321          (concat "\n" (make-string (1+ column) ?\ )))
 322         lbs cell separator ret
 323         key al cal)
 324     (insert "(")
 325     (when (and (memq 'name attributes)
 326                (setq value (get-char-attribute char 'name)))
 327       (insert (format
 328                (if (> (+ (current-column) (length value)) 48)
 329                    "(name . %S)%s"
 330                  "(name               . %S)%s")
 331                value line-breaking))
 332       (setq attributes (delq 'name attributes))
 333       )
 334     (when (and (memq 'script attributes)
 335                (setq value (get-char-attribute char 'script)))
 336       (insert (format "(script\t\t%s)%s"
 337                       (mapconcat (function prin1-to-string)
 338                                  value " ")
 339                       line-breaking))
 340       (setq attributes (delq 'script attributes))
 341       )
 342     (when (and (memq '=>ucs attributes)
 343                (setq value (get-char-attribute char '=>ucs)))
 344       (insert (format "(=>ucs\t\t. #x%04X)\t; %c%s"
 345                       value (decode-char 'ucs value)
 346                       line-breaking))
 347       (setq attributes (delq '=>ucs attributes))
 348       )
 349     (when (and (memq '->ucs attributes)
 350                (setq value (get-char-attribute char '->ucs)))
 351       (insert (format (if char-db-convert-obsolete-format
 352                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 353                         "(->ucs\t\t. #x%04X)\t; %c%s")
 354                       value (decode-char 'ucs value)
 355                       line-breaking))
 356       (setq attributes (delq '->ucs attributes))
 357       )
 358     (when (and (memq 'general-category attributes)
 359                (setq value (get-char-attribute char 'general-category)))
 360       (insert (format
 361                "(general-category\t%s) ; %s%s"
 362                (mapconcat (lambda (cell)
 363                             (format "%S" cell))
 364                           value " ")
 365                (cond ((rassoc value unidata-normative-category-alist)
 366                       "Normative Category")
 367                      ((rassoc value unidata-informative-category-alist)
 368                       "Informative Category")
 369                      (t
 370                       "Unknown Category"))
 371                line-breaking))
 372       (setq attributes (delq 'general-category attributes))
 373       )
 374     (when (and (memq 'bidi-category attributes)
 375                (setq value (get-char-attribute char 'bidi-category)))
 376       (insert (format "(bidi-category\t. %S)%s"
 377                       value
 378                       line-breaking))
 379       (setq attributes (delq 'bidi-category attributes))
 380       )
 381     (unless (or (not (memq 'mirrored attributes))
 382                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 383                     'empty))
 384       (insert (format "(mirrored\t\t. %S)%s"
 385                       value
 386                       line-breaking))
 387       (setq attributes (delq 'mirrored attributes))
 388       )
 389     (cond
 390      ((and (memq 'decimal-digit-value attributes)
 391            (setq value (get-char-attribute char 'decimal-digit-value)))
 392       (insert (format "(decimal-digit-value . %S)%s"
 393                       value
 394                       line-breaking))
 395       (setq attributes (delq 'decimal-digit-value attributes))
 396       (when (and (memq 'digit-value attributes)
 397                  (setq value (get-char-attribute char 'digit-value)))
 398         (insert (format "(digit-value\t . %S)%s"
 399                         value
 400                         line-breaking))
 401         (setq attributes (delq 'digit-value attributes))
 402         )
 403       (when (and (memq 'numeric-value attributes)
 404                  (setq value (get-char-attribute char 'numeric-value)))
 405         (insert (format "(numeric-value\t . %S)%s"
 406                         value
 407                         line-breaking))
 408         (setq attributes (delq 'numeric-value attributes))
 409         )
 410       )
 411      (t
 412       (when (and (memq 'digit-value attributes)
 413                  (setq value (get-char-attribute char 'digit-value)))
 414         (insert (format "(digit-value\t. %S)%s"
 415                         value
 416                         line-breaking))
 417         (setq attributes (delq 'digit-value attributes))
 418         )
 419       (when (and (memq 'numeric-value attributes)
 420                  (setq value (get-char-attribute char 'numeric-value)))
 421         (insert (format "(numeric-value\t. %S)%s"
 422                         value
 423                         line-breaking))
 424         (setq attributes (delq 'numeric-value attributes))
 425         )))
 426     (when (and (memq 'iso-10646-comment attributes)
 427                (setq value (get-char-attribute char 'iso-10646-comment)))
 428       (insert (format "(iso-10646-comment\t. %S)%s"
 429                       value
 430                       line-breaking))
 431       (setq attributes (delq 'iso-10646-comment attributes))
 432       )
 433     (when (and (memq 'morohashi-daikanwa attributes)
 434                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 435       (insert (format "(morohashi-daikanwa\t%s)%s"
 436                       (mapconcat (function prin1-to-string) value " ")
 437                       line-breaking))
 438       (setq attributes (delq 'morohashi-daikanwa attributes))
 439       )
 440     (setq radical nil
 441           strokes nil)
 442     (when (and (memq 'ideographic-radical attributes)
 443                (setq value (get-char-attribute char 'ideographic-radical)))
 444       (setq radical value)
 445       (insert (format "(ideographic-radical . %S)\t; %c%s"
 446                       radical
 447                       (aref ideographic-radicals radical)
 448                       line-breaking))
 449       (setq attributes (delq 'ideographic-radical attributes))
 450       )
 451     (when (and (memq 'ideographic-strokes attributes)
 452                (setq value (get-char-attribute char 'ideographic-strokes)))
 453       (setq strokes value)
 454       (insert (format "(ideographic-strokes . %S)%s"
 455                       strokes
 456                       line-breaking))
 457       (setq attributes (delq 'ideographic-strokes attributes))
 458       )
 459     (when (and (memq 'kangxi-radical attributes)
 460                (setq value (get-char-attribute char 'kangxi-radical)))
 461       (unless (eq value radical)
 462         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 463                         value
 464                         (aref ideographic-radicals value)
 465                         line-breaking))
 466         (or radical
 467             (setq radical value)))
 468       (setq attributes (delq 'kangxi-radical attributes))
 469       )
 470     (when (and (memq 'kangxi-strokes attributes)
 471                (setq value (get-char-attribute char 'kangxi-strokes)))
 472       (unless (eq value strokes)
 473         (insert (format "(kangxi-strokes\t . %S)%s"
 474                         value
 475                         line-breaking))
 476         (or strokes
 477             (setq strokes value)))
 478       (setq attributes (delq 'kangxi-strokes attributes))
 479       )
 480     (when (and (memq 'japanese-radical attributes)
 481                (setq value (get-char-attribute char 'japanese-radical)))
 482       (unless (eq value radical)
 483         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 484                         value
 485                         (aref ideographic-radicals value)
 486                         line-breaking))
 487         (or radical
 488             (setq radical value)))
 489       (setq attributes (delq 'japanese-radical attributes))
 490       )
 491     (when (and (memq 'japanese-strokes attributes)
 492                (setq value (get-char-attribute char 'japanese-strokes)))
 493       (unless (eq value strokes)
 494         (insert (format "(japanese-strokes\t . %S)%s"
 495                         value
 496                         line-breaking))
 497         (or strokes
 498             (setq strokes value)))
 499       (setq attributes (delq 'japanese-strokes attributes))
 500       )
 501     (when (and (memq 'cns-radical attributes)
 502                (setq value (get-char-attribute char 'cns-radical)))
 503       (insert (format "(cns-radical\t . %S)\t; %c%s"
 504                       value
 505                       (aref ideographic-radicals value)
 506                       line-breaking))
 507       (setq attributes (delq 'cns-radical attributes))
 508       )
 509     (when (and (memq 'cns-strokes attributes)
 510                (setq value (get-char-attribute char 'cns-strokes)))
 511       (unless (eq value strokes)
 512         (insert (format "(cns-strokes\t . %S)%s"
 513                         value
 514                         line-breaking))
 515         (or strokes
 516             (setq strokes value)))
 517       (setq attributes (delq 'cns-strokes attributes))
 518       )
 519     (when (and (memq 'shinjigen-1-radical attributes)
 520                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 521       (unless (eq value radical)
 522         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 523                         value
 524                         (aref ideographic-radicals value)
 525                         line-breaking))
 526         (or radical
 527             (setq radical value)))
 528       (setq attributes (delq 'shinjigen-1-radical attributes))
 529       )
 530     (when (and (memq 'total-strokes attributes)
 531                (setq value (get-char-attribute char 'total-strokes)))
 532       (insert (format "(total-strokes       . %S)%s"
 533                       value
 534                       line-breaking))
 535       (setq attributes (delq 'total-strokes attributes))
 536       )
 537     (when (and (memq '->ideograph attributes)
 538                (setq value (get-char-attribute char '->ideograph)))
 539       (insert (format "(->ideograph\t%s)%s"
 540                       (mapconcat (lambda (code)
 541                                    (cond ((symbolp code)
 542                                           (symbol-name code))
 543                                          ((integerp code)
 544                                           (format "#x%04X" code))
 545                                          (t
 546                                           (format "%s %S"
 547                                                   line-breaking code))))
 548                                  value " ")
 549                       line-breaking))
 550       (setq attributes (delq '->ideograph attributes))
 551       )
 552     (when (and (memq '->decomposition attributes)
 553                (setq value (get-char-attribute char '->decomposition)))
 554       (insert (format "(->decomposition\t%s)%s"
 555                       (mapconcat (lambda (code)
 556                                    (cond ((symbolp code)
 557                                           (symbol-name code))
 558                                          ((characterp code)
 559                                           (if readable
 560                                               (format "%S" code)
 561                                             (format "#x%04X"
 562                                                     (char-int code))
 563                                             ))
 564                                          ((integerp code)
 565                                           (format "#x%04X" code))
 566                                          (t
 567                                           (format "%s%S" line-breaking code))))
 568                                  value " ")
 569                       line-breaking))
 570       (setq attributes (delq '->decomposition attributes))
 571       )
 572     (if (equal (get-char-attribute char '->titlecase)
 573                (get-char-attribute char '->uppercase))
 574         (setq attributes (delq '->titlecase attributes)))
 575     (when (and (memq '->mojikyo attributes)
 576                (setq value (get-char-attribute char '->mojikyo)))
 577       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 578                       value (decode-char 'mojikyo value)
 579                       line-breaking))
 580       (setq attributes (delq '->mojikyo attributes))
 581       )
 582     (when (and (memq 'hanyu-dazidian-vol attributes)
 583                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 584       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 585                       value line-breaking))
 586       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 587       )
 588     (when (and (memq 'hanyu-dazidian-page attributes)
 589                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 590       (insert (format "(hanyu-dazidian-page . %d)%s"
 591                       value line-breaking))
 592       (setq attributes (delq 'hanyu-dazidian-page attributes))
 593       )
 594     (when (and (memq 'hanyu-dazidian-char attributes)
 595                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 596       (insert (format "(hanyu-dazidian-char . %d)%s"
 597                       value line-breaking))
 598       (setq attributes (delq 'hanyu-dazidian-char attributes))
 599       )
 600     (setq rest ccs-attributes)
 601     (while (and rest
 602                 (progn
 603                   (setq value (get-char-attribute char (car rest)))
 604                   (if value
 605                       (if (>= (length (symbol-name (car rest))) 19)
 606                           (progn
 607                             (setq has-long-ccs-name t)
 608                             nil)
 609                         t)
 610                     t)))
 611       (setq rest (cdr rest)))
 612     (while attributes
 613       (setq name (car attributes))
 614       (if (setq value (get-char-attribute char name))
 615           (cond ((eq name 'jisx0208-1978/4X)
 616                  (insert (format "(%-18s . #x%04X)%s"
 617                                  name value
 618                                  line-breaking)))
 619                 ((memq name '(->lowercase
 620                               ->uppercase ->titlecase
 621                               ->fullwidth <-fullwidth
 622                               ->identical
 623                               ->vulgar-ideograph <-vulgar-ideograph
 624                               ->ancient-ideograph <-ancient-ideograph
 625                               ->original-ideograph <-original-ideograph
 626                               ->simplified-ideograph <-simplified-ideograph
 627                               ->wrong-ideograph <-wrong-ideograph
 628                               ->same-ideograph
 629                               ->ideographic-variants
 630                               ->synonyms
 631                               ->radical <-radical
 632                               ->bopomofo <-bopomofo
 633                               ->ideographic <-ideographic
 634                               ideographic-structure))
 635                  (insert (format "(%-18s%s " name line-breaking))
 636                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 637                        separator nil)
 638                  (while (consp value)
 639                    (setq cell (car value))
 640                    (if (integerp cell)
 641                        (setq cell (decode-char 'ucs cell)))
 642                    (cond ((characterp cell)
 643                           (if separator
 644                               (insert lbs))
 645                           (char-db-insert-char-spec cell readable)
 646                           (setq separator lbs))
 647                          ((consp cell)
 648                           (if separator
 649                               (insert lbs))
 650                           (if (consp (car cell))
 651                               (char-db-insert-char-spec cell readable)
 652                             (char-db-insert-char-reference cell readable))
 653                           (setq separator lbs))
 654                          (t
 655                           (if separator
 656                               (insert separator))
 657                           (insert (prin1-to-string cell))
 658                           (setq separator " ")))
 659                    (setq value (cdr value)))
 660                  (insert ")")
 661                  (insert line-breaking))
 662                 ((memq name '(ideograph=
 663                               original-ideograph-of
 664                               ancient-ideograph-of
 665                               vulgar-ideograph-of
 666                               wrong-ideograph-of
 667                               simplified-ideograph-of
 668                               ideographic-variants
 669                               ideographic-different-form-of))
 670                  (insert (format "(%-18s%s " name line-breaking))
 671                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 672                        separator nil)
 673                  (while (consp value)
 674                    (setq cell (car value))
 675                    (if (and (consp cell)
 676                             (consp (car cell)))
 677                        (progn
 678                          (if separator
 679                              (insert lbs))
 680                          (char-db-insert-alist cell readable)
 681                          (setq separator lbs))
 682                      (if separator
 683                          (insert separator))
 684                      (insert (prin1-to-string cell))
 685                      (setq separator " "))
 686                    (setq value (cdr value)))
 687                  (insert ")")
 688                  (insert line-breaking))
 689                 ((string-match "^->" (symbol-name name))
 690                  (insert
 691                   (format "(%-18s %s)%s"
 692                           name
 693                           (mapconcat (lambda (code)
 694                                        (cond ((symbolp code)
 695                                               (symbol-name code))
 696                                              ((integerp code)
 697                                               (format "#x%04X" code))
 698                                              (t
 699                                               (format "%s%S"
 700                                                       line-breaking code))))
 701                                      value " ")
 702                           line-breaking)))
 703                 ((consp value)
 704                  (insert (format "(%-18s " name))
 705                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 706                        separator nil)
 707                  (while (consp value)
 708                    (setq cell (car value))
 709                    (if (and (consp cell)
 710                             (consp (car cell))
 711                             (setq ret (condition-case nil
 712                                           (find-char cell)
 713                                         (error nil))))
 714                        (progn
 715                          (setq rest cell
 716                                al nil
 717                                cal nil)
 718                          (while rest
 719                            (setq key (car (car rest)))
 720                            (if (find-charset key)
 721                                (setq cal (cons key cal))
 722                              (setq al (cons key al)))
 723                            (setq rest (cdr rest)))
 724                          (if separator
 725                              (insert lbs))
 726                          (insert-char-attributes ret
 727                                                  readable
 728                                                  al cal)
 729                          (setq separator lbs))
 730                      (if separator
 731                          (insert separator))
 732                      (insert (prin1-to-string cell))
 733                      (setq separator " "))
 734                    (setq value (cdr value)))
 735                  (insert ")")
 736                  (insert line-breaking))
 737                 (t
 738                  (insert (format "(%-18s . %S)%s"
 739                                  name value
 740                                  line-breaking)))
 741                 ))
 742       (setq attributes (cdr attributes)))
 743     (while ccs-attributes
 744       (setq name (car ccs-attributes))
 745       (if (and (eq name (charset-name name))
 746                (setq value (get-char-attribute char name)))
 747           (insert
 748            (format
 749             (cond ((memq name '(ideograph-daikanwa ideograph-gt
 750                                                    ideograph-cbeta))
 751                    (if has-long-ccs-name
 752                        "(%-26s . %05d)\t; %c%s"
 753                      "(%-18s . %05d)\t; %c%s"))
 754                   ((eq name 'mojikyo)
 755                    (if has-long-ccs-name
 756                        "(%-26s . %06d)\t; %c%s"
 757                      "(%-18s . %06d)\t; %c%s"))
 758                   ((eq name 'ucs)
 759                    (if has-long-ccs-name
 760                        "(%-26s . #x%04X)\t; %c%s"
 761                      "(%-18s . #x%04X)\t; %c%s"))
 762                   (t
 763                    (if has-long-ccs-name
 764                        "(%-26s . #x%02X)\t; %c%s"
 765                      "(%-18s . #x%02X)\t; %c%s")))
 766             name
 767             (if (= (charset-iso-graphic-plane name) 1)
 768                 (logior value
 769                         (cond ((= (charset-dimension name) 1)
 770                                #x80)
 771                               ((= (charset-dimension name) 2)
 772                                #x8080)
 773                               ((= (charset-dimension name) 3)
 774                                #x808080)
 775                               (t 0)))
 776               value)
 777             (char-db-decode-isolated-char name value)
 778             line-breaking)))
 779       (setq ccs-attributes (cdr ccs-attributes)))
 780     (insert ")")))
 781
 782 (defun insert-char-data (char &optional readable
 783                               attributes ccs-attributes)
 784   (save-restriction
 785     (narrow-to-region (point)(point))
 786     (insert "(define-char
 787   '")
 788     (insert-char-attributes char readable
 789                             attributes ccs-attributes)
 790     (insert ")\n")
 791     (goto-char (point-min))
 792     (while (re-search-forward "[ \t]+$" nil t)
 793       (replace-match ""))
 794     (goto-char (point-max))
 795     (tabify (point-min)(point-max))
 796     ))
 797
 798 ;;;###autoload
 799 (defun char-db-update-comment ()
 800   (interactive)
 801   (save-excursion
 802     (goto-char (point-min))
 803     (let (cdef table char)
 804       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 805         (goto-char (match-beginning 1))
 806         (setq cdef (read (current-buffer)))
 807         (when (find-charset (car cdef))
 808           (goto-char (match-end 0))
 809           (setq char
 810                 (if (and
 811                      (not (eq (car cdef) 'ideograph-daikanwa))
 812                      (or (memq (car cdef) '(ascii latin-viscii-upper
 813                                                   latin-viscii-lower
 814                                                   arabic-iso8859-6
 815                                                   japanese-jisx0213-1
 816                                                   japanese-jisx0213-2))
 817                          (= (char-int (charset-iso-final-char (car cdef)))
 818                             0)))
 819                     (apply (function make-char) cdef)
 820                   (if (setq table (charset-mapping-table (car cdef)))
 821                       (set-charset-mapping-table (car cdef) nil))
 822                   (prog1
 823                       (apply (function make-char) cdef)
 824                     (if table
 825                         (set-charset-mapping-table (car cdef) table)))))
 826           (when (not (or (< (char-int char) 32)
 827                          (and (<= 128 (char-int char))
 828                               (< (char-int char) 160))))
 829             (delete-region (point) (point-at-eol))
 830             (insert (format "\t; %c" char)))
 831           )))))
 832
 833 (defun insert-char-data-with-variant (char &optional printable
 834                                            no-ucs-variant
 835                                            script excluded-script)
 836   (insert-char-data char printable)
 837   (let ((variants (or (char-variants char)
 838                       (let ((ucs (get-char-attribute char '->ucs)))
 839                         (if ucs
 840                             (delete char (char-variants (int-char ucs)))))))
 841         variant vs)
 842     (setq variants (sort variants #'<))
 843     (while variants
 844       (setq variant (car variants))
 845       (if (and (or (null script)
 846                    (null (setq vs (get-char-attribute variant 'script)))
 847                    (memq script vs))
 848                (or (null excluded-script)
 849                    (null (setq vs (get-char-attribute variant 'script)))
 850                    (not (memq excluded-script vs))))
 851           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 852               (insert-char-data variant printable)))
 853       (setq variants (cdr variants))
 854       )))
 855
 856 (defun insert-char-range-data (min max &optional script excluded-script)
 857   (let ((code min)
 858         char)
 859     (while (<= code max)
 860       (setq char (decode-char 'ucs code))
 861       (if (get-char-attribute char 'ucs)
 862           (insert-char-data-with-variant char nil 'no-ucs-variant
 863                                          script excluded-script))
 864       (setq code (1+ code))
 865       )))
 866
 867 (defun write-char-range-data-to-file (min max file
 868                                           &optional script excluded-script)
 869   (let ((coding-system-for-write 'utf-8))
 870     (with-temp-buffer
 871       (insert-char-range-data min max script excluded-script)
 872       (write-region (point-min)(point-max) file))))
 873
 874 (defvar what-character-original-window-configuration)
 875
 876 ;;;###autoload
 877 (defun what-char-definition (char)
 878   (interactive (list (char-after)))
 879   (let ((buf (get-buffer-create "*Character Description*"))
 880         (the-buf (current-buffer))
 881         (win-conf (current-window-configuration)))
 882     (pop-to-buffer buf)
 883     (make-local-variable 'what-character-original-window-configuration)
 884     (setq what-character-original-window-configuration win-conf)
 885     (setq buffer-read-only nil)
 886     (erase-buffer)
 887     (condition-case err
 888         (progn
 889           (insert-char-data-with-variant char 'printable)
 890           ;; (char-db-update-comment)
 891           (set-buffer-modified-p nil)
 892           (view-mode the-buf (lambda (buf)
 893                                (set-window-configuration
 894                                 what-character-original-window-configuration)
 895                                ))
 896           (goto-char (point-min)))
 897       (error (progn
 898                (set-window-configuration
 899                 what-character-original-window-configuration)
 900                (signal (car err) (cdr err)))))))
 901
 902 (provide 'char-db-util)
 903
 904 ;;; char-db-util.el ends here