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