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