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 UTF-2000.
   9
  10 ;; UTF-2000 is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; UTF-2000 is distributed in the hope that it will be useful, but
  16 ;; 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; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 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" line-breaking code))))
 428                                  value " ")
 429                       line-breaking))
 430       (setq attributes (delq '->ideograph attributes))
 431       )
 432     (when (and (memq '->decomposition attributes)
 433                (setq value (get-char-attribute char '->decomposition)))
 434       (insert (format "(->decomposition\t%s)%s"
 435                       (mapconcat (lambda (code)
 436                                    (cond ((symbolp code)
 437                                           (symbol-name code))
 438                                          ((characterp code)
 439                                           (if readable
 440                                               (format "%S" code)
 441                                             (format "#x%04X"
 442                                                     (char-int code))
 443                                             ))
 444                                          ((integerp code)
 445                                           (format "#x%04X" code))
 446                                          (t
 447                                           (format "%s%S" line-breaking code))))
 448                                  value " ")
 449                       line-breaking))
 450       (setq attributes (delq '->decomposition attributes))
 451       )
 452     (when (and (memq '->uppercase attributes)
 453                (setq value (get-char-attribute char '->uppercase)))
 454       (insert (format "(->uppercase\t%s)%s"
 455                       (mapconcat (lambda (code)
 456                                    (cond ((symbolp code)
 457                                           (symbol-name code))
 458                                          ((integerp code)
 459                                           (format "#x%04X" code))
 460                                          (t
 461                                           (format "%s%S" line-breaking code))))
 462                                  value " ")
 463                       line-breaking))
 464       (setq attributes (delq '->uppercase attributes))
 465       )
 466     (when (and (memq '->lowercase attributes)
 467                (setq value (get-char-attribute char '->lowercase)))
 468       (insert (format "(->lowercase\t%s)%s"
 469                       (mapconcat (lambda (code)
 470                                    (cond ((symbolp code)
 471                                           (symbol-name code))
 472                                          ((integerp code)
 473                                           (format "#x%04X" code))
 474                                          (t
 475                                           (format "%s%S" line-breaking code))))
 476                                  value " ")
 477                       line-breaking))
 478       (setq attributes (delq '->lowercase attributes))
 479       )
 480     (when (and (memq '->titlecase attributes)
 481                (setq value (get-char-attribute char '->titlecase)))
 482       (insert (format "(->titlecase\t%s)%s"
 483                       (mapconcat (lambda (code)
 484                                    (cond ((symbolp code)
 485                                           (symbol-name code))
 486                                          ((integerp code)
 487                                           (format "#x%04X" code))
 488                                          (t
 489                                           (format "%s%S" line-breaking code))))
 490                                  value " ")
 491                       line-breaking))
 492       (setq attributes (delq '->titlecase attributes))
 493       )
 494     (when (and (memq '->mojikyo attributes)
 495                (setq value (get-char-attribute char '->mojikyo)))
 496       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 497                       value (decode-char 'mojikyo value)
 498                       line-breaking))
 499       (setq attributes (delq '->mojikyo attributes))
 500       )
 501     (setq rest ccs-attributes)
 502     (while (and rest
 503                 (progn
 504                   (setq value (get-char-attribute char (car rest)))
 505                   (if value
 506                       (if (>= (length (symbol-name (car rest))) 19)
 507                           (progn
 508                             (setq has-long-ccs-name t)
 509                             nil)
 510                         t)
 511                     t)))
 512       (setq rest (cdr rest)))
 513     (while attributes
 514       (setq name (car attributes))
 515       (if (setq value (get-char-attribute char name))
 516           (cond ((eq name 'jisx0208-1978/4X)
 517                  (insert (format "(%-18s . #x%04X)%s"
 518                                  name value
 519                                  line-breaking)))
 520                 ((string-match "^->" (symbol-name name))
 521                  (insert
 522                   (format "(%-18s %s)%s"
 523                           name
 524                           (mapconcat (lambda (code)
 525                                        (cond ((symbolp code)
 526                                               (symbol-name code))
 527                                              ((integerp code)
 528                                               (format "#x%04X" code))
 529                                              (t
 530                                               (format "%s%S"
 531                                                       line-breaking code))))
 532                                      value " ")
 533                           line-breaking)))
 534                 ((memq name '(ideograph=
 535                               original-ideograph-of
 536                               ancient-ideograph-of
 537                               vulgar-ideograph-of
 538                               wrong-ideograph-of
 539                               simplified-ideograph-of
 540                               ideographic-variants
 541                               ideographic-different-form-of))
 542                  (insert (format "(%-18s%s " name line-breaking))
 543                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 544                        separator nil)
 545                  (while (consp value)
 546                    (setq cell (car value))
 547                    (if (and (consp cell)
 548                             (consp (car cell)))
 549                        (progn
 550                          (if separator
 551                              (insert lbs))
 552                          (char-db-insert-alist cell readable)
 553                          (setq separator lbs))
 554                      (if separator
 555                          (insert separator))
 556                      (insert (prin1-to-string cell))
 557                      (setq separator " "))
 558                    (setq value (cdr value)))
 559                  (insert ")")
 560                  (insert line-breaking))
 561                 ((consp value)
 562                  (insert (format "(%-18s " name))
 563                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 564                        separator nil)
 565                  (while (consp value)
 566                    (setq cell (car value))
 567                    (if (and (consp cell)
 568                             (consp (car cell))
 569                             (setq ret (condition-case nil
 570                                           (define-char cell)
 571                                         (error nil))))
 572                        (progn
 573                          (setq rest cell
 574                                al nil
 575                                cal nil)
 576                          (while rest
 577                            (setq key (car (car rest)))
 578                            (if (find-charset key)
 579                                (setq cal (cons key cal))
 580                              (setq al (cons key al)))
 581                            (setq rest (cdr rest)))
 582                          (if separator
 583                              (insert lbs))
 584                          (insert-char-attributes ret
 585                                                  readable
 586                                                  al cal)
 587                          (setq separator lbs))
 588                      (if separator
 589                          (insert separator))
 590                      (insert (prin1-to-string cell))
 591                      (setq separator " "))
 592                    (setq value (cdr value)))
 593                  (insert ")")
 594                  (insert line-breaking))
 595                 (t
 596                  (insert (format "(%-18s . %S)%s"
 597                                  name value
 598                                  line-breaking)))
 599                 ))
 600       (setq attributes (cdr attributes)))
 601     (while ccs-attributes
 602       (setq name (car ccs-attributes))
 603       (if (setq value (get-char-attribute char name))
 604           (insert
 605            (format
 606             (cond ((memq name '(ideograph-daikanwa ideograph-gt))
 607                    (if has-long-ccs-name
 608                        "(%-26s . %05d)\t; %c%s"
 609                      "(%-18s . %05d)\t; %c%s"))
 610                   ((eq name 'mojikyo)
 611                    (if has-long-ccs-name
 612                        "(%-26s . %06d)\t; %c%s"
 613                      "(%-18s . %06d)\t; %c%s"))
 614                   (t
 615                    (if has-long-ccs-name
 616                        "(%-26s . #x%X)\t; %c%s"
 617                      "(%-18s . #x%X)\t; %c%s")))
 618             name
 619             (if (= (charset-iso-graphic-plane name) 1)
 620                 (logior value
 621                         (cond ((= (charset-dimension name) 1)
 622                                #x80)
 623                               ((= (charset-dimension name) 2)
 624                                #x8080)
 625                               ((= (charset-dimension name) 3)
 626                                #x808080)
 627                               (t 0)))
 628               value)
 629             (if (and (memq name '(ideograph-gt-pj-1
 630                                   ideograph-gt-pj-2
 631                                   ideograph-gt-pj-3
 632                                   ideograph-gt-pj-4
 633                                   ideograph-gt-pj-5
 634                                   ideograph-gt-pj-6
 635                                   ideograph-gt-pj-7
 636                                   ideograph-gt-pj-8
 637                                   ideograph-gt-pj-9
 638                                   ideograph-gt-pj-10
 639                                   ideograph-gt-pj-11))
 640                      (setq ret (decode-char name value))
 641                      (setq ret (get-char-attribute ret 'ideograph-gt)))
 642                 (decode-builtin-char 'ideograph-gt ret)
 643               (decode-builtin-char name value))
 644             line-breaking)))
 645       (setq ccs-attributes (cdr ccs-attributes)))
 646     (insert ")")))
 647
 648 (defun insert-char-data (char &optional readable
 649                               attributes ccs-attributes)
 650   (save-restriction
 651     (narrow-to-region (point)(point))
 652     (insert "(define-char
 653   '")
 654     (insert-char-attributes char readable
 655                             attributes ccs-attributes)
 656     (insert ")\n")
 657     (goto-char (point-min))
 658     (while (re-search-forward "[ \t]+$" nil t)
 659       (replace-match ""))
 660     (goto-char (point-max))
 661     (tabify (point-min)(point-max))
 662     ))
 663
 664 ;;;###autoload
 665 (defun char-db-update-comment ()
 666   (interactive)
 667   (save-excursion
 668     (goto-char (point-min))
 669     (let (cdef table char)
 670       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 671         (goto-char (match-beginning 1))
 672         (setq cdef (read (current-buffer)))
 673         (when (find-charset (car cdef))
 674           (goto-char (match-end 0))
 675           (setq char
 676                 (if (and
 677                      (not (eq (car cdef) 'ideograph-daikanwa))
 678                      (or (memq (car cdef) '(ascii latin-viscii-upper
 679                                                   latin-viscii-lower
 680                                                   arabic-iso8859-6
 681                                                   japanese-jisx0213-1
 682                                                   japanese-jisx0213-2))
 683                          (= (char-int (charset-iso-final-char (car cdef)))
 684                             0)))
 685                     (apply (function make-char) cdef)
 686                   (if (setq table (charset-mapping-table (car cdef)))
 687                       (set-charset-mapping-table (car cdef) nil))
 688                   (prog1
 689                       (apply (function make-char) cdef)
 690                     (if table
 691                         (set-charset-mapping-table (car cdef) table)))))
 692           (when (not (or (< (char-int char) 32)
 693                          (and (<= 128 (char-int char))
 694                               (< (char-int char) 160))))
 695             (delete-region (point) (point-at-eol))
 696             (insert (format "\t; %c" char)))
 697           )))))
 698
 699 (defun insert-char-data-with-variant (char &optional script printable
 700                                            no-ucs-variant)
 701   (insert-char-data char printable)
 702   (let ((variants (or (char-variants char)
 703                       (let ((ucs (get-char-attribute char '->ucs)))
 704                         (if ucs
 705                             (delete char (char-variants (int-char ucs)))))))
 706         variant vs)
 707     (while variants
 708       (setq variant (car variants))
 709       (if (or (null script)
 710               (null (setq vs (get-char-attribute variant 'script)))
 711               (memq script vs))
 712           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 713               (insert-char-data variant printable)))
 714       (setq variants (cdr variants))
 715       )))
 716
 717 (defun insert-char-range-data (min max &optional script)
 718   (let ((code min)
 719         char)
 720     (while (<= code max)
 721       (setq char (decode-char 'ucs code))
 722       (if (get-char-attribute char 'ucs)
 723           (insert-char-data-with-variant char script nil 'no-ucs-variant))
 724       (setq code (1+ code))
 725       )))
 726
 727 (defun write-char-range-data-to-file (min max file &optional script)
 728   (let ((coding-system-for-write 'utf-8))
 729     (with-temp-buffer
 730       (insert-char-range-data min max script)
 731       (write-region (point-min)(point-max) file))))
 732
 733 (defvar what-character-original-window-configuration)
 734
 735 ;;;###autoload
 736 (defun what-char-definition (char)
 737   (interactive (list (char-after)))
 738   (let ((buf (get-buffer-create "*Character Description*"))
 739         (the-buf (current-buffer))
 740         (win-conf (current-window-configuration)))
 741     (pop-to-buffer buf)
 742     (make-local-variable 'what-character-original-window-configuration)
 743     (setq what-character-original-window-configuration win-conf)
 744     (setq buffer-read-only nil)
 745     (erase-buffer)
 746     (condition-case err
 747         (progn
 748           (insert-char-data-with-variant char nil 'printable)
 749           ;; (char-db-update-comment)
 750           (set-buffer-modified-p nil)
 751           (view-mode the-buf (lambda (buf)
 752                                (set-window-configuration
 753                                 what-character-original-window-configuration)
 754                                ))
 755           (goto-char (point-min)))
 756       (error (progn
 757                (set-window-configuration
 758                 what-character-original-window-configuration)
 759                (signal (car err) (cdr err)))))))
 760
 761 (provide 'char-db-util)
 762
 763 ;;; char-db-util.el ends here