lisp/utf-2000/char-db-util.el

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