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

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