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