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