git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/utf-2000/char-db-util.el

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