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