lisp/utf-2000/char-db-util.el

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