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

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