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