git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility
   2
   3 ;; Copyright (C) 1998,1999,2000,2001,2002 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'alist)
  28
  29 (defconst unidata-normative-category-alist
  30   '(("Lu" letter        uppercase)
  31     ("Ll" letter        lowercase)
  32     ("Lt" letter        titlecase)
  33     ("Mn" mark          non-spacing)
  34     ("Mc" mark          spacing-combining)
  35     ("Me" mark          enclosing)
  36     ("Nd" number        decimal-digit)
  37     ("Nl" number        letter)
  38     ("No" number        other)
  39     ("Zs" separator     space)
  40     ("Zl" separator     line)
  41     ("Zp" separator     paragraph)
  42     ("Cc" other         control)
  43     ("Cf" other         format)
  44     ("Cs" other         surrogate)
  45     ("Co" other         private-use)
  46     ("Cn" other         not-assigned)))
  47
  48 (defconst unidata-informative-category-alist
  49   '(("Lm" letter        modifier)
  50     ("Lo" letter        other)
  51     ("Pc" punctuation   connector)
  52     ("Pd" punctuation   dash)
  53     ("Ps" punctuation   open)
  54     ("Pe" punctuation   close)
  55     ("Pi" punctuation   initial-quote)
  56     ("Pf" punctuation   final-quote)
  57     ("Po" punctuation   other)
  58     ("Sm" symbol        math)
  59     ("Sc" symbol        currency)
  60     ("Sk" symbol        modifier)
  61     ("So" symbol        other)
  62     ))
  63
  64 (defconst ideographic-radicals
  65   (let ((v (make-vector 215 nil))
  66         (i 1))
  67     (while (< i 215)
  68       (aset v i (int-char (+ #x2EFF i)))
  69       (setq i (1+ i)))
  70     (unless (charset-iso-final-char (car (split-char (aref v 34))))
  71       (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
  72     v))
  73
  74 ;;;###autoload
  75 (defun char-ref-p (obj)
  76   (and (consp obj)
  77        (keywordp (car obj))))
  78
  79 ;;;###autoload
  80 (defun char-ref= (cr1 cr2)
  81   (cond ((char-ref-p cr1)
  82          (if (char-ref-p cr2)
  83              (char-spec= (plist-get cr1 :char)
  84                          (plist-get cr2 :char))
  85            (char-spec= (plist-get cr1 :char) cr2)))
  86         (t
  87          (char-spec= cr1
  88                      (if (char-ref-p cr2)
  89                          (plist-get cr2 :char)
  90                        cr2)))))
  91
  92 ;;;###autoload
  93 (defun char-spec= (cs1 cs2)
  94   (if (characterp cs1)
  95       (if (characterp cs2)
  96           (eq cs1 cs2)
  97         (eq cs1 (find-char cs2)))
  98     (if (characterp cs2)
  99         (eq (find-char cs1) cs2)
 100       (eq (find-char cs1) (find-char cs2)))))
 101
 102 (defun char-attribute-name< (ka kb)
 103   (cond
 104    ((find-charset ka)
 105     (cond
 106      ((find-charset kb)
 107       (cond
 108        ((= (charset-dimension ka)
 109            (charset-dimension kb))
 110         (cond ((= (charset-chars ka)(charset-chars kb))
 111                (if (charset-iso-final-char ka)
 112                    (cond
 113                     ((>= (charset-iso-final-char ka) ?@)
 114                      (if (and (charset-iso-final-char kb)
 115                               (>= (charset-iso-final-char kb) ?@))
 116                          (< (charset-iso-final-char ka)
 117                             (charset-iso-final-char kb))
 118                        t))
 119                     (t
 120                      (if (charset-iso-final-char kb)
 121                          (if (>= (charset-iso-final-char kb) ?@)
 122                              nil
 123                            (< (charset-iso-final-char ka)
 124                               (charset-iso-final-char kb)))
 125                        t)))
 126                  (if (charset-iso-final-char kb)
 127                      nil
 128                    (< (charset-id ka)(charset-id kb)))))
 129               ((<= (charset-chars ka)(charset-chars kb)))))
 130        (t
 131         (< (charset-dimension ka)
 132            (charset-dimension kb))
 133         )))
 134      ((symbolp kb)
 135       nil)
 136      (t
 137       t)))
 138    ((find-charset kb)
 139     t)
 140    ((symbolp ka)
 141     (cond ((symbolp kb)
 142            (string< (symbol-name ka)
 143                     (symbol-name kb)))
 144           (t)))
 145    ((symbolp kb)
 146     nil)))
 147
 148 (defvar char-db-coded-charset-priority-list
 149   (let ((rest default-coded-charset-priority-list)
 150         dest)
 151     (while rest
 152       (when (symbolp (car rest))
 153         (cond ((memq (car rest)
 154                      '(latin-viscii-lower
 155                        latin-viscii-upper
 156                        ipa
 157                        lao
 158                        ethiopic
 159                        arabic-digit
 160                        arabic-1-column
 161                        arabic-2-column)))
 162               ((string-match "^mojikyo-" (symbol-name (car rest))))
 163               ((string-match "^chinese-big5" (symbol-name (car rest))))
 164               ((string-match "^ideograph-gt-pj-" (symbol-name (car rest)))
 165                (unless (memq 'ideograph-gt dest)
 166                  (setq dest (cons 'ideograph-gt dest))))
 167               (t
 168                (setq dest (cons (car rest) dest)))))
 169       (setq rest (cdr rest)))
 170     (append (sort dest #'char-attribute-name<)
 171             '(chinese-big5-cdp chinese-big5-eten chinese-big5))))
 172
 173 (defun char-db-insert-char-spec (char &optional readable column)
 174   (unless column
 175     (setq column (current-column)))
 176   (let (char-spec ret al cal key temp-char)
 177     (cond ((characterp char)
 178            (cond ((and (setq ret (get-char-attribute char 'ucs))
 179                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
 180                   (setq char-spec (list (cons 'ucs ret)))
 181                   (if (setq ret (get-char-attribute char 'name))
 182                       (setq char-spec (cons (cons 'name ret) char-spec)))
 183                   )
 184                  ((setq ret
 185                         (let ((default-coded-charset-priority-list
 186                                 char-db-coded-charset-priority-list))
 187                           (split-char char)))
 188                   (setq char-spec (list ret))
 189                   (dolist (ccs (delq (car ret) (charset-list)))
 190                     (if (or (and (charset-iso-final-char ccs)
 191                                  (setq ret (get-char-attribute char ccs)))
 192                             (eq ccs 'ideograph-daikanwa))
 193                         (setq char-spec (cons (cons ccs ret) char-spec))))
 194                   (if (null char-spec)
 195                       (setq char-spec (split-char char)))
 196                   (if (setq ret (get-char-attribute char 'name))
 197                       (setq char-spec (cons (cons 'name ret) char-spec)))
 198                   )))
 199           ((consp char)
 200            (setq char-spec char)
 201            (setq char nil)))
 202     (unless (or char
 203                 (condition-case nil
 204                     (setq char (find-char char-spec))
 205                   (error nil)))
 206       ;; define temporary character
 207       ;;   Current implementation is dirty.
 208       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
 209                                          char-spec)))
 210       (remove-char-attribute temp-char 'ideograph-daikanwa)
 211       (setq char temp-char))
 212     (setq al nil
 213           cal nil)
 214     (while char-spec
 215       (setq key (car (car char-spec)))
 216       (unless (memq key char-db-ignored-attributes)
 217         (if (find-charset key)
 218             (setq cal (cons key cal))
 219           (setq al (cons key al))))
 220       (setq char-spec (cdr char-spec)))
 221     (unless (or cal
 222                 (memq 'ideographic-structure al))
 223       (push 'ideographic-structure al))
 224     (insert-char-attributes char
 225                             readable
 226                             (or al 'none) cal)
 227     (when temp-char
 228       ;; undefine temporary character
 229       ;;   Current implementation is dirty.
 230       (setq char-spec (char-attribute-alist temp-char))
 231       (while char-spec
 232         (remove-char-attribute temp-char (car (car char-spec)))
 233         (setq char-spec (cdr char-spec))))))
 234
 235 (defun char-db-insert-alist (alist &optional readable column)
 236   (unless column
 237     (setq column (current-column)))
 238   (let ((line-breaking
 239          (concat "\n" (make-string (1+ column) ?\ )))
 240         name value
 241         ret al cal key
 242         lbs cell rest separator)
 243     (insert "(")
 244     (while alist
 245       (setq name (car (car alist))
 246             value (cdr (car alist)))
 247       (cond ((eq name 'char)
 248              (insert "(char . ")
 249              (if (setq ret (condition-case nil
 250                                (find-char value)
 251                              (error nil)))
 252                  (progn
 253                    (setq al nil
 254                          cal nil)
 255                    (while value
 256                      (setq key (car (car value)))
 257                      (if (find-charset key)
 258                          (setq cal (cons key cal))
 259                        (setq al (cons key al)))
 260                      (setq value (cdr value)))
 261                    (insert-char-attributes ret
 262                                            readable
 263                                            (or al 'none) cal))
 264                (insert (prin1-to-string value)))
 265              (insert ")")
 266              (insert line-breaking))
 267             ((consp value)
 268              (insert (format "(%-18s " name))
 269              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
 270              (while (consp value)
 271                (setq cell (car value))
 272                (if (and (consp cell)
 273                         (consp (car cell))
 274                         (setq ret (condition-case nil
 275                                       (find-char cell)
 276                                     (error nil)))
 277                         )
 278                    (progn
 279                      (setq rest cell
 280                            al nil
 281                            cal nil)
 282                      (while rest
 283                        (setq key (car (car rest)))
 284                        (if (find-charset key)
 285                            (setq cal (cons key cal))
 286                          (setq al (cons key al)))
 287                        (setq rest (cdr rest)))
 288                      (if separator
 289                          (insert lbs))
 290                      (insert-char-attributes ret
 291                                              readable
 292                                              al cal)
 293                      (setq separator lbs))
 294                  (if separator
 295                      (insert separator))
 296                  (insert (prin1-to-string cell))
 297                  (setq separator " "))
 298                (setq value (cdr value)))
 299              (insert ")")
 300              (insert line-breaking))
 301             (t
 302              (insert (format "(%-18s . %S)%s"
 303                              name value
 304                              line-breaking))))
 305       (setq alist (cdr alist))))
 306   (insert ")"))
 307
 308 (defun char-db-insert-char-reference (plist &optional readable column)
 309   (unless column
 310     (setq column (current-column)))
 311   (let ((line-breaking
 312          (concat "\n" (make-string (1+ column) ?\ )))
 313         name value)
 314     (insert "(")
 315     (while plist
 316       (setq name (pop plist))
 317       (setq value (pop plist))
 318       (cond ((eq name :char)
 319              (insert ":char\t")
 320              (cond ((numberp value)
 321                     (setq value (decode-char 'ucs value)))
 322                    ;; ((consp value)
 323                    ;;  (setq value (or (find-char value)
 324                    ;;                  value)))
 325                    )
 326              (char-db-insert-char-spec value readable)
 327              (insert line-breaking))
 328             (t
 329              (insert (format "%s\t%S%s"
 330                              name value
 331                              line-breaking))))
 332       ))
 333   (insert ")"))
 334
 335 (defun char-db-decode-isolated-char (ccs code-point)
 336   (let (ret)
 337     (setq ret
 338           (cond ((eq ccs 'arabic-iso8859-6)
 339                  (decode-char ccs code-point))
 340                 ((and (memq ccs '(ideograph-gt-pj-1
 341                                   ideograph-gt-pj-2
 342                                   ideograph-gt-pj-3
 343                                   ideograph-gt-pj-4
 344                                   ideograph-gt-pj-5
 345                                   ideograph-gt-pj-6
 346                                   ideograph-gt-pj-7
 347                                   ideograph-gt-pj-8
 348                                   ideograph-gt-pj-9
 349                                   ideograph-gt-pj-10
 350                                   ideograph-gt-pj-11))
 351                       (setq ret (decode-char ccs code-point))
 352                       (setq ret (get-char-attribute ret 'ideograph-gt)))
 353                  (decode-builtin-char 'ideograph-gt ret))
 354                 (t
 355                  (decode-builtin-char ccs code-point))))
 356     (cond ((and (<= 0 (char-int ret))
 357                 (<= (char-int ret) #x1F))
 358            (decode-char 'ucs (+ #x2400 (char-int ret))))
 359           ((= (char-int ret) #x7F)
 360            ?\u2421)
 361           (t ret))))
 362
 363 (defvar char-db-convert-obsolete-format t)
 364
 365 (defvar char-db-ignored-attributes nil)
 366
 367 (defun insert-char-attributes (char &optional readable
 368                                     attributes ccs-attributes
 369                                     column)
 370   (let (atr-d ccs-d)
 371     (setq attributes
 372           (sort (if attributes
 373                     (if (consp attributes)
 374                         (progn
 375                           (dolist (name attributes)
 376                             (unless (memq name char-db-ignored-attributes)
 377                               (push name atr-d)))
 378                           atr-d))
 379                   (dolist (name (char-attribute-list))
 380                     (unless (memq name char-db-ignored-attributes)
 381                       (if (find-charset name)
 382                           (push name ccs-d)
 383                         (push name atr-d))))
 384                   atr-d)
 385                 #'char-attribute-name<))
 386     (setq ccs-attributes
 387           (sort (if ccs-attributes
 388                     (progn
 389                       (setq ccs-d nil)
 390                       (dolist (name ccs-attributes)
 391                         (unless (memq name char-db-ignored-attributes)
 392                           (push name ccs-d)))
 393                       ccs-d)
 394                   (or ccs-d
 395                       (progn
 396                         (dolist (name (charset-list))
 397                           (unless (memq name char-db-ignored-attributes)
 398                             (push name ccs-d)))
 399                         ccs-d)))
 400                 #'char-attribute-name<)))
 401   (unless column
 402     (setq column (current-column)))
 403   (let (name value has-long-ccs-name rest
 404         radical strokes
 405         (line-breaking
 406          (concat "\n" (make-string (1+ column) ?\ )))
 407         lbs cell separator ret
 408         key al cal)
 409     (insert "(")
 410     (when (and (memq 'name attributes)
 411                (setq value (get-char-attribute char 'name)))
 412       (insert (format
 413                (if (> (+ (current-column) (length value)) 48)
 414                    "(name . %S)%s"
 415                  "(name               . %S)%s")
 416                value line-breaking))
 417       (setq attributes (delq 'name attributes))
 418       )
 419     (when (and (memq 'script attributes)
 420                (setq value (get-char-attribute char 'script)))
 421       (insert (format "(script\t\t%s)%s"
 422                       (mapconcat (function prin1-to-string)
 423                                  value " ")
 424                       line-breaking))
 425       (setq attributes (delq 'script attributes))
 426       )
 427     (when (and (memq '=>ucs attributes)
 428                (setq value (get-char-attribute char '=>ucs)))
 429       (insert (format "(=>ucs\t\t. #x%04X)\t; %c%s"
 430                       value (decode-char 'ucs value)
 431                       line-breaking))
 432       (setq attributes (delq '=>ucs attributes))
 433       )
 434     (when (and (memq '=>ucs* attributes)
 435                (setq value (get-char-attribute char '=>ucs*)))
 436       (insert (format "(=>ucs*\t\t. #x%04X)\t; %c%s"
 437                       value (decode-char 'ucs value)
 438                       line-breaking))
 439       (setq attributes (delq '=>ucs* attributes))
 440       )
 441     (when (and (memq '=>ucs-jis attributes)
 442                (setq value (get-char-attribute char '=>ucs-jis)))
 443       (insert (format "(=>ucs-jis\t\t. #x%04X)\t; %c%s"
 444                       value (decode-char 'ucs value)
 445                       line-breaking))
 446       (setq attributes (delq '=>ucs-jis attributes))
 447       )
 448     (when (and (memq '->ucs attributes)
 449                (setq value (get-char-attribute char '->ucs)))
 450       (insert (format (if char-db-convert-obsolete-format
 451                           "(=>ucs\t\t. #x%04X)\t; %c%s"
 452                         "(->ucs\t\t. #x%04X)\t; %c%s")
 453                       value (decode-char 'ucs value)
 454                       line-breaking))
 455       (setq attributes (delq '->ucs attributes))
 456       )
 457     (when (and (memq 'general-category attributes)
 458                (setq value (get-char-attribute char 'general-category)))
 459       (insert (format
 460                "(general-category\t%s) ; %s%s"
 461                (mapconcat (lambda (cell)
 462                             (format "%S" cell))
 463                           value " ")
 464                (cond ((rassoc value unidata-normative-category-alist)
 465                       "Normative Category")
 466                      ((rassoc value unidata-informative-category-alist)
 467                       "Informative Category")
 468                      (t
 469                       "Unknown Category"))
 470                line-breaking))
 471       (setq attributes (delq 'general-category attributes))
 472       )
 473     (when (and (memq 'bidi-category attributes)
 474                (setq value (get-char-attribute char 'bidi-category)))
 475       (insert (format "(bidi-category\t. %S)%s"
 476                       value
 477                       line-breaking))
 478       (setq attributes (delq 'bidi-category attributes))
 479       )
 480     (unless (or (not (memq 'mirrored attributes))
 481                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
 482                     'empty))
 483       (insert (format "(mirrored\t\t. %S)%s"
 484                       value
 485                       line-breaking))
 486       (setq attributes (delq 'mirrored attributes))
 487       )
 488     (cond
 489      ((and (memq 'decimal-digit-value attributes)
 490            (setq value (get-char-attribute char 'decimal-digit-value)))
 491       (insert (format "(decimal-digit-value . %S)%s"
 492                       value
 493                       line-breaking))
 494       (setq attributes (delq 'decimal-digit-value attributes))
 495       (when (and (memq 'digit-value attributes)
 496                  (setq value (get-char-attribute char 'digit-value)))
 497         (insert (format "(digit-value\t . %S)%s"
 498                         value
 499                         line-breaking))
 500         (setq attributes (delq 'digit-value attributes))
 501         )
 502       (when (and (memq 'numeric-value attributes)
 503                  (setq value (get-char-attribute char 'numeric-value)))
 504         (insert (format "(numeric-value\t . %S)%s"
 505                         value
 506                         line-breaking))
 507         (setq attributes (delq 'numeric-value attributes))
 508         )
 509       )
 510      (t
 511       (when (and (memq 'digit-value attributes)
 512                  (setq value (get-char-attribute char 'digit-value)))
 513         (insert (format "(digit-value\t. %S)%s"
 514                         value
 515                         line-breaking))
 516         (setq attributes (delq 'digit-value attributes))
 517         )
 518       (when (and (memq 'numeric-value attributes)
 519                  (setq value (get-char-attribute char 'numeric-value)))
 520         (insert (format "(numeric-value\t. %S)%s"
 521                         value
 522                         line-breaking))
 523         (setq attributes (delq 'numeric-value attributes))
 524         )))
 525     (when (and (memq 'iso-10646-comment attributes)
 526                (setq value (get-char-attribute char 'iso-10646-comment)))
 527       (insert (format "(iso-10646-comment\t. %S)%s"
 528                       value
 529                       line-breaking))
 530       (setq attributes (delq 'iso-10646-comment attributes))
 531       )
 532     (when (and (memq 'morohashi-daikanwa attributes)
 533                (setq value (get-char-attribute char 'morohashi-daikanwa)))
 534       (insert (format "(morohashi-daikanwa\t%s)%s"
 535                       (mapconcat (function prin1-to-string) value " ")
 536                       line-breaking))
 537       (setq attributes (delq 'morohashi-daikanwa attributes))
 538       )
 539     ;; (when (and (memq 'hanyu-dazidian attributes)
 540     ;;            (setq value (get-char-attribute char 'hanyu-dazidian)))
 541     ;;   (insert (format "(hanyu-dazidian     %s)%s"
 542     ;;                   (mapconcat #'number-to-string value " ")
 543     ;;                   line-breaking))
 544     ;;   (setq attributes (delq 'hanyu-dazidian attributes))
 545     ;;   )
 546     (setq radical nil
 547           strokes nil)
 548     (when (and (memq 'ideographic-radical attributes)
 549                (setq value (get-char-attribute char 'ideographic-radical)))
 550       (setq radical value)
 551       (insert (format "(ideographic-radical . %S)\t; %c%s"
 552                       radical
 553                       (aref ideographic-radicals radical)
 554                       line-breaking))
 555       (setq attributes (delq 'ideographic-radical attributes))
 556       )
 557     (when (and (memq 'ideographic-strokes attributes)
 558                (setq value (get-char-attribute char 'ideographic-strokes)))
 559       (setq strokes value)
 560       (insert (format "(ideographic-strokes . %S)%s"
 561                       strokes
 562                       line-breaking))
 563       (setq attributes (delq 'ideographic-strokes attributes))
 564       )
 565     (when (and (memq 'kangxi-radical attributes)
 566                (setq value (get-char-attribute char 'kangxi-radical)))
 567       (unless (eq value radical)
 568         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
 569                         value
 570                         (aref ideographic-radicals value)
 571                         line-breaking))
 572         (or radical
 573             (setq radical value)))
 574       (setq attributes (delq 'kangxi-radical attributes))
 575       )
 576     (when (and (memq 'kangxi-strokes attributes)
 577                (setq value (get-char-attribute char 'kangxi-strokes)))
 578       (unless (eq value strokes)
 579         (insert (format "(kangxi-strokes\t . %S)%s"
 580                         value
 581                         line-breaking))
 582         (or strokes
 583             (setq strokes value)))
 584       (setq attributes (delq 'kangxi-strokes attributes))
 585       )
 586     (when (and (memq 'japanese-radical attributes)
 587                (setq value (get-char-attribute char 'japanese-radical)))
 588       (unless (eq value radical)
 589         (insert (format "(japanese-radical\t . %S)\t; %c%s"
 590                         value
 591                         (aref ideographic-radicals value)
 592                         line-breaking))
 593         (or radical
 594             (setq radical value)))
 595       (setq attributes (delq 'japanese-radical attributes))
 596       )
 597     (when (and (memq 'japanese-strokes attributes)
 598                (setq value (get-char-attribute char 'japanese-strokes)))
 599       (unless (eq value strokes)
 600         (insert (format "(japanese-strokes\t . %S)%s"
 601                         value
 602                         line-breaking))
 603         (or strokes
 604             (setq strokes value)))
 605       (setq attributes (delq 'japanese-strokes attributes))
 606       )
 607     (when (and (memq 'cns-radical attributes)
 608                (setq value (get-char-attribute char 'cns-radical)))
 609       (insert (format "(cns-radical\t . %S)\t; %c%s"
 610                       value
 611                       (aref ideographic-radicals value)
 612                       line-breaking))
 613       (setq attributes (delq 'cns-radical attributes))
 614       )
 615     (when (and (memq 'cns-strokes attributes)
 616                (setq value (get-char-attribute char 'cns-strokes)))
 617       (unless (eq value strokes)
 618         (insert (format "(cns-strokes\t . %S)%s"
 619                         value
 620                         line-breaking))
 621         (or strokes
 622             (setq strokes value)))
 623       (setq attributes (delq 'cns-strokes attributes))
 624       )
 625     (when (and (memq 'shinjigen-1-radical attributes)
 626                (setq value (get-char-attribute char 'shinjigen-1-radical)))
 627       (unless (eq value radical)
 628         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
 629                         value
 630                         (aref ideographic-radicals value)
 631                         line-breaking))
 632         (or radical
 633             (setq radical value)))
 634       (setq attributes (delq 'shinjigen-1-radical attributes))
 635       )
 636     (when (and (memq 'total-strokes attributes)
 637                (setq value (get-char-attribute char 'total-strokes)))
 638       (insert (format "(total-strokes       . %S)%s"
 639                       value
 640                       line-breaking))
 641       (setq attributes (delq 'total-strokes attributes))
 642       )
 643     (when (and (memq '->ideograph attributes)
 644                (setq value (get-char-attribute char '->ideograph)))
 645       (insert (format "(->ideograph\t%s)%s"
 646                       (mapconcat (lambda (code)
 647                                    (cond ((symbolp code)
 648                                           (symbol-name code))
 649                                          ((integerp code)
 650                                           (format "#x%04X" code))
 651                                          (t
 652                                           (format "%s %S"
 653                                                   line-breaking code))))
 654                                  value " ")
 655                       line-breaking))
 656       (setq attributes (delq '->ideograph attributes))
 657       )
 658     (when (and (memq '->decomposition attributes)
 659                (setq value (get-char-attribute char '->decomposition)))
 660       (insert (format "(->decomposition\t%s)%s"
 661                       (mapconcat (lambda (code)
 662                                    (cond ((symbolp code)
 663                                           (symbol-name code))
 664                                          ((characterp code)
 665                                           (if readable
 666                                               (format "%S" code)
 667                                             (format "#x%04X"
 668                                                     (char-int code))
 669                                             ))
 670                                          ((integerp code)
 671                                           (format "#x%04X" code))
 672                                          (t
 673                                           (format "%s%S" line-breaking code))))
 674                                  value " ")
 675                       line-breaking))
 676       (setq attributes (delq '->decomposition attributes))
 677       )
 678     (if (equal (get-char-attribute char '->titlecase)
 679                (get-char-attribute char '->uppercase))
 680         (setq attributes (delq '->titlecase attributes)))
 681     (when (and (memq '->mojikyo attributes)
 682                (setq value (get-char-attribute char '->mojikyo)))
 683       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
 684                       value (decode-char 'mojikyo value)
 685                       line-breaking))
 686       (setq attributes (delq '->mojikyo attributes))
 687       )
 688     (when (and (memq 'hanyu-dazidian-vol attributes)
 689                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
 690       (insert (format "(hanyu-dazidian-vol  . %d)%s"
 691                       value line-breaking))
 692       (setq attributes (delq 'hanyu-dazidian-vol attributes))
 693       )
 694     (when (and (memq 'hanyu-dazidian-page attributes)
 695                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
 696       (insert (format "(hanyu-dazidian-page . %d)%s"
 697                       value line-breaking))
 698       (setq attributes (delq 'hanyu-dazidian-page attributes))
 699       )
 700     (when (and (memq 'hanyu-dazidian-char attributes)
 701                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
 702       (insert (format "(hanyu-dazidian-char . %d)%s"
 703                       value line-breaking))
 704       (setq attributes (delq 'hanyu-dazidian-char attributes))
 705       )
 706     (setq rest ccs-attributes)
 707     (while (and rest
 708                 (progn
 709                   (setq value (get-char-attribute char (car rest)))
 710                   (if value
 711                       (if (>= (length (symbol-name (car rest))) 19)
 712                           (progn
 713                             (setq has-long-ccs-name t)
 714                             nil)
 715                         t)
 716                     t)))
 717       (setq rest (cdr rest)))
 718     (while attributes
 719       (setq name (car attributes))
 720       (if (setq value (get-char-attribute char name))
 721           (cond ((eq name 'jisx0208-1978/4X)
 722                  (insert (format "(%-18s . #x%04X)%s"
 723                                  name value
 724                                  line-breaking)))
 725                 ((memq name '(->lowercase
 726                               ->uppercase ->titlecase
 727                               ->fullwidth <-fullwidth
 728                               ->identical
 729                               ->vulgar-ideograph <-vulgar-ideograph
 730                               ->ancient-ideograph <-ancient-ideograph
 731                               ->original-ideograph <-original-ideograph
 732                               ->simplified-ideograph <-simplified-ideograph
 733                               ->wrong-ideograph <-wrong-ideograph
 734                               ->same-ideograph
 735                               ->ideographic-variants
 736                               ->synonyms
 737                               ->radical <-radical
 738                               ->bopomofo <-bopomofo
 739                               ->ideographic <-ideographic
 740                               ideographic-structure))
 741                  (insert (format "(%-18s%s " name line-breaking))
 742                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
 743                        separator nil)
 744                  (while (consp value)
 745                    (setq cell (car value))
 746                    (if (integerp cell)
 747                        (setq cell (decode-char 'ucs cell)))
 748                    (cond ((characterp cell)
 749                           (if separator
 750                               (insert lbs))
 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