git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility
   2
   3 ;; Copyright (C) 1998,1999,2000,2001 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'alist)
  28
  29 (defconst unidata-normative-category-alist
  30   '(("Lu" letter        uppercase)
  31     ("Ll" letter        lowercase)
  32     ("Lt" letter        titlecase)
  33     ("Mn" mark          non-spacing)
  34     ("Mc" mark          spacing-combining)
  35     ("Me" mark          enclosing)
  36     ("Nd" number        decimal-digit)
  37     ("Nl" number        letter)
  38     ("No" number        other)
  39     ("Zs" separator     space)
  40     ("Zl" separator     line)
  41     ("Zp" separator     paragraph)
  42     ("Cc" other         control)
  43     ("Cf" other         format)
  44     ("Cs" other         surrogate)
  45     ("Co" other         private-use)
  46     ("Cn" other         not-assigned)))
  47
  48 (defconst unidata-informative-category-alist
  49   '(("Lm" letter        modifier)
  50     ("Lo" letter        other)
  51     ("Pc" punctuation   connector)
  52     ("Pd" punctuation   dash)
  53     ("Ps" punctuation   open)
  54     ("Pe" punctuation   close)
  55     ("Pi" punctuation   initial-quote)
  56     ("Pf" punctuation   final-quote)
  57     ("Po" punctuation   other)
  58     ("Sm" symbol        math)
  59     ("Sc" symbol        currency)
  60     ("Sk" symbol        modifier)
  61     ("So" symbol        other)
  62     ))
  63
  64 (defconst ideographic-radicals
  65   (let ((v (make-vector 215 nil))
  66         (i 1))
  67     (while (< i 215)
  68       (aset v i (int-char (+ #x2EFF i)))
  69       (setq i (1+ i)))
  70     (if (< (charset-iso-final-char (car (split-char (aref v 34)))) ?0)
  71         (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
  72     v))
  73
  74 (defun char-attribute-name< (ka kb)
  75   (cond
  76    ((find-charset ka)
  77     (cond
  78      ((find-charset kb)
  79       (cond
  80        ((= (charset-dimension ka)
  81            (charset-dimension kb))
  82         (cond ((= (charset-chars ka)(charset-chars kb))
  83                (cond
  84                 ((>= (charset-iso-final-char ka) ?@)
  85                  (if (>= (charset-iso-final-char kb) ?@)
  86                      (< (charset-iso-final-char ka)
  87                         (charset-iso-final-char kb))
  88                    t))
  89                 ((>= (charset-iso-final-char ka) ?0)
  90                  (cond
  91                   ((>= (charset-iso-final-char kb) ?@)
  92                    nil)
  93                   ((>= (charset-iso-final-char kb) ?0)
  94                    (< (charset-iso-final-char ka)
  95                       (charset-iso-final-char kb)))
  96                   (t)))
  97                 (t (if (>= (charset-iso-final-char kb) ?0)
  98                        nil
  99                      (> (charset-id ka)(charset-id kb))))))
 100               ((<= (charset-chars ka)(charset-chars kb)))))
 101        (t
 102         (< (charset-dimension ka)
 103            (charset-dimension kb))
 104         )))
 105      ((symbolp kb)
 106       nil)
 107      (t
 108       t)))
 109    ((find-charset kb)
 110     t)
 111    ((symbolp ka)
 112     (cond ((symbolp kb)
 113            (string< (symbol-name ka)
 114                     (symbol-name kb)))
 115           (t)))
 116    ((symbolp kb)
 117     nil)))
 118
 119 (defun char-db-insert-char-spec (char &optional readable column)
 120   (unless column
 121     (setq column (current-column)))
 122   (let (char-spec ret al cal key)
 123     (cond ((characterp char)
 124            (cond ((setq ret (get-char-attribute char 'ucs))
 125                   (setq char-spec (list (cons 'ucs ret)))
 126                   (if (setq ret (get-char-attribute char 'name))
 127                       (setq char-spec (cons (cons 'name ret) char-spec)))
 128                   )
 129                  ((setq ret (split-char char))
 130                   (setq char-spec (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-spec (cons (cons ccs ret) char-spec))))
 135                   (if (setq ret (get-char-attribute char 'name))
 136                       (setq char-spec (cons (cons 'name ret) char-spec)))
 137                   )))
 138           ((consp char)
 139            (setq char-spec char)
 140            (setq char nil)))
 141     (if (or char
 142             (setq char (condition-case nil
 143                            (define-char char-spec)
 144                          (error nil))))
 145         (progn
 146           (setq al nil
 147                 cal nil)
 148           (while char-spec
 149             (setq key (car (car char-spec)))
 150             (if (find-charset key)
 151                 (setq cal (cons key cal))
 152               (setq al (cons key al)))
 153             (setq char-spec (cdr char-spec)))
 154           (insert-char-attributes char
 155                                   readable
 156                                   (or al 'none) cal))
 157       (insert (prin1-to-string char-spec)))))
 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-reference (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              (if (numberp value)
 245                  (setq value (decode-char 'ucs value)))
 246              (char-db-insert-char-spec value readable)
 247              (insert line-breaking))
 248             (t
 249              (insert (format "%s\t%S%s"
 250                              name value
 251                              line-breaking))))
 252       ))
 253   (insert ")"))
 254
 255 (defun char-db-decode-isolated-char (ccs code-point)
 256   (let (ret)
 257     (setq ret
 258           (cond ((eq ccs 'arabic-iso8859-6)
 259                  (decode-char ccs code-point))
 260                 ((and (memq ccs '(ideograph-gt-pj-1
 261                                   ideograph-gt-pj-2
 262                                   ideograph-gt-pj-3
 263                                   ideograph-gt-pj-4
 264                                   ideograph-gt-pj-5
 265                                   ideograph-gt-pj-6
 266                                   ideograph-gt-pj-7
 267                                   ideograph-gt-pj-8
 268                                   ideograph-gt-pj-9
 269                                   ideograph-gt-pj-10
 270                                   ideograph-gt-pj-11))
 271                       (setq ret (decode-char ccs code-point))
 272                       (setq ret (get-char-attribute ret 'ideograph-gt)))
 273                  (decode-builtin-char 'ideograph-gt ret))
 274                 (t
 275                  (decode-builtin-char ccs code-point))))
 276     (cond ((and (<= 0 (char-int ret))
 277                 (<= (char-int ret) #x1F))
 278            (decode-char 'ucs (+ #x2400 (char-int ret))))
 279           ((= (char-int ret) #x7F)
 280            ?\u2421)
 281           (t ret))))
 282
 283 (defvar char-db-convert-obsolete-format t)
 284
 285 (defun insert-char-attributes (char &optional readable
 286                                     attributes ccs-attributes
 287                                     column)
 288   (setq attributes
 289         (sort (if attributes
 290                   (if (consp attributes)
 291                       (copy-sequence attributes))
 292                 (char-attribute-list))
 293               #'char-attribute-name<))
 294   (setq ccs-attributes
 295         (sort (if ccs-attributes
 296                   (copy-sequence ccs-attributes)
 297                 (charset-list))
 298               #'char-attribute-name<))
 299   (unless column
 300     (setq column (current-column)))
 301   (let (name value has-long-ccs-name rest
 302         radical strokes
 303         (line-breaking
 304          (concat "\n" (make-string (1+ column) ?\ )))
 305         lbs cell separator ret
 306         key al cal)
 307     (insert "(")
 308     (when (and (memq 'name attributes)
 309                (setq value (get-char-attribute char 'name)))
 310       (insert (format
 311                (if (> (+ (current-column) (length value)) 48)
 312                    "(name . %S)%s"
 313                  "(name               . %S)%s")
 314                value line-breaking))
 315       (setq attributes (delq 'name attributes))
 316       )
 317     (when (and (memq 'script attributes)
 318                (setq value (get-char-attribute char 'script)))
 319       (insert (format "(script\t\t%s)%s"
 320                       (mapconcat (function prin1-to-string)
 321                                  value " ")
 322                       line-breaking))
 323       (setq attributes (delq 'script 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 '->ucs attributes)
 333                (setq value (get-char-attribute char '->ucs)))
 334       (insert (format (if char-db-convert-obsolete-format
 335                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 336                         "(->ucs\t\t. #x%04X)\t; %c%s")
 337                       value (decode-char 'ucs value)
 338                       line-breaking))
 339       (setq attributes (delq '->ucs attributes))
 340       )
 341     (when (and (memq 'general-category attributes)
 342                (setq value (get-char-attribute char 'general-category)))
 343       (insert (format
 344                "(general-category\t%s) ; %s%s"
 345                (mapconcat (lambda (cell)
 346                             (format "%S" cell))
 347                           value " ")
 348                (cond ((rassoc value unidata-normative-category-alist)
 349                       "Normative Category")
 350                      ((rassoc value unidata-informative-category-alist)
 351                       "Informative Category")
 352                      (t
 353                       "Unknown Category"))
 354                line-breaking))
 355       (setq attributes (delq 'general-category attributes))
 356       )
 357     (when (and (memq 'bidi-category attributes)
 358                (setq value (get-char-attribute char 'bidi-category)))
 359       (insert (format "(bidi-category\t. %S)%s"
 360                       value
 361                       line-breaking))
 362       (setq attributes (delq 'bidi-category attributes))
 363       )
 364     (unless (or (not (memq 'mirrored attributes))
 365                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 366                     'empty))
 367       (insert (format "(mirrored\t\t. %S)%s"
 368                       value
 369                       line-breaking))
 370       (setq attributes (delq 'mirrored attributes))
 371       )
 372     (cond
 373      ((and (memq 'decimal-digit-value attributes)
 374            (setq value (get-char-attribute char 'decimal-digit-value)))
 375       (insert (format "(decimal-digit-value . %S)%s"
 376                       value
 377                       line-breaking))
 378       (setq attributes (delq 'decimal-digit-value attributes))
 379       (when (and (memq 'digit-value attributes)
 380                  (setq value (get-char-attribute char 'digit-value)))
 381         (insert (format "(digit-value\t . %S)%s"
 382                         value
 383                         line-breaking))
 384         (setq attributes (delq 'digit-value attributes))
 385         )
 386       (when (and (memq 'numeric-value attributes)
 387                  (setq value (get-char-attribute char 'numeric-value)))
 388         (insert (format "(numeric-value\t . %S)%s"
 389                         value
 390                         line-breaking))
 391         (setq attributes (delq 'numeric-value attributes))
 392         )
 393       )
 394      (t
 395       (when (and (memq 'digit-value attributes)
 396                  (setq value (get-char-attribute char 'digit-value)))
 397         (insert (format "(digit-value\t. %S)%s"
 398                         value
 399                         line-breaking))
 400         (setq attributes (delq 'digit-value attributes))
 401         )
 402       (when (and (memq 'numeric-value attributes)
 403                  (setq value (get-char-attribute char 'numeric-value)))
 404         (insert (format "(numeric-value\t. %S)%s"
 405                         value
 406                         line-breaking))
 407         (setq attributes (delq 'numeric-value attributes))
 408         )))
 409     (when (and (memq 'iso-10646-comment attributes)
 410                (setq value (get-char-attribute char 'iso-10646-comment)))
 411       (insert (format "(iso-10646-comment\t. %S)%s"
 412                       value
 413                       line-breaking))
 414       (setq attributes (delq 'iso-10646-comment attributes))
 415       )
 416     (when (and (memq 'morohashi-daikanwa attributes)
 417                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 418       (insert (format "(morohashi-daikanwa\t%s)%s"
 419                       (mapconcat (function prin1-to-string) value " ")
 420                       line-breaking))
 421       (setq attributes (delq 'morohashi-daikanwa attributes))
 422       )
 423     (setq radical nil
 424           strokes nil)
 425     (when (and (memq 'ideographic-radical attributes)
 426                (setq value (get-char-attribute char 'ideographic-radical)))
 427       (setq radical value)
 428       (insert (format "(ideographic-radical . %S)\t; %c%s"
 429                       radical
 430                       (aref ideographic-radicals radical)
 431                       line-breaking))
 432       (setq attributes (delq 'ideographic-radical attributes))
 433       )
 434     (when (and (memq 'ideographic-strokes attributes)
 435                (setq value (get-char-attribute char 'ideographic-strokes)))
 436       (setq strokes value)
 437       (insert (format "(ideographic-strokes . %S)%s"
 438                       strokes
 439                       line-breaking))
 440       (setq attributes (delq 'ideographic-strokes attributes))
 441       )
 442     (when (and (memq 'kangxi-radical attributes)
 443                (setq value (get-char-attribute char 'kangxi-radical)))
 444       (unless (eq value radical)
 445         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 446                         value
 447                         (aref ideographic-radicals value)
 448                         line-breaking))
 449         (or radical
 450             (setq radical value)))
 451       (setq attributes (delq 'kangxi-radical attributes))
 452       )
 453     (when (and (memq 'kangxi-strokes attributes)
 454                (setq value (get-char-attribute char 'kangxi-strokes)))
 455       (unless (eq value strokes)
 456         (insert (format "(kangxi-strokes\t . %S)%s"
 457                         value
 458                         line-breaking))
 459         (or strokes
 460             (setq strokes value)))
 461       (setq attributes (delq 'kangxi-strokes attributes))
 462       )
 463     (when (and (memq 'japanese-radical attributes)
 464                (setq value (get-char-attribute char 'japanese-radical)))
 465       (unless (eq value radical)
 466         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 467                         value
 468                         (aref ideographic-radicals value)
 469                         line-breaking))
 470         (or radical
 471             (setq radical value)))
 472       (setq attributes (delq 'japanese-radical attributes))
 473       )
 474     (when (and (memq 'japanese-strokes attributes)
 475                (setq value (get-char-attribute char 'japanese-strokes)))
 476       (unless (eq value strokes)
 477         (insert (format "(japanese-strokes\t . %S)%s"
 478                         value
 479                         line-breaking))
 480         (or strokes
 481             (setq strokes value)))
 482       (setq attributes (delq 'japanese-strokes attributes))
 483       )
 484     (when (and (memq 'cns-radical attributes)
 485                (setq value (get-char-attribute char 'cns-radical)))
 486       (insert (format "(cns-radical\t . %S)\t; %c%s"
 487                       value
 488                       (aref ideographic-radicals value)
 489                       line-breaking))
 490       (setq attributes (delq 'cns-radical attributes))
 491       )
 492     (when (and (memq 'cns-strokes attributes)
 493                (setq value (get-char-attribute char 'cns-strokes)))
 494       (unless (eq value strokes)
 495         (insert (format "(cns-strokes\t . %S)%s"
 496                         value
 497                         line-breaking))
 498         (or strokes
 499             (setq strokes value)))
 500       (setq attributes (delq 'cns-strokes attributes))
 501       )
 502     (when (and (memq 'shinjigen-1-radical attributes)
 503                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 504       (unless (eq value radical)
 505         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 506                         value
 507                         (aref ideographic-radicals value)
 508                         line-breaking))
 509         (or radical
 510             (setq radical value)))
 511       (setq attributes (delq 'shinjigen-1-radical attributes))
 512       )
 513     (when (and (memq 'total-strokes attributes)
 514                (setq value (get-char-attribute char 'total-strokes)))
 515       (insert (format "(total-strokes       . %S)%s"
 516                       value
 517                       line-breaking))
 518       (setq attributes (delq 'total-strokes attributes))
 519       )
 520     (when (and (memq '->ideograph attributes)
 521                (setq value (get-char-attribute char '->ideograph)))
 522       (insert (format "(->ideograph\t%s)%s"
 523                       (mapconcat (lambda (code)
 524                                    (cond ((symbolp code)
 525                                           (symbol-name code))
 526                                          ((integerp code)
 527                                           (format "#x%04X" code))
 528                                          (t
 529                                           (format "%s %S"
 530                                                   line-breaking code))))
 531                                  value " ")
 532                       line-breaking))
 533       (setq attributes (delq '->ideograph attributes))
 534       )
 535     (when (and (memq '->decomposition attributes)
 536                (setq value (get-char-attribute char '->decomposition)))
 537       (insert (format "(->decomposition\t%s)%s"
 538                       (mapconcat (lambda (code)
 539                                    (cond ((symbolp code)
 540                                           (symbol-name code))
 541                                          ((characterp code)
 542                                           (if readable
 543                                               (format "%S" code)
 544                                             (format "#x%04X"
 545                                                     (char-int code))
 546                                             ))
 547                                          ((integerp code)
 548                                           (format "#x%04X" code))
 549                                          (t
 550                                           (format "%s%S" line-breaking code))))
 551                                  value " ")
 552                       line-breaking))
 553       (setq attributes (delq '->decomposition attributes))
 554       )
 555     (if (equal (get-char-attribute char '->titlecase)
 556                (get-char-attribute char '->uppercase))
 557         (setq attributes (delq '->titlecase attributes)))
 558     (when (and (memq '->mojikyo attributes)
 559                (setq value (get-char-attribute char '->mojikyo)))
 560       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 561                       value (decode-char 'mojikyo value)
 562                       line-breaking))
 563       (setq attributes (delq '->mojikyo attributes))
 564       )
 565     (setq rest ccs-attributes)
 566     (while (and rest
 567                 (progn
 568                   (setq value (get-char-attribute char (car rest)))
 569                   (if value
 570                       (if (>= (length (symbol-name (car rest))) 19)
 571                           (progn
 572                             (setq has-long-ccs-name t)
 573                             nil)
 574                         t)
 575                     t)))
 576       (setq rest (cdr rest)))
 577     (while attributes
 578       (setq name (car attributes))
 579       (if (setq value (get-char-attribute char name))
 580           (cond ((eq name 'jisx0208-1978/4X)
 581                  (insert (format "(%-18s . #x%04X)%s"
 582                                  name value
 583                                  line-breaking)))
 584                 ((memq name '(->lowercase
 585                               ->uppercase ->titlecase
 586                               ->fullwidth <-fullwidth
 587                               ->vulgar-ideograph <-vulgar-ideograph
 588                               ->ancient-ideograph <-ancient-ideograph
 589                               ->original-ideograph <-original-ideograph
 590                               ->simplified-ideograph <-simplified-ideograph
 591                               ->same-ideograph
 592                               ->ideographic-variants
 593                               ->synonyms
 594                               ->radical <-radical
 595                               ->bopomofo <-bopomofo
 596                               ->ideographic <-ideographic
 597                               ideographic-structure))
 598                  (insert (format "(%-18s%s " name line-breaking))
 599                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 600                        separator nil)
 601                  (while (consp value)
 602                    (setq cell (car value))
 603                    (if (integerp cell)
 604                        (setq cell (decode-char 'ucs cell)))
 605                    (cond ((characterp cell)
 606                           (if separator
 607                               (insert lbs))
 608                           (char-db-insert-char-spec cell readable)
 609                           (setq separator lbs))
 610                          ((consp cell)
 611                           (if separator
 612                               (insert lbs))
 613                           (if (consp (car cell))
 614                               (char-db-insert-char-spec cell readable)
 615                             (char-db-insert-char-reference cell readable))
 616                           (setq separator lbs))
 617                          (t
 618                           (if separator
 619                               (insert separator))
 620                           (insert (prin1-to-string cell))
 621                           (setq separator " ")))
 622                    (setq value (cdr value)))
 623                  (insert ")")
 624                  (insert line-breaking))
 625                 ((memq name '(ideograph=
 626                               original-ideograph-of
 627                               ancient-ideograph-of
 628                               vulgar-ideograph-of
 629                               wrong-ideograph-of
 630                               simplified-ideograph-of
 631                               ideographic-variants
 632                               ideographic-different-form-of))
 633                  (insert (format "(%-18s%s " name line-breaking))
 634                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 635                        separator nil)
 636                  (while (consp value)
 637                    (setq cell (car value))
 638                    (if (and (consp cell)
 639                             (consp (car cell)))
 640                        (progn
 641                          (if separator
 642                              (insert lbs))
 643                          (char-db-insert-alist cell readable)
 644                          (setq separator lbs))
 645                      (if separator
 646                          (insert separator))
 647                      (insert (prin1-to-string cell))
 648                      (setq separator " "))
 649                    (setq value (cdr value)))
 650                  (insert ")")
 651                  (insert line-breaking))
 652                 ((string-match "^->" (symbol-name name))
 653                  (insert
 654                   (format "(%-18s %s)%s"
 655                           name
 656                           (mapconcat (lambda (code)
 657                                        (cond ((symbolp code)
 658                                               (symbol-name code))
 659                                              ((integerp code)
 660                                               (format "#x%04X" code))
 661                                              (t
 662                                               (format "%s%S"
 663                                                       line-breaking code))))
 664                                      value " ")
 665                           line-breaking)))
 666                 ((consp value)
 667                  (insert (format "(%-18s " name))
 668                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 669                        separator nil)
 670                  (while (consp value)
 671                    (setq cell (car value))
 672                    (if (and (consp cell)
 673                             (consp (car cell))
 674                             (setq ret (condition-case nil
 675                                           (define-char cell)
 676                                         (error nil))))
 677                        (progn
 678                          (setq rest cell
 679                                al nil
 680                                cal nil)
 681                          (while rest
 682                            (setq key (car (car rest)))
 683                            (if (find-charset key)
 684                                (setq cal (cons key cal))
 685                              (setq al (cons key al)))
 686                            (setq rest (cdr rest)))
 687                          (if separator
 688                              (insert lbs))
 689                          (insert-char-attributes ret
 690                                                  readable
 691                                                  al cal)
 692                          (setq separator lbs))
 693                      (if separator
 694                          (insert separator))
 695                      (insert (prin1-to-string cell))
 696                      (setq separator " "))
 697                    (setq value (cdr value)))
 698                  (insert ")")
 699                  (insert line-breaking))
 700                 (t
 701                  (insert (format "(%-18s . %S)%s"
 702                                  name value
 703                                  line-breaking)))
 704                 ))
 705       (setq attributes (cdr attributes)))
 706     (while ccs-attributes
 707       (setq name (car ccs-attributes))
 708       (if (and (eq name (charset-name name))
 709                (setq value (get-char-attribute char name)))
 710           (insert
 711            (format
 712             (cond ((memq name '(ideograph-daikanwa ideograph-gt))
 713                    (if has-long-ccs-name
 714                        "(%-26s . %05d)\t; %c%s"
 715                      "(%-18s . %05d)\t; %c%s"))
 716                   ((eq name 'mojikyo)
 717                    (if has-long-ccs-name
 718                        "(%-26s . %06d)\t; %c%s"
 719                      "(%-18s . %06d)\t; %c%s"))
 720                   ((eq name 'ucs)
 721                    (if has-long-ccs-name
 722                        "(%-26s . #x%04X)\t; %c%s"
 723                      "(%-18s . #x%04X)\t; %c%s"))
 724                   (t
 725                    (if has-long-ccs-name
 726                        "(%-26s . #x%02X)\t; %c%s"
 727                      "(%-18s . #x%02X)\t; %c%s")))
 728             name
 729             (if (= (charset-iso-graphic-plane name) 1)
 730                 (logior value
 731                         (cond ((= (charset-dimension name) 1)
 732                                #x80)
 733                               ((= (charset-dimension name) 2)
 734                                #x8080)
 735                               ((= (charset-dimension name) 3)
 736                                #x808080)
 737                               (t 0)))
 738               value)
 739             (char-db-decode-isolated-char name value)
 740             line-breaking)))
 741       (setq ccs-attributes (cdr ccs-attributes)))
 742     (insert ")")))
 743
 744 (defun insert-char-data (char &optional readable
 745                               attributes ccs-attributes)
 746   (save-restriction
 747     (narrow-to-region (point)(point))
 748     (insert "(define-char
 749   '")
 750     (insert-char-attributes char readable
 751                             attributes ccs-attributes)
 752     (insert ")\n")
 753     (goto-char (point-min))
 754     (while (re-search-forward "[ \t]+$" nil t)
 755       (replace-match ""))
 756     (goto-char (point-max))
 757     (tabify (point-min)(point-max))
 758     ))
 759
 760 ;;;###autoload
 761 (defun char-db-update-comment ()
 762   (interactive)
 763   (save-excursion
 764     (goto-char (point-min))
 765     (let (cdef table char)
 766       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 767         (goto-char (match-beginning 1))
 768         (setq cdef (read (current-buffer)))
 769         (when (find-charset (car cdef))
 770           (goto-char (match-end 0))
 771           (setq char
 772                 (if (and
 773                      (not (eq (car cdef) 'ideograph-daikanwa))
 774                      (or (memq (car cdef) '(ascii latin-viscii-upper
 775                                                   latin-viscii-lower
 776                                                   arabic-iso8859-6
 777                                                   japanese-jisx0213-1
 778                                                   japanese-jisx0213-2))
 779                          (= (char-int (charset-iso-final-char (car cdef)))
 780                             0)))
 781                     (apply (function make-char) cdef)
 782                   (if (setq table (charset-mapping-table (car cdef)))
 783                       (set-charset-mapping-table (car cdef) nil))
 784                   (prog1
 785                       (apply (function make-char) cdef)
 786                     (if table
 787                         (set-charset-mapping-table (car cdef) table)))))
 788           (when (not (or (< (char-int char) 32)
 789                          (and (<= 128 (char-int char))
 790                               (< (char-int char) 160))))
 791             (delete-region (point) (point-at-eol))
 792             (insert (format "\t; %c" char)))
 793           )))))
 794
 795 (defun insert-char-data-with-variant (char &optional printable
 796                                            no-ucs-variant
 797                                            script excluded-script)
 798   (insert-char-data char printable)
 799   (let ((variants (or (char-variants char)
 800                       (let ((ucs (get-char-attribute char '->ucs)))
 801                         (if ucs
 802                             (delete char (char-variants (int-char ucs)))))))
 803         variant vs)
 804     (setq variants (sort variants #'<))
 805     (while variants
 806       (setq variant (car variants))
 807       (if (and (or (null script)
 808                    (null (setq vs (get-char-attribute variant 'script)))
 809                    (memq script vs))
 810                (or (null excluded-script)
 811                    (null (setq vs (get-char-attribute variant 'script)))
 812                    (not (memq excluded-script vs))))
 813           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 814               (insert-char-data variant printable)))
 815       (setq variants (cdr variants))
 816       )))
 817
 818 (defun insert-char-range-data (min max &optional script excluded-script)
 819   (let ((code min)
 820         char)
 821     (while (<= code max)
 822       (setq char (decode-char 'ucs code))
 823       (if (get-char-attribute char 'ucs)
 824           (insert-char-data-with-variant char nil 'no-ucs-variant
 825                                          script excluded-script))
 826       (setq code (1+ code))
 827       )))
 828
 829 (defun write-char-range-data-to-file (min max file
 830                                           &optional script excluded-script)
 831   (let ((coding-system-for-write 'utf-8))
 832     (with-temp-buffer
 833       (insert-char-range-data min max script excluded-script)
 834       (write-region (point-min)(point-max) file))))
 835
 836 (defvar what-character-original-window-configuration)
 837
 838 ;;;###autoload
 839 (defun what-char-definition (char)
 840   (interactive (list (char-after)))
 841   (let ((buf (get-buffer-create "*Character Description*"))
 842         (the-buf (current-buffer))
 843         (win-conf (current-window-configuration)))
 844     (pop-to-buffer buf)
 845     (make-local-variable 'what-character-original-window-configuration)
 846     (setq what-character-original-window-configuration win-conf)
 847     (setq buffer-read-only nil)
 848     (erase-buffer)
 849     (condition-case err
 850         (progn
 851           (insert-char-data-with-variant char 'printable)
 852           ;; (char-db-update-comment)
 853           (set-buffer-modified-p nil)
 854           (view-mode the-buf (lambda (buf)
 855                                (set-window-configuration
 856                                 what-character-original-window-configuration)
 857                                ))
 858           (goto-char (point-min)))
 859       (error (progn
 860                (set-window-configuration
 861                 what-character-original-window-configuration)
 862                (signal (car err) (cdr err)))))))
 863
 864 (provide 'char-db-util)
 865
 866 ;;; char-db-util.el ends here