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