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