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