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