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