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