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