git.chise.org Git - chise/xemacs-chise.git.1/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,2003 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs CHISE.
   9
  10 ;; XEmacs CHISE 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 CHISE 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 CHISE; 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 (decode-char '=ucs (+ #x2EFF i)))
  69       (setq i (1+ i)))
  70     v))
  71
  72 (defvar char-db-feature-domains
  73   '(ucs daikanwa cns gt jis jis/alt jis/a jis/b misc unknown))
  74
  75 (defvar char-db-ignored-attributes nil)
  76
  77 (defun char-attribute-name< (ka kb)
  78   (cond
  79    ((find-charset ka)
  80     (cond
  81      ((find-charset kb)
  82       (if (and (charset-iso-final-char ka)
  83                (>= (charset-iso-final-char ka) ?@)
  84                (charset-iso-final-char kb)
  85                (>= (charset-iso-final-char kb) ?@))
  86           (cond
  87            ((= (charset-dimension ka)
  88                (charset-dimension kb))
  89             (< (charset-iso-final-char ka)
  90                (charset-iso-final-char kb)))
  91            (t
  92             (> (charset-dimension ka)
  93                (charset-dimension kb))
  94             ))
  95         (if (< (charset-id ka) 0)
  96             (if (< (charset-id kb) 0)
  97                 (cond
  98                  ((= (charset-dimension ka)
  99                      (charset-dimension kb))
 100                   (> (charset-id ka)(charset-id kb)))
 101                  (t
 102                   (> (charset-dimension ka)
 103                      (charset-dimension kb))
 104                   ))
 105               t)
 106           (< (charset-id ka)(charset-id kb)))))
 107      ((symbolp kb)
 108       nil)
 109      (t
 110       t)))
 111    ((find-charset kb)
 112     t)
 113    ((symbolp ka)
 114     (cond ((symbolp kb)
 115            (string< (symbol-name ka)
 116                     (symbol-name kb)))
 117           (t)))
 118    ((symbolp kb)
 119     nil)))
 120
 121 (defvar char-db-coded-charset-priority-list
 122   '(ascii
 123     control-1
 124     latin-iso8859-1
 125     latin-iso8859-2
 126     latin-iso8859-3
 127     latin-iso8859-4
 128     latin-iso8859-9
 129     latin-jisx0201
 130     cyrillic-iso8859-5
 131     greek-iso8859-7
 132     thai-tis620
 133     =jis-x0208
 134     japanese-jisx0208
 135     japanese-jisx0212
 136     japanese-jisx0208-1978
 137     chinese-gb2312
 138     chinese-cns11643-1
 139     chinese-cns11643-2
 140     chinese-cns11643-3
 141     chinese-cns11643-4
 142     chinese-cns11643-5
 143     chinese-cns11643-6
 144     chinese-cns11643-7
 145     =jis-x0208-1990
 146     =jis-x0213-1-2000
 147     =jis-x0213-2-2000
 148     korean-ksc5601
 149     chinese-isoir165
 150     katakana-jisx0201
 151     hebrew-iso8859-8
 152     chinese-gb12345
 153     latin-viscii
 154     ethiopic-ucs
 155     =gt
 156     ideograph-daikanwa-2
 157     ideograph-daikanwa
 158     =cbeta
 159     ideograph-hanziku-1
 160     ideograph-hanziku-2
 161     ideograph-hanziku-3
 162     ideograph-hanziku-4
 163     ideograph-hanziku-5
 164     ideograph-hanziku-6
 165     ideograph-hanziku-7
 166     ideograph-hanziku-8
 167     ideograph-hanziku-9
 168     ideograph-hanziku-10
 169     ideograph-hanziku-11
 170     ideograph-hanziku-12
 171     =big5
 172     =big5-eten
 173     =big5-cdp
 174     =gt-k
 175     =jef-china3))
 176
 177 (defun char-db-make-char-spec (char)
 178   (let (ret char-spec)
 179     (cond ((characterp char)
 180            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
 181                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 182                   (setq char-spec (list (cons '=ucs ret)))
 183                   (cond ((setq ret (get-char-attribute char 'name))
 184                          (setq char-spec (cons (cons 'name ret) char-spec))
 185                          )
 186                         ((setq ret (get-char-attribute char 'name*))
 187                          (setq char-spec (cons (cons 'name* ret) char-spec))
 188                          ))
 189                   )
 190                  ((setq ret
 191                         (catch 'tag
 192                           (let ((rest char-db-coded-charset-priority-list)
 193                                 ccs)
 194                             (while rest
 195                               (setq ccs (charset-name
 196                                          (find-charset (car rest))))
 197                               (if (setq ret
 198                                         (encode-char char ccs
 199                                                      'defined-only))
 200                                   (throw 'tag (cons ccs ret)))
 201                               (setq rest (cdr rest))))))
 202                   (setq char-spec (list ret))
 203                   (dolist (ccs (delq (car ret) (charset-list)))
 204                     (if (and (or (charset-iso-final-char ccs)
 205                                  (memq ccs
 206                                        '(ideograph-daikanwa
 207                                          =daikanwa-rev2
 208                                          ;; =gt-k
 209                                          )))
 210                              (setq ret (encode-char char ccs 'defined-only)))
 211                         (setq char-spec (cons (cons ccs ret) char-spec))))
 212                   (if (null char-spec)
 213                       (setq char-spec (split-char char)))
 214                   (cond ((setq ret (get-char-attribute char 'name))
 215                          (setq char-spec (cons (cons 'name ret) char-spec))
 216                          )
 217                         ((setq ret (get-char-attribute char 'name*))
 218                          (setq char-spec (cons (cons 'name* ret) char-spec))
 219                          ))
 220                   ))
 221            char-spec)
 222           ((consp char)
 223            char))))
 224
 225 (defun char-db-insert-char-spec (char &optional readable column)
 226   (unless column
 227     (setq column (current-column)))
 228   (let (char-spec al cal key temp-char)
 229     (setq char-spec (char-db-make-char-spec char))
 230     (unless (or (characterp char) ; char
 231                 (condition-case nil
 232                     (setq char (find-char char-spec))
 233                   (error nil)))
 234       ;; define temporary character
 235       ;;   Current implementation is dirty.
 236       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 237                                          char-spec)))
 238       (remove-char-attribute temp-char 'ideograph-daikanwa)
 239       (setq char temp-char))
 240     (setq al nil
 241           cal nil)
 242     (while char-spec
 243       (setq key (car (car char-spec)))
 244       (unless (memq key char-db-ignored-attributes)
 245         (if (find-charset key)
 246             (if (encode-char char key 'defined-only)
 247                 (setq cal (cons key cal)))
 248           (setq al (cons key al))))
 249       (setq char-spec (cdr char-spec)))
 250     (unless cal
 251       (setq char-spec (char-db-make-char-spec char))
 252       (while char-spec
 253         (setq key (car (car char-spec)))
 254         (unless (memq key char-db-ignored-attributes)
 255           (if (find-charset key)
 256               (setq cal (cons key cal))
 257             (setq al (cons key al))))
 258         (setq char-spec (cdr char-spec)))
 259       )
 260     (unless (or cal
 261                 (memq 'ideographic-structure al))
 262       (push 'ideographic-structure al))
 263     (insert-char-attributes char
 264                             readable
 265                             (or al 'none) cal)
 266     (when temp-char
 267       ;; undefine temporary character
 268       ;;   Current implementation is dirty.
 269       (setq char-spec (char-attribute-alist temp-char))
 270       (while char-spec
 271         (remove-char-attribute temp-char (car (car char-spec)))
 272         (setq char-spec (cdr char-spec))))))
 273
 274 (defun char-db-insert-alist (alist &optional readable column)
 275   (unless column
 276     (setq column (current-column)))
 277   (let ((line-breaking
 278          (concat "\n" (make-string (1+ column) ?\ )))
 279         name value
 280         ret al cal key
 281         lbs cell rest separator)
 282     (insert "(")
 283     (while alist
 284       (setq name (car (car alist))
 285             value (cdr (car alist)))
 286       (cond ((eq name 'char)
 287              (insert "(char . ")
 288              (if (setq ret (condition-case nil
 289                                (find-char value)
 290                              (error nil)))
 291                  (progn
 292                    (setq al nil
 293                          cal nil)
 294                    (while value
 295                      (setq key (car (car value)))
 296                      (if (find-charset key)
 297                          (setq cal (cons key cal))
 298                        (setq al (cons key al)))
 299                      (setq value (cdr value)))
 300                    (insert-char-attributes ret
 301                                            readable
 302                                            (or al 'none) cal))
 303                (insert (prin1-to-string value)))
 304              (insert ")")
 305              (insert line-breaking))
 306             ((consp value)
 307              (insert (format "(%-18s " name))
 308              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 309              (while (consp value)
 310                (setq cell (car value))
 311                (if (and (consp cell)
 312                         (consp (car cell))
 313                         (setq ret (condition-case nil
 314                                       (find-char cell)
 315                                     (error nil)))
 316                         )
 317                    (progn
 318                      (setq rest cell
 319                            al nil
 320                            cal nil)
 321                      (while rest
 322                        (setq key (car (car rest)))
 323                        (if (find-charset key)
 324                            (setq cal (cons key cal))
 325                          (setq al (cons key al)))
 326                        (setq rest (cdr rest)))
 327                      (if separator
 328                          (insert lbs))
 329                      (insert-char-attributes ret
 330                                              readable
 331                                              al cal)
 332                      (setq separator lbs))
 333                  (if separator
 334                      (insert separator))
 335                  (insert (prin1-to-string cell))
 336                  (setq separator " "))
 337                (setq value (cdr value)))
 338              (insert ")")
 339              (insert line-breaking))
 340             (t
 341              (insert (format "(%-18s . %S)%s"
 342                              name value
 343                              line-breaking))))
 344       (setq alist (cdr alist))))
 345   (insert ")"))
 346
 347 (defun char-db-insert-char-reference (plist &optional readable column)
 348   (unless column
 349     (setq column (current-column)))
 350   (let ((line-breaking
 351          (concat "\n" (make-string (1+ column) ?\ )))
 352         (separator "")
 353         name value)
 354     (insert "(")
 355     (while plist
 356       (setq name (pop plist))
 357       (setq value (pop plist))
 358       (cond ((eq name :char)
 359              (insert separator)
 360              (insert ":char\t")
 361              (cond ((numberp value)
 362                     (setq value (decode-char '=ucs value)))
 363                    ;; ((consp value)
 364                    ;;  (setq value (or (find-char value)
 365                    ;;                  value)))
 366                    )
 367              (char-db-insert-char-spec value readable)
 368              (insert line-breaking)
 369              (setq separator ""))
 370             ((eq name :radical)
 371              (insert (format "%s%s\t%d ; %c%s"
 372                              separator
 373                              name value
 374                              (aref ideographic-radicals value)
 375                              line-breaking))
 376              (setq separator ""))
 377             (t
 378              (insert (format "%s%s\t%S" separator name value))
 379              (setq separator line-breaking)))
 380       ))
 381   (insert ")"))
 382
 383 (defun char-db-decode-isolated-char (ccs code-point)
 384   (let (ret)
 385     (setq ret
 386           (cond ((eq ccs 'arabic-iso8859-6)
 387                  (decode-char ccs code-point))
 388                 ((and (memq ccs '(=gt-pj-1
 389                                   =gt-pj-2
 390                                   =gt-pj-3
 391                                   =gt-pj-4
 392                                   =gt-pj-5
 393                                   =gt-pj-6
 394                                   =gt-pj-7
 395                                   =gt-pj-8
 396                                   =gt-pj-9
 397                                   =gt-pj-10
 398                                   =gt-pj-11))
 399                       (setq ret (decode-char ccs code-point))
 400                       (setq ret (encode-char ret '=gt 'defined-only)))
 401                  (decode-builtin-char '=gt ret))
 402                 (t
 403                  (decode-builtin-char ccs code-point))))
 404     (cond ((and (<= 0 (char-int ret))
 405                 (<= (char-int ret) #x1F))
 406            (decode-char '=ucs (+ #x2400 (char-int ret))))
 407           ((= (char-int ret) #x7F)
 408            ?\u2421)
 409           (t ret))))
 410
 411 (defvar char-db-convert-obsolete-format t)
 412
 413 (defun insert-char-attributes (char &optional readable
 414                                     attributes ccs-attributes
 415                                     column)
 416   (let (atr-d ccs-d)
 417     (setq attributes
 418           (sort (if attributes
 419                     (if (consp attributes)
 420                         (progn
 421                           (dolist (name attributes)
 422                             (unless (memq name char-db-ignored-attributes)
 423                               (push name atr-d)))
 424                           atr-d))
 425                   (dolist (name (char-attribute-list))
 426                     (unless (memq name char-db-ignored-attributes)
 427                       (if (find-charset name)
 428                           (push name ccs-d)
 429                         (push name atr-d))))
 430                   atr-d)
 431                 #'char-attribute-name<))
 432     (setq ccs-attributes
 433           (sort (if ccs-attributes
 434                     (progn
 435                       (setq ccs-d nil)
 436                       (dolist (name ccs-attributes)
 437                         (unless (memq name char-db-ignored-attributes)
 438                           (push name ccs-d)))
 439                       ccs-d)
 440                   (or ccs-d
 441                       (progn
 442                         (dolist (name (charset-list))
 443                           (unless (memq name char-db-ignored-attributes)
 444                             (push name ccs-d)))
 445                         ccs-d)))
 446                 #'char-attribute-name<)))
 447   (unless column
 448     (setq column (current-column)))
 449   (let (name value has-long-ccs-name rest
 450         radical strokes
 451         (line-breaking
 452          (concat "\n" (make-string (1+ column) ?\ )))
 453         lbs cell separator ret
 454         key al cal
 455         dest-ccss)
 456     (insert "(")
 457     (when (and (memq 'name attributes)
 458                (setq value (get-char-attribute char 'name)))
 459       (insert (format
 460                (if (> (+ (current-column) (length value)) 48)
 461                    "(name . %S)%s"
 462                  "(name               . %S)%s")
 463                value line-breaking))
 464       (setq attributes (delq 'name attributes))
 465       )
 466     (when (and (memq 'name* attributes)
 467                (setq value (get-char-attribute char 'name*)))
 468       (insert (format
 469                (if (> (+ (current-column) (length value)) 48)
 470                    "(name* . %S)%s"
 471                  "(name*              . %S)%s")
 472                value line-breaking))
 473       (setq attributes (delq 'name* attributes))
 474       )
 475     (when (and (memq 'script attributes)
 476                (setq value (get-char-attribute char 'script)))
 477       (insert (format "(script\t\t%s)%s"
 478                       (mapconcat (function prin1-to-string)
 479                                  value " ")
 480                       line-breaking))
 481       (setq attributes (delq 'script attributes))
 482       )
 483     (dolist (name '(=>ucs =>ucs*))
 484       (when (and (memq name attributes)
 485                  (setq value (get-char-attribute char name)))
 486         (insert (format "(%-18s . #x%04X)\t; %c%s"
 487                         name value (decode-char '=ucs value)
 488                         line-breaking))
 489         (setq attributes (delq name attributes))))
 490     (dolist (name '(=>ucs@gb =>ucs@cns =>ucs@jis =>ucs@ks =>ucs@big5))
 491       (when (and (memq name attributes)
 492                  (setq value (get-char-attribute char name)))
 493         (insert (format "(%-18s . #x%04X)\t; %c%s"
 494                         name value
 495                         (decode-char (intern
 496                                       (concat "="
 497                                               (substring
 498                                                (symbol-name name) 2)))
 499                                      value)
 500                         line-breaking))
 501         (setq attributes (delq name attributes))
 502         ))
 503     (dolist (name '(=>ucs-gb =>ucs-cns =>ucs-jis =>ucs-ks =>ucs-big5))
 504       (when (and (memq name attributes)
 505                  (setq value (get-char-attribute char name)))
 506         (insert (format "(%-18s . #x%04X)\t; %c%s"
 507                         (intern
 508                          (concat "=>ucs@"
 509                                  (substring (symbol-name name) 6)))
 510                         value
 511                         (decode-char (intern
 512                                       (concat "=ucs@"
 513                                               (substring
 514                                                (symbol-name name) 6)))
 515                                      value)
 516                         line-breaking))
 517         (setq attributes (delq name attributes))))
 518     (when (and (memq '->ucs attributes)
 519                (setq value (get-char-attribute char '->ucs)))
 520       (insert (format (if char-db-convert-obsolete-format
 521                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 522                         "(->ucs\t\t. #x%04X)\t; %c%s")
 523                       value (decode-char '=ucs value)
 524                       line-breaking))
 525       (setq attributes (delq '->ucs attributes))
 526       )
 527     (when (and (memq 'general-category attributes)
 528                (setq value (get-char-attribute char 'general-category)))
 529       (insert (format
 530                "(general-category\t%s) ; %s%s"
 531                (mapconcat (lambda (cell)
 532                             (format "%S" cell))
 533                           value " ")
 534                (cond ((rassoc value unidata-normative-category-alist)
 535                       "Normative Category")
 536                      ((rassoc value unidata-informative-category-alist)
 537                       "Informative Category")
 538                      (t
 539                       "Unknown Category"))
 540                line-breaking))
 541       (setq attributes (delq 'general-category attributes))
 542       )
 543     (when (and (memq 'bidi-category attributes)
 544                (setq value (get-char-attribute char 'bidi-category)))
 545       (insert (format "(bidi-category\t. %S)%s"
 546                       value
 547                       line-breaking))
 548       (setq attributes (delq 'bidi-category attributes))
 549       )
 550     (unless (or (not (memq 'mirrored attributes))
 551                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 552                     'empty))
 553       (insert (format "(mirrored\t\t. %S)%s"
 554                       value
 555                       line-breaking))
 556       (setq attributes (delq 'mirrored attributes))
 557       )
 558     (cond
 559      ((and (memq 'decimal-digit-value attributes)
 560            (setq value (get-char-attribute char 'decimal-digit-value)))
 561       (insert (format "(decimal-digit-value . %S)%s"
 562                       value
 563                       line-breaking))
 564       (setq attributes (delq 'decimal-digit-value attributes))
 565       (when (and (memq 'digit-value attributes)
 566                  (setq value (get-char-attribute char 'digit-value)))
 567         (insert (format "(digit-value\t . %S)%s"
 568                         value
 569                         line-breaking))
 570         (setq attributes (delq 'digit-value attributes))
 571         )
 572       (when (and (memq 'numeric-value attributes)
 573                  (setq value (get-char-attribute char 'numeric-value)))
 574         (insert (format "(numeric-value\t . %S)%s"
 575                         value
 576                         line-breaking))
 577         (setq attributes (delq 'numeric-value attributes))
 578         )
 579       )
 580      (t
 581       (when (and (memq 'digit-value attributes)
 582                  (setq value (get-char-attribute char 'digit-value)))
 583         (insert (format "(digit-value\t. %S)%s"
 584                         value
 585                         line-breaking))
 586         (setq attributes (delq 'digit-value attributes))
 587         )
 588       (when (and (memq 'numeric-value attributes)
 589                  (setq value (get-char-attribute char 'numeric-value)))
 590         (insert (format "(numeric-value\t. %S)%s"
 591                         value
 592                         line-breaking))
 593         (setq attributes (delq 'numeric-value attributes))
 594         )))
 595     (when (and (memq 'iso-10646-comment attributes)
 596                (setq value (get-char-attribute char 'iso-10646-comment)))
 597       (insert (format "(iso-10646-comment\t. %S)%s"
 598                       value
 599                       line-breaking))
 600       (setq attributes (delq 'iso-10646-comment attributes))
 601       )
 602     (when (and (memq 'morohashi-daikanwa attributes)
 603                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 604       (insert (format "(morohashi-daikanwa\t%s)%s"
 605                       (mapconcat (function prin1-to-string) value " ")
 606                       line-breaking))
 607       (setq attributes (delq 'morohashi-daikanwa attributes))
 608       )
 609     (setq radical nil
 610           strokes nil)
 611     (when (and (memq 'ideographic-radical attributes)
 612                (setq value (get-char-attribute char 'ideographic-radical)))
 613       (setq radical value)
 614       (insert (format "(ideographic-radical . %S)\t; %c%s"
 615                       radical
 616                       (aref ideographic-radicals radical)
 617                       line-breaking))
 618       (setq attributes (delq 'ideographic-radical attributes))
 619       )
 620     (let (key)
 621       (dolist (domain char-db-feature-domains)
 622         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
 623         (when (and (memq key attributes)
 624                    (setq value (get-char-attribute char key)))
 625           (setq radical value)
 626           (insert (format "(%s . %S)\t; %c%s"
 627                           key
 628                           radical
 629                           (aref ideographic-radicals radical)
 630                           line-breaking))
 631           (setq attributes (delq key attributes))
 632           )
 633         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
 634         (when (and (memq key attributes)
 635                    (setq value (get-char-attribute char key)))
 636           (setq strokes value)
 637           (insert (format "(%s . %S)%s"
 638                           key
 639                           strokes
 640                           line-breaking))
 641           (setq attributes (delq key attributes))
 642           )
 643         (setq key (intern (format "%s@%s" 'total-strokes domain)))
 644         (when (and (memq key attributes)
 645                    (setq value (get-char-attribute char key)))
 646           (insert (format "(%s       . %S)%s"
 647                           key
 648                           value
 649                           line-breaking))
 650           (setq attributes (delq key attributes))
 651           )
 652         (dolist (feature '(ideographic-radical
 653                            ideographic-strokes
 654                            total-strokes))
 655           (setq key (intern (format "%s@%s*sources" feature domain)))
 656           (when (and (memq key attributes)
 657                      (setq value (get-char-attribute char key)))
 658             (insert (format "(%s%s" key line-breaking))
 659             (dolist (cell value)
 660               (insert (format " %s" cell)))
 661             (insert ")")
 662             (insert line-breaking)
 663             (setq attributes (delq key attributes))
 664             ))
 665         ))
 666     (when (and (memq 'ideographic-strokes attributes)
 667                (setq value (get-char-attribute char 'ideographic-strokes)))
 668       (setq strokes value)
 669       (insert (format "(ideographic-strokes . %S)%s"
 670                       strokes
 671                       line-breaking))
 672       (setq attributes (delq 'ideographic-strokes attributes))
 673       )
 674     (when (and (memq 'kangxi-radical attributes)
 675                (setq value (get-char-attribute char 'kangxi-radical)))
 676       (unless (eq value radical)
 677         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 678                         value
 679                         (aref ideographic-radicals value)
 680                         line-breaking))
 681         (or radical
 682             (setq radical value)))
 683       (setq attributes (delq 'kangxi-radical attributes))
 684       )
 685     (when (and (memq 'kangxi-strokes attributes)
 686                (setq value (get-char-attribute char 'kangxi-strokes)))
 687       (unless (eq value strokes)
 688         (insert (format "(kangxi-strokes\t . %S)%s"
 689                         value
 690                         line-breaking))
 691         (or strokes
 692             (setq strokes value)))
 693       (setq attributes (delq 'kangxi-strokes attributes))
 694       )
 695     (when (and (memq 'japanese-radical attributes)
 696                (setq value (get-char-attribute char 'japanese-radical)))
 697       (unless (eq value radical)
 698         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 699                         value
 700                         (aref ideographic-radicals value)
 701                         line-breaking))
 702         (or radical
 703             (setq radical value)))
 704       (setq attributes (delq 'japanese-radical attributes))
 705       )
 706     (when (and (memq 'japanese-strokes attributes)
 707                (setq value (get-char-attribute char 'japanese-strokes)))
 708       (unless (eq value strokes)
 709         (insert (format "(japanese-strokes\t . %S)%s"
 710                         value
 711                         line-breaking))
 712         (or strokes
 713             (setq strokes value)))
 714       (setq attributes (delq 'japanese-strokes attributes))
 715       )
 716     (when (and (memq 'cns-radical attributes)
 717                (setq value (get-char-attribute char 'cns-radical)))
 718       (insert (format "(cns-radical\t . %S)\t; %c%s"
 719                       value
 720                       (aref ideographic-radicals value)
 721                       line-breaking))
 722       (setq attributes (delq 'cns-radical attributes))
 723       )
 724     (when (and (memq 'cns-strokes attributes)
 725                (setq value (get-char-attribute char 'cns-strokes)))
 726       (unless (eq value strokes)
 727         (insert (format "(cns-strokes\t . %S)%s"
 728                         value
 729                         line-breaking))
 730         (or strokes
 731             (setq strokes value)))
 732       (setq attributes (delq 'cns-strokes attributes))
 733       )
 734     (when (and (memq 'shinjigen-1-radical attributes)
 735                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 736       (unless (eq value radical)
 737         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 738                         value
 739                         (aref ideographic-radicals value)
 740                         line-breaking))
 741         (or radical
 742             (setq radical value)))
 743       (setq attributes (delq 'shinjigen-1-radical attributes))
 744       )
 745     (when (and (memq 'ideographic- attributes)
 746                (setq value (get-char-attribute char 'ideographic-)))
 747       (insert "(ideographic-       ")
 748       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 749             separator nil)
 750       (while (consp value)
 751         (setq cell (car value))
 752         (if (integerp cell)
 753             (setq cell (decode-char '=ucs cell)))
 754         (cond ((characterp cell)
 755                (if separator
 756                    (insert lbs))
 757                (if readable
 758                    (insert (format "%S" cell))
 759                  (char-db-insert-char-spec cell readable))
 760                (setq separator lbs))
 761               ((consp cell)
 762                (if separator
 763                    (insert lbs))
 764                (if (consp (car cell))
 765                    (char-db-insert-char-spec cell readable)
 766                  (char-db-insert-char-reference cell readable))
 767                (setq separator lbs))
 768               (t
 769                (if separator
 770                    (insert separator))
 771                (insert (prin1-to-string cell))
 772                (setq separator " ")))
 773         (setq value (cdr value)))
 774       (insert ")")
 775       (insert line-breaking)
 776       (setq attributes (delq 'ideographic- attributes)))
 777     (when (and (memq 'total-strokes attributes)
 778                (setq value (get-char-attribute char 'total-strokes)))
 779       (insert (format "(total-strokes       . %S)%s"
 780                       value
 781                       line-breaking))
 782       (setq attributes (delq 'total-strokes attributes))
 783       )
 784     (when (and (memq '->ideograph attributes)
 785                (setq value (get-char-attribute char '->ideograph)))
 786       (insert (format "(->ideograph\t%s)%s"
 787                       (mapconcat (lambda (code)
 788                                    (cond ((symbolp code)
 789                                           (symbol-name code))
 790                                          ((integerp code)
 791                                           (format "#x%04X" code))
 792                                          (t
 793                                           (format "%s %S"
 794                                                   line-breaking code))))
 795                                  value " ")
 796                       line-breaking))
 797       (setq attributes (delq '->ideograph attributes))
 798       )
 799     (when (and (memq '->decomposition attributes)
 800                (setq value (get-char-attribute char '->decomposition)))
 801       (insert (format "(->decomposition\t%s)%s"
 802                       (mapconcat (lambda (code)
 803                                    (cond ((symbolp code)
 804                                           (symbol-name code))
 805                                          ((characterp code)
 806                                           (if readable
 807                                               (format "%S" code)
 808                                             (format "#x%04X"
 809                                                     (char-int code))
 810                                             ))
 811                                          ((integerp code)
 812                                           (format "#x%04X" code))
 813                                          (t
 814                                           (format "%s%S" line-breaking code))))
 815                                  value " ")
 816                       line-breaking))
 817       (setq attributes (delq '->decomposition attributes))
 818       )
 819     (if (equal (get-char-attribute char '->titlecase)
 820                (get-char-attribute char '->uppercase))
 821         (setq attributes (delq '->titlecase attributes)))
 822     (when (and (memq '->mojikyo attributes)
 823                (setq value (get-char-attribute char '->mojikyo)))
 824       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 825                       value (decode-char 'mojikyo value)
 826                       line-breaking))
 827       (setq attributes (delq '->mojikyo attributes))
 828       )
 829     (when (and (memq 'hanyu-dazidian-vol attributes)
 830                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 831       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 832                       value line-breaking))
 833       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 834       )
 835     (when (and (memq 'hanyu-dazidian-page attributes)
 836                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 837       (insert (format "(hanyu-dazidian-page . %d)%s"
 838                       value line-breaking))
 839       (setq attributes (delq 'hanyu-dazidian-page attributes))
 840       )
 841     (when (and (memq 'hanyu-dazidian-char attributes)
 842                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 843       (insert (format "(hanyu-dazidian-char . %d)%s"
 844                       value line-breaking))
 845       (setq attributes (delq 'hanyu-dazidian-char attributes))
 846       )
 847     (unless readable
 848       (when (memq '->ucs-unified attributes)
 849         (setq attributes (delq '->ucs-unified attributes))
 850         )
 851       (when (memq 'composition attributes)
 852         (setq attributes (delq 'composition attributes))
 853         ))
 854     (setq rest ccs-attributes)
 855     (while (and rest
 856                 (progn
 857                   (setq value (get-char-attribute char (car rest)))
 858                   (if value
 859                       (if (>= (length (symbol-name (car rest))) 19)
 860                           (progn
 861                             (setq has-long-ccs-name t)
 862                             nil)
 863                         t)
 864                     t)))
 865       (setq rest (cdr rest)))
 866     (while attributes
 867       (setq name (car attributes))
 868       (if (setq value (get-char-attribute char name))
 869           (cond ((string-match "^=>ucs@" (symbol-name name))
 870                  (insert (format "(%-18s . #x%04X)\t; %c%s"
 871                                  name value (decode-char '=ucs value)
 872                                  line-breaking))
 873                  )
 874                 ((eq name 'jisx0208-1978/4X)
 875                  (insert (format "(%-18s . #x%04X)%s"
 876                                  name value
 877                                  line-breaking)))
 878                 ((or (eq name 'ideographic-structure)
 879                      (eq name 'ideographic-)
 880                      (string-match "^\\(->\\|<-\\)" (symbol-name name)))
 881                  (insert (format "(%-18s%s " name line-breaking))
 882                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 883                        separator nil)
 884                  (while (consp value)
 885                    (setq cell (car value))
 886                    (if (integerp cell)
 887                        (setq cell (decode-char '=ucs cell)))
 888                    (cond ((characterp cell)
 889                           (if separator
 890                               (insert lbs))
 891                           (if readable
 892                               (insert (format "%S" cell))
 893                             (char-db-insert-char-spec cell readable))
 894                           (setq separator lbs))
 895                          ((consp cell)
 896                           (if separator
 897                               (insert lbs))
 898                           (if (consp (car cell))
 899                               (char-db-insert-char-spec cell readable)
 900                             (char-db-insert-char-reference cell readable))
 901                           (setq separator lbs))
 902                          (t
 903                           (if separator
 904                               (insert separator))
 905                           (insert (prin1-to-string cell))
 906                           (setq separator " ")))
 907                    (setq value (cdr value)))
 908                  (insert ")")
 909                  (insert line-breaking))
 910                 ((memq name '(ideograph=
 911                               original-ideograph-of
 912                               ancient-ideograph-of
 913                               vulgar-ideograph-of
 914                               wrong-ideograph-of
 915                               simplified-ideograph-of
 916                               ideographic-variants
 917                               ideographic-different-form-of))
 918                  (insert (format "(%-18s%s " name line-breaking))
 919                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 920                        separator nil)
 921                  (while (consp value)
 922                    (setq cell (car value))
 923                    (if (and (consp cell)
 924                             (consp (car cell)))
 925                        (progn
 926                          (if separator
 927                              (insert lbs))
 928                          (char-db-insert-alist cell readable)
 929                          (setq separator lbs))
 930                      (if separator
 931                          (insert separator))
 932                      (insert (prin1-to-string cell))
 933                      (setq separator " "))
 934                    (setq value (cdr value)))
 935                  (insert ")")
 936                  (insert line-breaking))
 937                 ;; ((string-match "^->" (symbol-name name))
 938                 ;;  (insert
 939                 ;;   (format "(%-18s %s)%s"
 940                 ;;           name
 941                 ;;           (mapconcat (lambda (code)
 942                 ;;                        (cond ((symbolp code)
 943                 ;;                               (symbol-name code))
 944                 ;;                              ((integerp code)
 945                 ;;                               (format "#x%04X" code))
 946                 ;;                              (t
 947                 ;;                               (format "%s%S"
 948                 ;;                                       line-breaking code))))
 949                 ;;                      value " ")
 950                 ;;           line-breaking)))
 951                 ((consp value)
 952                  (insert (format "(%-18s " name))
 953                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 954                        separator nil)
 955                  (while (consp value)
 956                    (setq cell (car value))
 957                    (if (and (consp cell)
 958                             (consp (car cell))
 959                             (setq ret (condition-case nil
 960                                           (find-char cell)
 961                                         (error nil))))
 962                        (progn
 963                          (setq rest cell
 964                                al nil
 965                                cal nil)
 966                          (while rest
 967                            (setq key (car (car rest)))
 968                            (if (find-charset key)
 969                                (setq cal (cons key cal))
 970                              (setq al (cons key al)))
 971                            (setq rest (cdr rest)))
 972                          (if separator
 973                              (insert lbs))
 974                          (insert-char-attributes ret
 975                                                  readable
 976                                                  al cal)
 977                          (setq separator lbs))
 978                      (if separator
 979                          (insert separator))
 980                      (insert (prin1-to-string cell))
 981                      (setq separator " "))
 982                    (setq value (cdr value)))
 983                  (insert ")")
 984                  (insert line-breaking))
 985                 (t
 986                  (insert (format "(%-18s . %S)%s"
 987                                  name value
 988                                  line-breaking)))
 989                 ))
 990       (setq attributes (cdr attributes)))
 991     (while ccs-attributes
 992       (setq name (charset-name (car ccs-attributes)))
 993       (if (and (not (memq name dest-ccss))
 994                (prog1
 995                    (setq value (get-char-attribute char name))
 996                  (setq dest-ccss (cons name dest-ccss))))
 997           (insert
 998            (format
 999             (cond ((memq name '(=daikanwa
1000                                 =daikanwa-rev1 =daikanwa-rev2
1001                                 =gt =gt-k =cbeta))
1002                    (if has-long-ccs-name
1003                        "(%-26s . %05d)\t; %c%s"
1004                      "(%-18s . %05d)\t; %c%s"))
1005                   ((eq name 'mojikyo)
1006                    (if has-long-ccs-name
1007                        "(%-26s . %06d)\t; %c%s"
1008                      "(%-18s . %06d)\t; %c%s"))
1009                   ((>= (charset-dimension name) 2)
1010                    (if has-long-ccs-name
1011                        "(%-26s . #x%04X)\t; %c%s"
1012                      "(%-18s . #x%04X)\t; %c%s"))
1013                   (t
1014                    (if has-long-ccs-name
1015                        "(%-26s . #x%02X)\t; %c%s"
1016                      "(%-18s . #x%02X)\t; %c%s")))
1017             name
1018             (if (= (charset-iso-graphic-plane name) 1)
1019                 (logior value
1020                         (cond ((= (charset-dimension name) 1)
1021                                #x80)
1022                               ((= (charset-dimension name) 2)
1023                                #x8080)
1024                               ((= (charset-dimension name) 3)
1025                                #x808080)
1026                               (t 0)))
1027               value)
1028             (char-db-decode-isolated-char name value)
1029             line-breaking)))
1030       (setq ccs-attributes (cdr ccs-attributes)))
1031     (insert ")")))
1032
1033 (defun insert-char-data (char &optional readable
1034                               attributes ccs-attributes)
1035   (save-restriction
1036     (narrow-to-region (point)(point))
1037     (insert "(define-char
1038   '")
1039     (insert-char-attributes char readable
1040                             attributes ccs-attributes)
1041     (insert ")\n")
1042     (goto-char (point-min))
1043     (while (re-search-forward "[ \t]+$" nil t)
1044       (replace-match ""))
1045     ;; from tabify.
1046     (goto-char (point-min))
1047     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1048       (let ((column (current-column))
1049             (indent-tabs-mode t))
1050         (delete-region (match-beginning 0) (point))
1051         (indent-to column)))
1052     (goto-char (point-max))
1053     ;; (tabify (point-min)(point-max))
1054     ))
1055
1056 (defun insert-char-data-with-variant (char &optional printable
1057                                            no-ucs-unified
1058                                            script excluded-script)
1059   (insert-char-data char printable)
1060   (let ((variants (or (char-variants char)
1061                       (let ((ucs (get-char-attribute char '->ucs)))
1062                         (if ucs
1063                             (delete char (char-variants (int-char ucs)))))))
1064         variant vs)
1065     (setq variants (sort variants #'<))
1066     (while variants
1067       (setq variant (car variants))
1068       (if (and (or (null script)
1069                    (null (setq vs (get-char-attribute variant 'script)))
1070                    (memq script vs))
1071                (or (null excluded-script)
1072                    (null (setq vs (get-char-attribute variant 'script)))
1073                    (not (memq excluded-script vs))))
1074           (or (and no-ucs-unified (get-char-attribute variant '=ucs))
1075               (insert-char-data variant printable)))
1076       (setq variants (cdr variants))
1077       )))
1078
1079 (defun insert-char-range-data (min max &optional script excluded-script)
1080   (let ((code min)
1081         char)
1082     (while (<= code max)
1083       (setq char (decode-char '=ucs code))
1084       (if (encode-char char '=ucs 'defined-only)
1085           (insert-char-data-with-variant char nil 'no-ucs-unified
1086                                          script excluded-script))
1087       (setq code (1+ code)))))
1088
1089 (defun write-char-range-data-to-file (min max file
1090                                           &optional script excluded-script)
1091   (let ((coding-system-for-write 'utf-8-mcs))
1092     (with-temp-buffer
1093       (insert ";; -*- coding: utf-8-mcs -*-\n")
1094       (insert-char-range-data min max script excluded-script)
1095       (write-region (point-min)(point-max) file))))
1096
1097 (defvar what-character-original-window-configuration)
1098
1099 ;;;###autoload
1100 (defun what-char-definition (char)
1101   (interactive (list (char-after)))
1102   (let ((buf (get-buffer-create "*Character Description*"))
1103         (the-buf (current-buffer))
1104         (win-conf (current-window-configuration)))
1105     (pop-to-buffer buf)
1106     (make-local-variable 'what-character-original-window-configuration)
1107     (setq what-character-original-window-configuration win-conf)
1108     (setq buffer-read-only nil)
1109     (erase-buffer)
1110     (condition-case err
1111         (progn
1112           (insert-char-data-with-variant char 'printable)
1113           (unless (char-attribute-alist char)
1114             (insert (format ";; = %c\n"
1115                             (let* ((rest (split-char char))
1116                                    (ccs (pop rest))
1117                                    (code (pop rest)))
1118                               (while rest
1119                                 (setq code (logior (lsh code 8)
1120                                                    (pop rest))))
1121                               (decode-char ccs code)))))
1122           ;; (char-db-update-comment)
1123           (set-buffer-modified-p nil)
1124           (view-mode the-buf (lambda (buf)
1125                                (set-window-configuration
1126                                 what-character-original-window-configuration)
1127                                ))
1128           (goto-char (point-min)))
1129       (error (progn
1130                (set-window-configuration
1131                 what-character-original-window-configuration)
1132                (signal (car err) (cdr err)))))))
1133
1134 (provide 'char-db-util)
1135
1136 ;;; char-db-util.el ends here