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