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