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