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     (when (and (not readable)
 677                (memq '->ucs-variants attributes))
 678       (setq attributes (delq '->ucs-variants attributes))
 679       )
 680     (setq rest ccs-attributes)
 681     (while (and rest
 682                 (progn
 683                   (setq value (get-char-attribute char (car rest)))
 684                   (if value
 685                       (if (>= (length (symbol-name (car rest))) 19)
 686                           (progn
 687                             (setq has-long-ccs-name t)
 688                             nil)
 689                         t)
 690                     t)))
 691       (setq rest (cdr rest)))
 692     (while attributes
 693       (setq name (car attributes))
 694       (if (setq value (get-char-attribute char name))
 695           (cond ((eq name 'jisx0208-1978/4X)
 696                  (insert (format "(%-18s . #x%04X)%s"
 697                                  name value
 698                                  line-breaking)))
 699                 ((or (eq name 'ideographic-structure)
 700                      (string-match "^\\(->\\|<-\\)" (symbol-name name)))
 701                  ;; (memq name '(->lowercase
 702                  ;;              ->uppercase ->titlecase
 703                  ;;              ->fullwidth <-fullwidth
 704                  ;;              ->identical
 705                  ;;              ->vulgar-ideograph <-vulgar-ideograph
 706                  ;;              ->ancient-ideograph <-ancient-ideograph
 707                  ;;              ->original-ideograph <-original-ideograph
 708                  ;;              ->simplified-ideograph <-simplified-ideograph
 709                  ;;              ->wrong-ideograph <-wrong-ideograph
 710                  ;;              ->same-ideograph
 711                  ;;              ->ideographic-variants
 712                  ;;              ->synonyms
 713                  ;;              ->radical <-radical
 714                  ;;              ->bopomofo <-bopomofo
 715                  ;;              ->ideographic <-ideographic
 716                  ;;              ideographic-structure))
 717                  (insert (format "(%-18s%s " name line-breaking))
 718                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 719                        separator nil)
 720                  (while (consp value)
 721                    (setq cell (car value))
 722                    (if (integerp cell)
 723                        (setq cell (decode-char 'ucs cell)))
 724                    (cond ((characterp cell)
 725                           (if separator
 726                               (insert lbs))
 727                           (if readable
 728                               (insert (format "%S" cell))
 729                             (char-db-insert-char-spec cell readable))
 730                           (setq separator lbs))
 731                          ((consp cell)
 732                           (if separator
 733                               (insert lbs))
 734                           (if (consp (car cell))
 735                               (char-db-insert-char-spec cell readable)
 736                             (char-db-insert-char-reference cell readable))
 737                           (setq separator lbs))
 738                          (t
 739                           (if separator
 740                               (insert separator))
 741                           (insert (prin1-to-string cell))
 742                           (setq separator " ")))
 743                    (setq value (cdr value)))
 744                  (insert ")")
 745                  (insert line-breaking))
 746                 ((memq name '(ideograph=
 747                               original-ideograph-of
 748                               ancient-ideograph-of
 749                               vulgar-ideograph-of
 750                               wrong-ideograph-of
 751                               simplified-ideograph-of
 752                               ideographic-variants
 753                               ideographic-different-form-of))
 754                  (insert (format "(%-18s%s " name line-breaking))
 755                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 756                        separator nil)
 757                  (while (consp value)
 758                    (setq cell (car value))
 759                    (if (and (consp cell)
 760                             (consp (car cell)))
 761                        (progn
 762                          (if separator
 763                              (insert lbs))
 764                          (char-db-insert-alist cell readable)
 765                          (setq separator lbs))
 766                      (if separator
 767                          (insert separator))
 768                      (insert (prin1-to-string cell))
 769                      (setq separator " "))
 770                    (setq value (cdr value)))
 771                  (insert ")")
 772                  (insert line-breaking))
 773                 ;; ((string-match "^->" (symbol-name name))
 774                 ;;  (insert
 775                 ;;   (format "(%-18s %s)%s"
 776                 ;;           name
 777                 ;;           (mapconcat (lambda (code)
 778                 ;;                        (cond ((symbolp code)
 779                 ;;                               (symbol-name code))
 780                 ;;                              ((integerp code)
 781                 ;;                               (format "#x%04X" code))
 782                 ;;                              (t
 783                 ;;                               (format "%s%S"
 784                 ;;                                       line-breaking code))))
 785                 ;;                      value " ")
 786                 ;;           line-breaking)))
 787                 ((consp value)
 788                  (insert (format "(%-18s " name))
 789                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 790                        separator nil)
 791                  (while (consp value)
 792                    (setq cell (car value))
 793                    (if (and (consp cell)
 794                             (consp (car cell))
 795                             (setq ret (condition-case nil
 796                                           (find-char cell)
 797                                         (error nil))))
 798                        (progn
 799                          (setq rest cell
 800                                al nil
 801                                cal nil)
 802                          (while rest
 803                            (setq key (car (car rest)))
 804                            (if (find-charset key)
 805                                (setq cal (cons key cal))
 806                              (setq al (cons key al)))
 807                            (setq rest (cdr rest)))
 808                          (if separator
 809                              (insert lbs))
 810                          (insert-char-attributes ret
 811                                                  readable
 812                                                  al cal)
 813                          (setq separator lbs))
 814                      (if separator
 815                          (insert separator))
 816                      (insert (prin1-to-string cell))
 817                      (setq separator " "))
 818                    (setq value (cdr value)))
 819                  (insert ")")
 820                  (insert line-breaking))
 821                 (t
 822                  (insert (format "(%-18s . %S)%s"
 823                                  name value
 824                                  line-breaking)))
 825                 ))
 826       (setq attributes (cdr attributes)))
 827     (while ccs-attributes
 828       (setq name (car ccs-attributes))
 829       (if (and (eq name (charset-name name))
 830                (setq value (get-char-attribute char name)))
 831           (insert
 832            (format
 833             (cond ((memq name '(ideograph-daikanwa-2
 834                                 ideograph-daikanwa
 835                                 ideograph-gt
 836                                 ideograph-cbeta))
 837                    (if has-long-ccs-name
 838                        "(%-26s . %05d)\t; %c%s"
 839                      "(%-18s . %05d)\t; %c%s"))
 840                   ((eq name 'mojikyo)
 841                    (if has-long-ccs-name
 842                        "(%-26s . %06d)\t; %c%s"
 843                      "(%-18s . %06d)\t; %c%s"))
 844                   ((eq name 'ucs)
 845                    (if has-long-ccs-name
 846                        "(%-26s . #x%04X)\t; %c%s"
 847                      "(%-18s . #x%04X)\t; %c%s"))
 848                   (t
 849                    (if has-long-ccs-name
 850                        "(%-26s . #x%02X)\t; %c%s"
 851                      "(%-18s . #x%02X)\t; %c%s")))
 852             name
 853             (if (= (charset-iso-graphic-plane name) 1)
 854                 (logior value
 855                         (cond ((= (charset-dimension name) 1)
 856                                #x80)
 857                               ((= (charset-dimension name) 2)
 858                                #x8080)
 859                               ((= (charset-dimension name) 3)
 860                                #x808080)
 861                               (t 0)))
 862               value)
 863             (char-db-decode-isolated-char name value)
 864             line-breaking)))
 865       (setq ccs-attributes (cdr ccs-attributes)))
 866     (insert ")")))
 867
 868 (defun insert-char-data (char &optional readable
 869                               attributes ccs-attributes)
 870   (save-restriction
 871     (narrow-to-region (point)(point))
 872     (insert "(define-char
 873   '")
 874     (insert-char-attributes char readable
 875                             attributes ccs-attributes)
 876     (insert ")\n")
 877     (goto-char (point-min))
 878     (while (re-search-forward "[ \t]+$" nil t)
 879       (replace-match ""))
 880     (goto-char (point-max))
 881     (tabify (point-min)(point-max))
 882     ))
 883
 884 ;;;###autoload
 885 (defun char-db-update-comment ()
 886   (interactive)
 887   (save-excursion
 888     (goto-char (point-min))
 889     (let (cdef table char)
 890       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 891         (goto-char (match-beginning 1))
 892         (setq cdef (read (current-buffer)))
 893         (when (find-charset (car cdef))
 894           (goto-char (match-end 0))
 895           (setq char
 896                 (if (and
 897                      (not (eq (car cdef) 'ideograph-daikanwa))
 898                      (or (memq (car cdef) '(ascii latin-viscii-upper
 899                                                   latin-viscii-lower
 900                                                   arabic-iso8859-6
 901                                                   japanese-jisx0213-1
 902                                                   japanese-jisx0213-2))
 903                          (= (char-int (charset-iso-final-char (car cdef)))
 904                             0)))
 905                     (apply (function make-char) cdef)
 906                   (if (setq table (charset-mapping-table (car cdef)))
 907                       (set-charset-mapping-table (car cdef) nil))
 908                   (prog1
 909                       (apply (function make-char) cdef)
 910                     (if table
 911                         (set-charset-mapping-table (car cdef) table)))))
 912           (when (not (or (< (char-int char) 32)
 913                          (and (<= 128 (char-int char))
 914                               (< (char-int char) 160))))
 915             (delete-region (point) (point-at-eol))
 916             (insert (format "\t; %c" char)))
 917           )))))
 918
 919 (defun insert-char-data-with-variant (char &optional printable
 920                                            no-ucs-variant
 921                                            script excluded-script)
 922   (insert-char-data char printable)
 923   (let ((variants (or (char-variants char)
 924                       (let ((ucs (get-char-attribute char '->ucs)))
 925                         (if ucs
 926                             (delete char (char-variants (int-char ucs)))))))
 927         variant vs)
 928     (setq variants (sort variants #'<))
 929     (while variants
 930       (setq variant (car variants))
 931       (if (and (or (null script)
 932                    (null (setq vs (get-char-attribute variant 'script)))
 933                    (memq script vs))
 934                (or (null excluded-script)
 935                    (null (setq vs (get-char-attribute variant 'script)))
 936                    (not (memq excluded-script vs))))
 937           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 938               (insert-char-data variant printable)))
 939       (setq variants (cdr variants))
 940       )))
 941
 942 (defun insert-char-range-data (min max &optional script excluded-script)
 943   (let ((code min)
 944         char)
 945     (while (<= code max)
 946       (setq char (decode-char 'ucs code))
 947       (if (get-char-attribute char 'ucs)
 948           (insert-char-data-with-variant char nil 'no-ucs-variant
 949                                          script excluded-script))
 950       (setq code (1+ code))
 951       )))
 952
 953 (defun write-char-range-data-to-file (min max file
 954                                           &optional script excluded-script)
 955   (let ((coding-system-for-write 'utf-8))
 956     (with-temp-buffer
 957       (insert-char-range-data min max script excluded-script)
 958       (write-region (point-min)(point-max) file))))
 959
 960 (defvar what-character-original-window-configuration)
 961
 962 ;;;###autoload
 963 (defun what-char-definition (char)
 964   (interactive (list (char-after)))
 965   (let ((buf (get-buffer-create "*Character Description*"))
 966         (the-buf (current-buffer))
 967         (win-conf (current-window-configuration)))
 968     (pop-to-buffer buf)
 969     (make-local-variable 'what-character-original-window-configuration)
 970     (setq what-character-original-window-configuration win-conf)
 971     (setq buffer-read-only nil)
 972     (erase-buffer)
 973     (condition-case err
 974         (progn
 975           (insert-char-data-with-variant char 'printable)
 976           (unless (char-attribute-alist char)
 977             (insert (format ";; = %c\n"
 978                             (let* ((rest (split-char char))
 979                                    (ccs (pop rest))
 980                                    (code (pop rest)))
 981                               (while rest
 982                                 (setq code (logior (lsh code 8)
 983                                                    (pop rest))))
 984                               (decode-char ccs code)))))
 985           ;; (char-db-update-comment)
 986           (set-buffer-modified-p nil)
 987           (view-mode the-buf (lambda (buf)
 988                                (set-window-configuration
 989                                 what-character-original-window-configuration)
 990                                ))
 991           (goto-char (point-min)))
 992       (error (progn
 993                (set-window-configuration
 994                 what-character-original-window-configuration)
 995                (signal (car err) (cdr err)))))))
 996
 997 (provide 'char-db-util)
 998
 999 ;;; char-db-util.el ends here