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