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 "(=>ucs*\t\t. #x%04X)\t; %c%s"
 407                       value (decode-char 'ucs value)
 408                       line-breaking))
 409       (setq attributes (delq '=>ucs* attributes))
 410       )
 411     (when (and (memq '->ucs attributes)
 412                (setq value (get-char-attribute char '->ucs)))
 413       (insert (format (if char-db-convert-obsolete-format
 414                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 415                         "(->ucs\t\t. #x%04X)\t; %c%s")
 416                       value (decode-char 'ucs value)
 417                       line-breaking))
 418       (setq attributes (delq '->ucs attributes))
 419       )
 420     (when (and (memq 'general-category attributes)
 421                (setq value (get-char-attribute char 'general-category)))
 422       (insert (format
 423                "(general-category\t%s) ; %s%s"
 424                (mapconcat (lambda (cell)
 425                             (format "%S" cell))
 426                           value " ")
 427                (cond ((rassoc value unidata-normative-category-alist)
 428                       "Normative Category")
 429                      ((rassoc value unidata-informative-category-alist)
 430                       "Informative Category")
 431                      (t
 432                       "Unknown Category"))
 433                line-breaking))
 434       (setq attributes (delq 'general-category attributes))
 435       )
 436     (when (and (memq 'bidi-category attributes)
 437                (setq value (get-char-attribute char 'bidi-category)))
 438       (insert (format "(bidi-category\t. %S)%s"
 439                       value
 440                       line-breaking))
 441       (setq attributes (delq 'bidi-category attributes))
 442       )
 443     (unless (or (not (memq 'mirrored attributes))
 444                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 445                     'empty))
 446       (insert (format "(mirrored\t\t. %S)%s"
 447                       value
 448                       line-breaking))
 449       (setq attributes (delq 'mirrored attributes))
 450       )
 451     (cond
 452      ((and (memq 'decimal-digit-value attributes)
 453            (setq value (get-char-attribute char 'decimal-digit-value)))
 454       (insert (format "(decimal-digit-value . %S)%s"
 455                       value
 456                       line-breaking))
 457       (setq attributes (delq 'decimal-digit-value attributes))
 458       (when (and (memq 'digit-value attributes)
 459                  (setq value (get-char-attribute char 'digit-value)))
 460         (insert (format "(digit-value\t . %S)%s"
 461                         value
 462                         line-breaking))
 463         (setq attributes (delq 'digit-value attributes))
 464         )
 465       (when (and (memq 'numeric-value attributes)
 466                  (setq value (get-char-attribute char 'numeric-value)))
 467         (insert (format "(numeric-value\t . %S)%s"
 468                         value
 469                         line-breaking))
 470         (setq attributes (delq 'numeric-value attributes))
 471         )
 472       )
 473      (t
 474       (when (and (memq 'digit-value attributes)
 475                  (setq value (get-char-attribute char 'digit-value)))
 476         (insert (format "(digit-value\t. %S)%s"
 477                         value
 478                         line-breaking))
 479         (setq attributes (delq 'digit-value attributes))
 480         )
 481       (when (and (memq 'numeric-value attributes)
 482                  (setq value (get-char-attribute char 'numeric-value)))
 483         (insert (format "(numeric-value\t. %S)%s"
 484                         value
 485                         line-breaking))
 486         (setq attributes (delq 'numeric-value attributes))
 487         )))
 488     (when (and (memq 'iso-10646-comment attributes)
 489                (setq value (get-char-attribute char 'iso-10646-comment)))
 490       (insert (format "(iso-10646-comment\t. %S)%s"
 491                       value
 492                       line-breaking))
 493       (setq attributes (delq 'iso-10646-comment attributes))
 494       )
 495     (when (and (memq 'morohashi-daikanwa attributes)
 496                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 497       (insert (format "(morohashi-daikanwa\t%s)%s"
 498                       (mapconcat (function prin1-to-string) value " ")
 499                       line-breaking))
 500       (setq attributes (delq 'morohashi-daikanwa attributes))
 501       )
 502     (setq radical nil
 503           strokes nil)
 504     (when (and (memq 'ideographic-radical attributes)
 505                (setq value (get-char-attribute char 'ideographic-radical)))
 506       (setq radical value)
 507       (insert (format "(ideographic-radical . %S)\t; %c%s"
 508                       radical
 509                       (aref ideographic-radicals radical)
 510                       line-breaking))
 511       (setq attributes (delq 'ideographic-radical attributes))
 512       )
 513     (when (and (memq 'ideographic-strokes attributes)
 514                (setq value (get-char-attribute char 'ideographic-strokes)))
 515       (setq strokes value)
 516       (insert (format "(ideographic-strokes . %S)%s"
 517                       strokes
 518                       line-breaking))
 519       (setq attributes (delq 'ideographic-strokes attributes))
 520       )
 521     (when (and (memq 'kangxi-radical attributes)
 522                (setq value (get-char-attribute char 'kangxi-radical)))
 523       (unless (eq value radical)
 524         (insert (format "(kangxi-radical\t . %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 'kangxi-radical attributes))
 531       )
 532     (when (and (memq 'kangxi-strokes attributes)
 533                (setq value (get-char-attribute char 'kangxi-strokes)))
 534       (unless (eq value strokes)
 535         (insert (format "(kangxi-strokes\t . %S)%s"
 536                         value
 537                         line-breaking))
 538         (or strokes
 539             (setq strokes value)))
 540       (setq attributes (delq 'kangxi-strokes attributes))
 541       )
 542     (when (and (memq 'japanese-radical attributes)
 543                (setq value (get-char-attribute char 'japanese-radical)))
 544       (unless (eq value radical)
 545         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 546                         value
 547                         (aref ideographic-radicals value)
 548                         line-breaking))
 549         (or radical
 550             (setq radical value)))
 551       (setq attributes (delq 'japanese-radical attributes))
 552       )
 553     (when (and (memq 'japanese-strokes attributes)
 554                (setq value (get-char-attribute char 'japanese-strokes)))
 555       (unless (eq value strokes)
 556         (insert (format "(japanese-strokes\t . %S)%s"
 557                         value
 558                         line-breaking))
 559         (or strokes
 560             (setq strokes value)))
 561       (setq attributes (delq 'japanese-strokes attributes))
 562       )
 563     (when (and (memq 'cns-radical attributes)
 564                (setq value (get-char-attribute char 'cns-radical)))
 565       (insert (format "(cns-radical\t . %S)\t; %c%s"
 566                       value
 567                       (aref ideographic-radicals value)
 568                       line-breaking))
 569       (setq attributes (delq 'cns-radical attributes))
 570       )
 571     (when (and (memq 'cns-strokes attributes)
 572                (setq value (get-char-attribute char 'cns-strokes)))
 573       (unless (eq value strokes)
 574         (insert (format "(cns-strokes\t . %S)%s"
 575                         value
 576                         line-breaking))
 577         (or strokes
 578             (setq strokes value)))
 579       (setq attributes (delq 'cns-strokes attributes))
 580       )
 581     (when (and (memq 'shinjigen-1-radical attributes)
 582                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 583       (unless (eq value radical)
 584         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 585                         value
 586                         (aref ideographic-radicals value)
 587                         line-breaking))
 588         (or radical
 589             (setq radical value)))
 590       (setq attributes (delq 'shinjigen-1-radical attributes))
 591       )
 592     (when (and (memq 'total-strokes attributes)
 593                (setq value (get-char-attribute char 'total-strokes)))
 594       (insert (format "(total-strokes       . %S)%s"
 595                       value
 596                       line-breaking))
 597       (setq attributes (delq 'total-strokes attributes))
 598       )
 599     (when (and (memq '->ideograph attributes)
 600                (setq value (get-char-attribute char '->ideograph)))
 601       (insert (format "(->ideograph\t%s)%s"
 602                       (mapconcat (lambda (code)
 603                                    (cond ((symbolp code)
 604                                           (symbol-name code))
 605                                          ((integerp code)
 606                                           (format "#x%04X" code))
 607                                          (t
 608                                           (format "%s %S"
 609                                                   line-breaking code))))
 610                                  value " ")
 611                       line-breaking))
 612       (setq attributes (delq '->ideograph attributes))
 613       )
 614     (when (and (memq '->decomposition attributes)
 615                (setq value (get-char-attribute char '->decomposition)))
 616       (insert (format "(->decomposition\t%s)%s"
 617                       (mapconcat (lambda (code)
 618                                    (cond ((symbolp code)
 619                                           (symbol-name code))
 620                                          ((characterp code)
 621                                           (if readable
 622                                               (format "%S" code)
 623                                             (format "#x%04X"
 624                                                     (char-int code))
 625                                             ))
 626                                          ((integerp code)
 627                                           (format "#x%04X" code))
 628                                          (t
 629                                           (format "%s%S" line-breaking code))))
 630                                  value " ")
 631                       line-breaking))
 632       (setq attributes (delq '->decomposition attributes))
 633       )
 634     (if (equal (get-char-attribute char '->titlecase)
 635                (get-char-attribute char '->uppercase))
 636         (setq attributes (delq '->titlecase attributes)))
 637     (when (and (memq '->mojikyo attributes)
 638                (setq value (get-char-attribute char '->mojikyo)))
 639       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 640                       value (decode-char 'mojikyo value)
 641                       line-breaking))
 642       (setq attributes (delq '->mojikyo attributes))
 643       )
 644     (when (and (memq 'hanyu-dazidian-vol attributes)
 645                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 646       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 647                       value line-breaking))
 648       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 649       )
 650     (when (and (memq 'hanyu-dazidian-page attributes)
 651                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 652       (insert (format "(hanyu-dazidian-page . %d)%s"
 653                       value line-breaking))
 654       (setq attributes (delq 'hanyu-dazidian-page attributes))
 655       )
 656     (when (and (memq 'hanyu-dazidian-char attributes)
 657                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 658       (insert (format "(hanyu-dazidian-char . %d)%s"
 659                       value line-breaking))
 660       (setq attributes (delq 'hanyu-dazidian-char attributes))
 661       )
 662     (setq rest ccs-attributes)
 663     (while (and rest
 664                 (progn
 665                   (setq value (get-char-attribute char (car rest)))
 666                   (if value
 667                       (if (>= (length (symbol-name (car rest))) 19)
 668                           (progn
 669                             (setq has-long-ccs-name t)
 670                             nil)
 671                         t)
 672                     t)))
 673       (setq rest (cdr rest)))
 674     (while attributes
 675       (setq name (car attributes))
 676       (if (setq value (get-char-attribute char name))
 677           (cond ((eq name 'jisx0208-1978/4X)
 678                  (insert (format "(%-18s . #x%04X)%s"
 679                                  name value
 680                                  line-breaking)))
 681                 ((memq name '(->lowercase
 682                               ->uppercase ->titlecase
 683                               ->fullwidth <-fullwidth
 684                               ->identical
 685                               ->vulgar-ideograph <-vulgar-ideograph
 686                               ->ancient-ideograph <-ancient-ideograph
 687                               ->original-ideograph <-original-ideograph
 688                               ->simplified-ideograph <-simplified-ideograph
 689                               ->wrong-ideograph <-wrong-ideograph
 690                               ->same-ideograph
 691                               ->ideographic-variants
 692                               ->synonyms
 693                               ->radical <-radical
 694                               ->bopomofo <-bopomofo
 695                               ->ideographic <-ideographic
 696                               ideographic-structure))
 697                  (insert (format "(%-18s%s " name line-breaking))
 698                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 699                        separator nil)
 700                  (while (consp value)
 701                    (setq cell (car value))
 702                    (if (integerp cell)
 703                        (setq cell (decode-char 'ucs cell)))
 704                    (cond ((characterp cell)
 705                           (if separator
 706                               (insert lbs))
 707                           (char-db-insert-char-spec cell readable)
 708                           (setq separator lbs))
 709                          ((consp cell)
 710                           (if separator
 711                               (insert lbs))
 712                           (if (consp (car cell))
 713                               (char-db-insert-char-spec cell readable)
 714                             (char-db-insert-char-reference cell readable))
 715                           (setq separator lbs))
 716                          (t
 717                           (if separator
 718                               (insert separator))
 719                           (insert (prin1-to-string cell))
 720                           (setq separator " ")))
 721                    (setq value (cdr value)))
 722                  (insert ")")
 723                  (insert line-breaking))
 724                 ((memq name '(ideograph=
 725                               original-ideograph-of
 726                               ancient-ideograph-of
 727                               vulgar-ideograph-of
 728                               wrong-ideograph-of
 729                               simplified-ideograph-of
 730                               ideographic-variants
 731                               ideographic-different-form-of))
 732                  (insert (format "(%-18s%s " name line-breaking))
 733                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 734                        separator nil)
 735                  (while (consp value)
 736                    (setq cell (car value))
 737                    (if (and (consp cell)
 738                             (consp (car cell)))
 739                        (progn
 740                          (if separator
 741                              (insert lbs))
 742                          (char-db-insert-alist cell readable)
 743                          (setq separator lbs))
 744                      (if separator
 745                          (insert separator))
 746                      (insert (prin1-to-string cell))
 747                      (setq separator " "))
 748                    (setq value (cdr value)))
 749                  (insert ")")
 750                  (insert line-breaking))
 751                 ((string-match "^->" (symbol-name name))
 752                  (insert
 753                   (format "(%-18s %s)%s"
 754                           name
 755                           (mapconcat (lambda (code)
 756                                        (cond ((symbolp code)
 757                                               (symbol-name code))
 758                                              ((integerp code)
 759                                               (format "#x%04X" code))
 760                                              (t
 761                                               (format "%s%S"
 762                                                       line-breaking code))))
 763                                      value " ")
 764                           line-breaking)))
 765                 ((consp value)
 766                  (insert (format "(%-18s " name))
 767                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 768                        separator nil)
 769                  (while (consp value)
 770                    (setq cell (car value))
 771                    (if (and (consp cell)
 772                             (consp (car cell))
 773                             (setq ret (condition-case nil
 774                                           (find-char cell)
 775                                         (error nil))))
 776                        (progn
 777                          (setq rest cell
 778                                al nil
 779                                cal nil)
 780                          (while rest
 781                            (setq key (car (car rest)))
 782                            (if (find-charset key)
 783                                (setq cal (cons key cal))
 784                              (setq al (cons key al)))
 785                            (setq rest (cdr rest)))
 786                          (if separator
 787                              (insert lbs))
 788                          (insert-char-attributes ret
 789                                                  readable
 790                                                  al cal)
 791                          (setq separator lbs))
 792                      (if separator
 793                          (insert separator))
 794                      (insert (prin1-to-string cell))
 795                      (setq separator " "))
 796                    (setq value (cdr value)))
 797                  (insert ")")
 798                  (insert line-breaking))
 799                 (t
 800                  (insert (format "(%-18s . %S)%s"
 801                                  name value
 802                                  line-breaking)))
 803                 ))
 804       (setq attributes (cdr attributes)))
 805     (while ccs-attributes
 806       (setq name (car ccs-attributes))
 807       (if (and (eq name (charset-name name))
 808                (setq value (get-char-attribute char name)))
 809           (insert
 810            (format
 811             (cond ((memq name '(ideograph-daikanwa ideograph-gt
 812                                                    ideograph-cbeta))
 813                    (if has-long-ccs-name
 814                        "(%-26s . %05d)\t; %c%s"
 815                      "(%-18s . %05d)\t; %c%s"))
 816                   ((eq name 'mojikyo)
 817                    (if has-long-ccs-name
 818                        "(%-26s . %06d)\t; %c%s"
 819                      "(%-18s . %06d)\t; %c%s"))
 820                   ((eq name 'ucs)
 821                    (if has-long-ccs-name
 822                        "(%-26s . #x%04X)\t; %c%s"
 823                      "(%-18s . #x%04X)\t; %c%s"))
 824                   (t
 825                    (if has-long-ccs-name
 826                        "(%-26s . #x%02X)\t; %c%s"
 827                      "(%-18s . #x%02X)\t; %c%s")))
 828             name
 829             (if (= (charset-iso-graphic-plane name) 1)
 830                 (logior value
 831                         (cond ((= (charset-dimension name) 1)
 832                                #x80)
 833                               ((= (charset-dimension name) 2)
 834                                #x8080)
 835                               ((= (charset-dimension name) 3)
 836                                #x808080)
 837                               (t 0)))
 838               value)
 839             (char-db-decode-isolated-char name value)
 840             line-breaking)))
 841       (setq ccs-attributes (cdr ccs-attributes)))
 842     (insert ")")))
 843
 844 (defun insert-char-data (char &optional readable
 845                               attributes ccs-attributes)
 846   (save-restriction
 847     (narrow-to-region (point)(point))
 848     (insert "(define-char
 849   '")
 850     (insert-char-attributes char readable
 851                             attributes ccs-attributes)
 852     (insert ")\n")
 853     (goto-char (point-min))
 854     (while (re-search-forward "[ \t]+$" nil t)
 855       (replace-match ""))
 856     (goto-char (point-max))
 857     (tabify (point-min)(point-max))
 858     ))
 859
 860 ;;;###autoload
 861 (defun char-db-update-comment ()
 862   (interactive)
 863   (save-excursion
 864     (goto-char (point-min))
 865     (let (cdef table char)
 866       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 867         (goto-char (match-beginning 1))
 868         (setq cdef (read (current-buffer)))
 869         (when (find-charset (car cdef))
 870           (goto-char (match-end 0))
 871           (setq char
 872                 (if (and
 873                      (not (eq (car cdef) 'ideograph-daikanwa))
 874                      (or (memq (car cdef) '(ascii latin-viscii-upper
 875                                                   latin-viscii-lower
 876                                                   arabic-iso8859-6
 877                                                   japanese-jisx0213-1
 878                                                   japanese-jisx0213-2))
 879                          (= (char-int (charset-iso-final-char (car cdef)))
 880                             0)))
 881                     (apply (function make-char) cdef)
 882                   (if (setq table (charset-mapping-table (car cdef)))
 883                       (set-charset-mapping-table (car cdef) nil))
 884                   (prog1
 885                       (apply (function make-char) cdef)
 886                     (if table
 887                         (set-charset-mapping-table (car cdef) table)))))
 888           (when (not (or (< (char-int char) 32)
 889                          (and (<= 128 (char-int char))
 890                               (< (char-int char) 160))))
 891             (delete-region (point) (point-at-eol))
 892             (insert (format "\t; %c" char)))
 893           )))))
 894
 895 (defun insert-char-data-with-variant (char &optional printable
 896                                            no-ucs-variant
 897                                            script excluded-script)
 898   (insert-char-data char printable)
 899   (let ((variants (or (char-variants char)
 900                       (let ((ucs (get-char-attribute char '->ucs)))
 901                         (if ucs
 902                             (delete char (char-variants (int-char ucs)))))))
 903         variant vs)
 904     (setq variants (sort variants #'<))
 905     (while variants
 906       (setq variant (car variants))
 907       (if (and (or (null script)
 908                    (null (setq vs (get-char-attribute variant 'script)))
 909                    (memq script vs))
 910                (or (null excluded-script)
 911                    (null (setq vs (get-char-attribute variant 'script)))
 912                    (not (memq excluded-script vs))))
 913           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 914               (insert-char-data variant printable)))
 915       (setq variants (cdr variants))
 916       )))
 917
 918 (defun insert-char-range-data (min max &optional script excluded-script)
 919   (let ((code min)
 920         char)
 921     (while (<= code max)
 922       (setq char (decode-char 'ucs code))
 923       (if (get-char-attribute char 'ucs)
 924           (insert-char-data-with-variant char nil 'no-ucs-variant
 925                                          script excluded-script))
 926       (setq code (1+ code))
 927       )))
 928
 929 (defun write-char-range-data-to-file (min max file
 930                                           &optional script excluded-script)
 931   (let ((coding-system-for-write 'utf-8))
 932     (with-temp-buffer
 933       (insert-char-range-data min max script excluded-script)
 934       (write-region (point-min)(point-max) file))))
 935
 936 (defvar what-character-original-window-configuration)
 937
 938 ;;;###autoload
 939 (defun what-char-definition (char)
 940   (interactive (list (char-after)))
 941   (let ((buf (get-buffer-create "*Character Description*"))
 942         (the-buf (current-buffer))
 943         (win-conf (current-window-configuration)))
 944     (pop-to-buffer buf)
 945     (make-local-variable 'what-character-original-window-configuration)
 946     (setq what-character-original-window-configuration win-conf)
 947     (setq buffer-read-only nil)
 948     (erase-buffer)
 949     (condition-case err
 950         (progn
 951           (insert-char-data-with-variant char 'printable)
 952           (unless (char-attribute-alist char)
 953             (insert (format ";; = %c\n"
 954                             (apply #'make-char (split-char char)))))
 955           ;; (char-db-update-comment)
 956           (set-buffer-modified-p nil)
 957           (view-mode the-buf (lambda (buf)
 958                                (set-window-configuration
 959                                 what-character-original-window-configuration)
 960                                ))
 961           (goto-char (point-min)))
 962       (error (progn
 963                (set-window-configuration
 964                 what-character-original-window-configuration)
 965                (signal (car err) (cdr err)))))))
 966
 967 (provide 'char-db-util)
 968
 969 ;;; char-db-util.el ends here