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