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         (separator "")
 315         name value)
 316     (insert "(")
 317     (while plist
 318       (setq name (pop plist))
 319       (setq value (pop plist))
 320       (cond ((eq name :char)
 321              (insert separator)
 322              (insert ":char\t")
 323              (cond ((numberp value)
 324                     (setq value (decode-char 'ucs value)))
 325                    ;; ((consp value)
 326                    ;;  (setq value (or (find-char value)
 327                    ;;                  value)))
 328                    )
 329              (char-db-insert-char-spec value readable)
 330              (insert line-breaking)
 331              (setq separator ""))
 332             ((eq name :radical)
 333              (insert (format "%s%s\t%d ; %c%s"
 334                              separator
 335                              name value
 336                              (aref ideographic-radicals value)
 337                              line-breaking))
 338              (setq separator ""))
 339             (t
 340              (insert (format "%s%s\t%S" separator name value))
 341              (setq separator line-breaking)))
 342       ))
 343   (insert ")"))
 344
 345 (defun char-db-decode-isolated-char (ccs code-point)
 346   (let (ret)
 347     (setq ret
 348           (cond ((eq ccs 'arabic-iso8859-6)
 349                  (decode-char ccs code-point))
 350                 ((and (memq ccs '(ideograph-gt-pj-1
 351                                   ideograph-gt-pj-2
 352                                   ideograph-gt-pj-3
 353                                   ideograph-gt-pj-4
 354                                   ideograph-gt-pj-5
 355                                   ideograph-gt-pj-6
 356                                   ideograph-gt-pj-7
 357                                   ideograph-gt-pj-8
 358                                   ideograph-gt-pj-9
 359                                   ideograph-gt-pj-10
 360                                   ideograph-gt-pj-11))
 361                       (setq ret (decode-char ccs code-point))
 362                       (setq ret (get-char-attribute ret 'ideograph-gt)))
 363                  (decode-builtin-char 'ideograph-gt ret))
 364                 (t
 365                  (decode-builtin-char ccs code-point))))
 366     (cond ((and (<= 0 (char-int ret))
 367                 (<= (char-int ret) #x1F))
 368            (decode-char 'ucs (+ #x2400 (char-int ret))))
 369           ((= (char-int ret) #x7F)
 370            ?\u2421)
 371           (t ret))))
 372
 373 (defvar char-db-convert-obsolete-format t)
 374
 375 (defun insert-char-attributes (char &optional readable
 376                                     attributes ccs-attributes
 377                                     column)
 378   (let (atr-d ccs-d)
 379     (setq attributes
 380           (sort (if attributes
 381                     (if (consp attributes)
 382                         (progn
 383                           (dolist (name attributes)
 384                             (unless (memq name char-db-ignored-attributes)
 385                               (push name atr-d)))
 386                           atr-d))
 387                   (dolist (name (char-attribute-list))
 388                     (unless (memq name char-db-ignored-attributes)
 389                       (if (find-charset name)
 390                           (push name ccs-d)
 391                         (push name atr-d))))
 392                   atr-d)
 393                 #'char-attribute-name<))
 394     (setq ccs-attributes
 395           (sort (if ccs-attributes
 396                     (progn
 397                       (setq ccs-d nil)
 398                       (dolist (name ccs-attributes)
 399                         (unless (memq name char-db-ignored-attributes)
 400                           (push name ccs-d)))
 401                       ccs-d)
 402                   (or ccs-d
 403                       (progn
 404                         (dolist (name (charset-list))
 405                           (unless (memq name char-db-ignored-attributes)
 406                             (push name ccs-d)))
 407                         ccs-d)))
 408                 #'char-attribute-name<)))
 409   (unless column
 410     (setq column (current-column)))
 411   (let (name value has-long-ccs-name rest
 412         radical strokes
 413         (line-breaking
 414          (concat "\n" (make-string (1+ column) ?\ )))
 415         lbs cell separator ret
 416         key al cal)
 417     (insert "(")
 418     (when (and (memq 'name attributes)
 419                (setq value (get-char-attribute char 'name)))
 420       (insert (format
 421                (if (> (+ (current-column) (length value)) 48)
 422                    "(name . %S)%s"
 423                  "(name               . %S)%s")
 424                value line-breaking))
 425       (setq attributes (delq 'name attributes))
 426       )
 427     (when (and (memq 'script attributes)
 428                (setq value (get-char-attribute char 'script)))
 429       (insert (format "(script\t\t%s)%s"
 430                       (mapconcat (function prin1-to-string)
 431                                  value " ")
 432                       line-breaking))
 433       (setq attributes (delq 'script attributes))
 434       )
 435     (when (and (memq '=>ucs attributes)
 436                (setq value (get-char-attribute char '=>ucs)))
 437       (insert (format "(=>ucs\t\t. #x%04X)\t; %c%s"
 438                       value (decode-char 'ucs value)
 439                       line-breaking))
 440       (setq attributes (delq '=>ucs attributes))
 441       )
 442     (when (and (memq '=>ucs* attributes)
 443                (setq value (get-char-attribute char '=>ucs*)))
 444       (insert (format "(=>ucs*\t\t. #x%04X)\t; %c%s"
 445                       value (decode-char 'ucs value)
 446                       line-breaking))
 447       (setq attributes (delq '=>ucs* attributes))
 448       )
 449     (when (and (memq '=>ucs-jis attributes)
 450                (setq value (get-char-attribute char '=>ucs-jis)))
 451       (insert (format "(=>ucs-jis\t\t. #x%04X)\t; %c%s"
 452                       value (decode-char 'ucs value)
 453                       line-breaking))
 454       (setq attributes (delq '=>ucs-jis attributes))
 455       )
 456     (when (and (memq '->ucs attributes)
 457                (setq value (get-char-attribute char '->ucs)))
 458       (insert (format (if char-db-convert-obsolete-format
 459                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 460                         "(->ucs\t\t. #x%04X)\t; %c%s")
 461                       value (decode-char 'ucs value)
 462                       line-breaking))
 463       (setq attributes (delq '->ucs attributes))
 464       )
 465     (when (and (memq 'general-category attributes)
 466                (setq value (get-char-attribute char 'general-category)))
 467       (insert (format
 468                "(general-category\t%s) ; %s%s"
 469                (mapconcat (lambda (cell)
 470                             (format "%S" cell))
 471                           value " ")
 472                (cond ((rassoc value unidata-normative-category-alist)
 473                       "Normative Category")
 474                      ((rassoc value unidata-informative-category-alist)
 475                       "Informative Category")
 476                      (t
 477                       "Unknown Category"))
 478                line-breaking))
 479       (setq attributes (delq 'general-category attributes))
 480       )
 481     (when (and (memq 'bidi-category attributes)
 482                (setq value (get-char-attribute char 'bidi-category)))
 483       (insert (format "(bidi-category\t. %S)%s"
 484                       value
 485                       line-breaking))
 486       (setq attributes (delq 'bidi-category attributes))
 487       )
 488     (unless (or (not (memq 'mirrored attributes))
 489                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 490                     'empty))
 491       (insert (format "(mirrored\t\t. %S)%s"
 492                       value
 493                       line-breaking))
 494       (setq attributes (delq 'mirrored attributes))
 495       )
 496     (cond
 497      ((and (memq 'decimal-digit-value attributes)
 498            (setq value (get-char-attribute char 'decimal-digit-value)))
 499       (insert (format "(decimal-digit-value . %S)%s"
 500                       value
 501                       line-breaking))
 502       (setq attributes (delq 'decimal-digit-value attributes))
 503       (when (and (memq 'digit-value attributes)
 504                  (setq value (get-char-attribute char 'digit-value)))
 505         (insert (format "(digit-value\t . %S)%s"
 506                         value
 507                         line-breaking))
 508         (setq attributes (delq 'digit-value attributes))
 509         )
 510       (when (and (memq 'numeric-value attributes)
 511                  (setq value (get-char-attribute char 'numeric-value)))
 512         (insert (format "(numeric-value\t . %S)%s"
 513                         value
 514                         line-breaking))
 515         (setq attributes (delq 'numeric-value attributes))
 516         )
 517       )
 518      (t
 519       (when (and (memq 'digit-value attributes)
 520                  (setq value (get-char-attribute char 'digit-value)))
 521         (insert (format "(digit-value\t. %S)%s"
 522                         value
 523                         line-breaking))
 524         (setq attributes (delq 'digit-value attributes))
 525         )
 526       (when (and (memq 'numeric-value attributes)
 527                  (setq value (get-char-attribute char 'numeric-value)))
 528         (insert (format "(numeric-value\t. %S)%s"
 529                         value
 530                         line-breaking))
 531         (setq attributes (delq 'numeric-value attributes))
 532         )))
 533     (when (and (memq 'iso-10646-comment attributes)
 534                (setq value (get-char-attribute char 'iso-10646-comment)))
 535       (insert (format "(iso-10646-comment\t. %S)%s"
 536                       value
 537                       line-breaking))
 538       (setq attributes (delq 'iso-10646-comment attributes))
 539       )
 540     (when (and (memq 'morohashi-daikanwa attributes)
 541                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 542       (insert (format "(morohashi-daikanwa\t%s)%s"
 543                       (mapconcat (function prin1-to-string) value " ")
 544                       line-breaking))
 545       (setq attributes (delq 'morohashi-daikanwa attributes))
 546       )
 547     (setq radical nil
 548           strokes nil)
 549     (when (and (memq 'ideographic-radical attributes)
 550                (setq value (get-char-attribute char 'ideographic-radical)))
 551       (setq radical value)
 552       (insert (format "(ideographic-radical . %S)\t; %c%s"
 553                       radical
 554                       (aref ideographic-radicals radical)
 555                       line-breaking))
 556       (setq attributes (delq 'ideographic-radical attributes))
 557       )
 558     (when (and (memq 'ideographic-strokes attributes)
 559                (setq value (get-char-attribute char 'ideographic-strokes)))
 560       (setq strokes value)
 561       (insert (format "(ideographic-strokes . %S)%s"
 562                       strokes
 563                       line-breaking))
 564       (setq attributes (delq 'ideographic-strokes attributes))
 565       )
 566     (when (and (memq 'kangxi-radical attributes)
 567                (setq value (get-char-attribute char 'kangxi-radical)))
 568       (unless (eq value radical)
 569         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 570                         value
 571                         (aref ideographic-radicals value)
 572                         line-breaking))
 573         (or radical
 574             (setq radical value)))
 575       (setq attributes (delq 'kangxi-radical attributes))
 576       )
 577     (when (and (memq 'kangxi-strokes attributes)
 578                (setq value (get-char-attribute char 'kangxi-strokes)))
 579       (unless (eq value strokes)
 580         (insert (format "(kangxi-strokes\t . %S)%s"
 581                         value
 582                         line-breaking))
 583         (or strokes
 584             (setq strokes value)))
 585       (setq attributes (delq 'kangxi-strokes attributes))
 586       )
 587     (when (and (memq 'japanese-radical attributes)
 588                (setq value (get-char-attribute char 'japanese-radical)))
 589       (unless (eq value radical)
 590         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 591                         value
 592                         (aref ideographic-radicals value)
 593                         line-breaking))
 594         (or radical
 595             (setq radical value)))
 596       (setq attributes (delq 'japanese-radical attributes))
 597       )
 598     (when (and (memq 'japanese-strokes attributes)
 599                (setq value (get-char-attribute char 'japanese-strokes)))
 600       (unless (eq value strokes)
 601         (insert (format "(japanese-strokes\t . %S)%s"
 602                         value
 603                         line-breaking))
 604         (or strokes
 605             (setq strokes value)))
 606       (setq attributes (delq 'japanese-strokes attributes))
 607       )
 608     (when (and (memq 'cns-radical attributes)
 609                (setq value (get-char-attribute char 'cns-radical)))
 610       (insert (format "(cns-radical\t . %S)\t; %c%s"
 611                       value
 612                       (aref ideographic-radicals value)
 613                       line-breaking))
 614       (setq attributes (delq 'cns-radical attributes))
 615       )
 616     (when (and (memq 'cns-strokes attributes)
 617                (setq value (get-char-attribute char 'cns-strokes)))
 618       (unless (eq value strokes)
 619         (insert (format "(cns-strokes\t . %S)%s"
 620                         value
 621                         line-breaking))
 622         (or strokes
 623             (setq strokes value)))
 624       (setq attributes (delq 'cns-strokes attributes))
 625       )
 626     (when (and (memq 'shinjigen-1-radical attributes)
 627                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 628       (unless (eq value radical)
 629         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 630                         value
 631                         (aref ideographic-radicals value)
 632                         line-breaking))
 633         (or radical
 634             (setq radical value)))
 635       (setq attributes (delq 'shinjigen-1-radical attributes))
 636       )
 637     (when (and (memq 'ideographic- attributes)
 638                (setq value (get-char-attribute char 'ideographic-)))
 639       (insert "(ideographic-       ")
 640       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 641             separator nil)
 642       (while (consp value)
 643         (setq cell (car value))
 644         (if (integerp cell)
 645             (setq cell (decode-char 'ucs cell)))
 646         (cond ((characterp cell)
 647                (if separator
 648                    (insert lbs))
 649                (if readable
 650                    (insert (format "%S" cell))
 651                  (char-db-insert-char-spec cell readable))
 652                (setq separator lbs))
 653               ((consp cell)
 654                (if separator
 655                    (insert lbs))
 656                (if (consp (car cell))
 657                    (char-db-insert-char-spec cell readable)
 658                  (char-db-insert-char-reference cell readable))
 659                (setq separator lbs))
 660               (t
 661                (if separator
 662                    (insert separator))
 663                (insert (prin1-to-string cell))
 664                (setq separator " ")))
 665         (setq value (cdr value)))
 666       (insert ")")
 667       (insert line-breaking)
 668       (setq attributes (delq 'ideographic- attributes)))
 669     (when (and (memq 'total-strokes attributes)
 670                (setq value (get-char-attribute char 'total-strokes)))
 671       (insert (format "(total-strokes       . %S)%s"
 672                       value
 673                       line-breaking))
 674       (setq attributes (delq 'total-strokes attributes))
 675       )
 676     (when (and (memq '->ideograph attributes)
 677                (setq value (get-char-attribute char '->ideograph)))
 678       (insert (format "(->ideograph\t%s)%s"
 679                       (mapconcat (lambda (code)
 680                                    (cond ((symbolp code)
 681                                           (symbol-name code))
 682                                          ((integerp code)
 683                                           (format "#x%04X" code))
 684                                          (t
 685                                           (format "%s %S"
 686                                                   line-breaking code))))
 687                                  value " ")
 688                       line-breaking))
 689       (setq attributes (delq '->ideograph attributes))
 690       )
 691     (when (and (memq '->decomposition attributes)
 692                (setq value (get-char-attribute char '->decomposition)))
 693       (insert (format "(->decomposition\t%s)%s"
 694                       (mapconcat (lambda (code)
 695                                    (cond ((symbolp code)
 696                                           (symbol-name code))
 697                                          ((characterp code)
 698                                           (if readable
 699                                               (format "%S" code)
 700                                             (format "#x%04X"
 701                                                     (char-int code))
 702                                             ))
 703                                          ((integerp code)
 704                                           (format "#x%04X" code))
 705                                          (t
 706                                           (format "%s%S" line-breaking code))))
 707                                  value " ")
 708                       line-breaking))
 709       (setq attributes (delq '->decomposition attributes))
 710       )
 711     (if (equal (get-char-attribute char '->titlecase)
 712                (get-char-attribute char '->uppercase))
 713         (setq attributes (delq '->titlecase attributes)))
 714     (when (and (memq '->mojikyo attributes)
 715                (setq value (get-char-attribute char '->mojikyo)))
 716       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 717                       value (decode-char 'mojikyo value)
 718                       line-breaking))
 719       (setq attributes (delq '->mojikyo attributes))
 720       )
 721     (when (and (memq 'hanyu-dazidian-vol attributes)
 722                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 723       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 724                       value line-breaking))
 725       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 726       )
 727     (when (and (memq 'hanyu-dazidian-page attributes)
 728                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 729       (insert (format "(hanyu-dazidian-page . %d)%s"
 730                       value line-breaking))
 731       (setq attributes (delq 'hanyu-dazidian-page attributes))
 732       )
 733     (when (and (memq 'hanyu-dazidian-char attributes)
 734                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 735       (insert (format "(hanyu-dazidian-char . %d)%s"
 736                       value line-breaking))
 737       (setq attributes (delq 'hanyu-dazidian-char attributes))
 738       )
 739     (when (and (not readable)
 740                (memq '->ucs-variants attributes))
 741       (setq attributes (delq '->ucs-variants attributes))
 742       )
 743     (setq rest ccs-attributes)
 744     (while (and rest
 745                 (progn
 746                   (setq value (get-char-attribute char (car rest)))
 747                   (if value
 748                       (if (>= (length (symbol-name (car rest))) 19)
 749                           (progn
 750                             (setq has-long-ccs-name t)
 751                             nil)
 752                         t)
 753                     t)))
 754       (setq rest (cdr rest)))
 755     (while attributes
 756       (setq name (car attributes))
 757       (if (setq value (get-char-attribute char name))
 758           (cond ((eq name 'jisx0208-1978/4X)
 759                  (insert (format "(%-18s . #x%04X)%s"
 760                                  name value
 761                                  line-breaking)))
 762                 ((or (eq name 'ideographic-structure)
 763                      (eq name 'ideographic-)
 764                      (string-match "^\\(->\\|<-\\)" (symbol-name name)))
 765                  ;; (memq name '(->lowercase
 766                  ;;              ->uppercase ->titlecase
 767                  ;;              ->fullwidth <-fullwidth
 768                  ;;              ->identical
 769                  ;;              ->vulgar-ideograph <-vulgar-ideograph
 770                  ;;              ->ancient-ideograph <-ancient-ideograph
 771                  ;;              ->original-ideograph <-original-ideograph
 772                  ;;              ->simplified-ideograph <-simplified-ideograph
 773                  ;;              ->wrong-ideograph <-wrong-ideograph
 774                  ;;              ->same-ideograph
 775                  ;;              ->ideographic-variants
 776                  ;;              ->synonyms
 777                  ;;              ->radical <-radical
 778                  ;;              ->bopomofo <-bopomofo
 779                  ;;              ->ideographic <-ideographic
 780                  ;;              ideographic-structure))
 781                  (insert (format "(%-18s%s " name line-breaking))
 782                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 783                        separator nil)
 784                  (while (consp value)
 785                    (setq cell (car value))
 786                    (if (integerp cell)
 787                        (setq cell (decode-char 'ucs cell)))
 788                    (cond ((characterp cell)
 789                           (if separator
 790                               (insert lbs))
 791                           (if readable
 792                               (insert (format "%S" cell))
 793                             (char-db-insert-char-spec cell readable))
 794                           (setq separator lbs))
 795                          ((consp cell)
 796                           (if separator
 797                               (insert lbs))
 798                           (if (consp (car cell))
 799                               (char-db-insert-char-spec cell readable)
 800                             (char-db-insert-char-reference cell readable))
 801                           (setq separator lbs))
 802                          (t
 803                           (if separator
 804                               (insert separator))
 805                           (insert (prin1-to-string cell))
 806                           (setq separator " ")))
 807                    (setq value (cdr value)))
 808                  (insert ")")
 809                  (insert line-breaking))
 810                 ((memq name '(ideograph=
 811                               original-ideograph-of
 812                               ancient-ideograph-of
 813                               vulgar-ideograph-of
 814                               wrong-ideograph-of
 815                               simplified-ideograph-of
 816                               ideographic-variants
 817                               ideographic-different-form-of))
 818                  (insert (format "(%-18s%s " name line-breaking))
 819                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 820                        separator nil)
 821                  (while (consp value)
 822                    (setq cell (car value))
 823                    (if (and (consp cell)
 824                             (consp (car cell)))
 825                        (progn
 826                          (if separator
 827                              (insert lbs))
 828                          (char-db-insert-alist cell readable)
 829                          (setq separator lbs))
 830                      (if separator
 831                          (insert separator))
 832                      (insert (prin1-to-string cell))
 833                      (setq separator " "))
 834                    (setq value (cdr value)))
 835                  (insert ")")
 836                  (insert line-breaking))
 837                 ;; ((string-match "^->" (symbol-name name))
 838                 ;;  (insert
 839                 ;;   (format "(%-18s %s)%s"
 840                 ;;           name
 841                 ;;           (mapconcat (lambda (code)
 842                 ;;                        (cond ((symbolp code)
 843                 ;;                               (symbol-name code))
 844                 ;;                              ((integerp code)
 845                 ;;                               (format "#x%04X" code))
 846                 ;;                              (t
 847                 ;;                               (format "%s%S"
 848                 ;;                                       line-breaking code))))
 849                 ;;                      value " ")
 850                 ;;           line-breaking)))
 851                 ((consp value)
 852                  (insert (format "(%-18s " name))
 853                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 854                        separator nil)
 855                  (while (consp value)
 856                    (setq cell (car value))
 857                    (if (and (consp cell)
 858                             (consp (car cell))
 859                             (setq ret (condition-case nil
 860                                           (find-char cell)
 861                                         (error nil))))
 862                        (progn
 863                          (setq rest cell
 864                                al nil
 865                                cal nil)
 866                          (while rest
 867                            (setq key (car (car rest)))
 868                            (if (find-charset key)
 869                                (setq cal (cons key cal))
 870                              (setq al (cons key al)))
 871                            (setq rest (cdr rest)))
 872                          (if separator
 873                              (insert lbs))
 874                          (insert-char-attributes ret
 875                                                  readable
 876                                                  al cal)
 877                          (setq separator lbs))
 878                      (if separator
 879                          (insert separator))
 880                      (insert (prin1-to-string cell))
 881                      (setq separator " "))
 882                    (setq value (cdr value)))
 883                  (insert ")")
 884                  (insert line-breaking))
 885                 (t
 886                  (insert (format "(%-18s . %S)%s"
 887                                  name value
 888                                  line-breaking)))
 889                 ))
 890       (setq attributes (cdr attributes)))
 891     (while ccs-attributes
 892       (setq name (car ccs-attributes))
 893       (if (and (eq name (charset-name name))
 894                (setq value (get-char-attribute char name)))
 895           (insert
 896            (format
 897             (cond ((memq name '(ideograph-daikanwa-2
 898                                 ideograph-daikanwa
 899                                 ideograph-gt
 900                                 ideograph-cbeta))
 901                    (if has-long-ccs-name
 902                        "(%-26s . %05d)\t; %c%s"
 903                      "(%-18s . %05d)\t; %c%s"))
 904                   ((eq name 'mojikyo)
 905                    (if has-long-ccs-name
 906                        "(%-26s . %06d)\t; %c%s"
 907                      "(%-18s . %06d)\t; %c%s"))
 908                   ((eq name 'ucs)
 909                    (if has-long-ccs-name
 910                        "(%-26s . #x%04X)\t; %c%s"
 911                      "(%-18s . #x%04X)\t; %c%s"))
 912                   (t
 913                    (if has-long-ccs-name
 914                        "(%-26s . #x%02X)\t; %c%s"
 915                      "(%-18s . #x%02X)\t; %c%s")))
 916             name
 917             (if (= (charset-iso-graphic-plane name) 1)
 918                 (logior value
 919                         (cond ((= (charset-dimension name) 1)
 920                                #x80)
 921                               ((= (charset-dimension name) 2)
 922                                #x8080)
 923                               ((= (charset-dimension name) 3)
 924                                #x808080)
 925                               (t 0)))
 926               value)
 927             (char-db-decode-isolated-char name value)
 928             line-breaking)))
 929       (setq ccs-attributes (cdr ccs-attributes)))
 930     (insert ")")))
 931
 932 (defun insert-char-data (char &optional readable
 933                               attributes ccs-attributes)
 934   (save-restriction
 935     (narrow-to-region (point)(point))
 936     (insert "(define-char
 937   '")
 938     (insert-char-attributes char readable
 939                             attributes ccs-attributes)
 940     (insert ")\n")
 941     (goto-char (point-min))
 942     (while (re-search-forward "[ \t]+$" nil t)
 943       (replace-match ""))
 944     (goto-char (point-max))
 945     (tabify (point-min)(point-max))
 946     ))
 947
 948 ;;;###autoload
 949 (defun char-db-update-comment ()
 950   (interactive)
 951   (save-excursion
 952     (goto-char (point-min))
 953     (let (cdef table char)
 954       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 955         (goto-char (match-beginning 1))
 956         (setq cdef (read (current-buffer)))
 957         (when (find-charset (car cdef))
 958           (goto-char (match-end 0))
 959           (setq char
 960                 (if (and
 961                      (not (eq (car cdef) 'ideograph-daikanwa))
 962                      (or (memq (car cdef) '(ascii latin-viscii-upper
 963                                                   latin-viscii-lower
 964                                                   arabic-iso8859-6
 965                                                   japanese-jisx0213-1
 966                                                   japanese-jisx0213-2))
 967                          (= (char-int (charset-iso-final-char (car cdef)))
 968                             0)))
 969                     (apply (function make-char) cdef)
 970                   (if (setq table (charset-mapping-table (car cdef)))
 971                       (set-charset-mapping-table (car cdef) nil))
 972                   (prog1
 973                       (apply (function make-char) cdef)
 974                     (if table
 975                         (set-charset-mapping-table (car cdef) table)))))
 976           (when (not (or (< (char-int char) 32)
 977                          (and (<= 128 (char-int char))
 978                               (< (char-int char) 160))))
 979             (delete-region (point) (point-at-eol))
 980             (insert (format "\t; %c" char)))
 981           )))))
 982
 983 (defun insert-char-data-with-variant (char &optional printable
 984                                            no-ucs-variant
 985                                            script excluded-script)
 986   (insert-char-data char printable)
 987   (let ((variants (or (char-variants char)
 988                       (let ((ucs (get-char-attribute char '->ucs)))
 989                         (if ucs
 990                             (delete char (char-variants (int-char ucs)))))))
 991         variant vs)
 992     (setq variants (sort variants #'<))
 993     (while variants
 994       (setq variant (car variants))
 995       (if (and (or (null script)
 996                    (null (setq vs (get-char-attribute variant 'script)))
 997                    (memq script vs))
 998                (or (null excluded-script)
 999                    (null (setq vs (get-char-attribute variant 'script)))
1000                    (not (memq excluded-script vs))))
1001           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
1002               (insert-char-data variant printable)))
1003       (setq variants (cdr variants))
1004       )))
1005
1006 (defun insert-char-range-data (min max &optional script excluded-script)
1007   (let ((code min)
1008         char)
1009     (while (<= code max)
1010       (setq char (decode-char 'ucs code))
1011       (if (get-char-attribute char 'ucs)
1012           (insert-char-data-with-variant char nil 'no-ucs-variant
1013                                          script excluded-script))
1014       (setq code (1+ code))
1015       )))
1016
1017 (defun write-char-range-data-to-file (min max file
1018                                           &optional script excluded-script)
1019   (let ((coding-system-for-write 'utf-8))
1020     (with-temp-buffer
1021       (insert-char-range-data min max script excluded-script)
1022       (write-region (point-min)(point-max) file))))
1023
1024 (defvar what-character-original-window-configuration)
1025
1026 ;;;###autoload
1027 (defun what-char-definition (char)
1028   (interactive (list (char-after)))
1029   (let ((buf (get-buffer-create "*Character Description*"))
1030         (the-buf (current-buffer))
1031         (win-conf (current-window-configuration)))
1032     (pop-to-buffer buf)
1033     (make-local-variable 'what-character-original-window-configuration)
1034     (setq what-character-original-window-configuration win-conf)
1035     (setq buffer-read-only nil)
1036     (erase-buffer)
1037     (condition-case err
1038         (progn
1039           (insert-char-data-with-variant char 'printable)
1040           (unless (char-attribute-alist char)
1041             (insert (format ";; = %c\n"
1042                             (let* ((rest (split-char char))
1043                                    (ccs (pop rest))
1044                                    (code (pop rest)))
1045                               (while rest
1046                                 (setq code (logior (lsh code 8)
1047                                                    (pop rest))))
1048                               (decode-char ccs code)))))
1049           ;; (char-db-update-comment)
1050           (set-buffer-modified-p nil)
1051           (view-mode the-buf (lambda (buf)
1052                                (set-window-configuration
1053                                 what-character-original-window-configuration)
1054                                ))
1055           (goto-char (point-min)))
1056       (error (progn
1057                (set-window-configuration
1058                 what-character-original-window-configuration)
1059                (signal (car err) (cdr err)))))))
1060
1061 (provide 'char-db-util)
1062
1063 ;;; char-db-util.el ends here