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