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