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

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