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