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