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

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