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