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