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

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