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 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 UTF-2000.
   9
  10 ;; UTF-2000 is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; UTF-2000 is distributed in the hope that it will be useful, but
  16 ;; 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; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 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     (if (< (charset-iso-final-char (car (split-char (aref v 34)))) ?0)
  71         (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A)))
  72     v))
  73
  74 (defun char-attribute-name< (ka kb)
  75   (cond
  76    ((find-charset ka)
  77     (cond
  78      ((find-charset kb)
  79       (cond
  80        ((= (charset-dimension ka)
  81            (charset-dimension kb))
  82         (cond ((= (charset-chars ka)(charset-chars kb))
  83                (cond
  84                 ((>= (charset-iso-final-char ka) ?@)
  85                  (if (>= (charset-iso-final-char kb) ?@)
  86                      (< (charset-iso-final-char ka)
  87                         (charset-iso-final-char kb))
  88                    t))
  89                 ((>= (charset-iso-final-char ka) ?0)
  90                  (cond
  91                   ((>= (charset-iso-final-char kb) ?@)
  92                    nil)
  93                   ((>= (charset-iso-final-char kb) ?0)
  94                    (< (charset-iso-final-char ka)
  95                       (charset-iso-final-char kb)))
  96                   (t)))))
  97               ((<= (charset-chars ka)(charset-chars kb)))))
  98        (t
  99         (< (charset-dimension ka)
 100            (charset-dimension kb))
 101         )))
 102      ((symbolp kb)
 103       nil)
 104      (t
 105       t)))
 106    ((find-charset kb)
 107     t)
 108    ((symbolp ka)
 109     (cond ((symbolp kb)
 110            (string< (symbol-name ka)
 111                     (symbol-name kb)))
 112           (t)))
 113    ((symbolp kb)
 114     nil)))
 115
 116 (defun insert-char-data (char &optional readable
 117                               attributes ccs-attributes)
 118   (setq attributes
 119         (if attributes
 120             (copy-sequence attributes)
 121           (sort (char-attribute-list) #'char-attribute-name<)))
 122   (setq ccs-attributes
 123         (if ccs-attributes
 124             (copy-sequence ccs-attributes)
 125           (sort (charset-list) #'char-attribute-name<)))
 126   (let (name value has-long-ccs-name rest
 127         radical strokes)
 128     (save-restriction
 129       (narrow-to-region (point)(point))
 130       (insert "(define-char
 131   '(")
 132       (when (setq value (get-char-attribute char 'name))
 133         (insert (format
 134                  (if (> (length value) 47)
 135                      "(name . %S)
 136     "
 137                    "(name\t\t. %S)
 138     ")
 139                  value))
 140         (setq attributes (delq 'name attributes))
 141         )
 142       (when (setq value (get-char-attribute char 'script))
 143         (insert (format "(script\t\t%s)
 144     "
 145                         (mapconcat (function prin1-to-string)
 146                                    value " ")))
 147         (setq attributes (delq 'script attributes))
 148         )
 149       (when (setq value (get-char-attribute char '->ucs))
 150         (insert (format "(->ucs\t\t. #x%04X)\t; %c
 151     "
 152                         value (decode-char 'ucs value)))
 153         (setq attributes (delq '->ucs attributes))
 154         )
 155       (when (setq value (get-char-attribute char 'general-category))
 156         (insert (format
 157                  "(general-category\t%s) ; %s
 158     "
 159                  (mapconcat (lambda (cell)
 160                               (format "%S" cell))
 161                             value " ")
 162                  (cond ((rassoc value unidata-normative-category-alist)
 163                         "Normative Category")
 164                        ((rassoc value unidata-informative-category-alist)
 165                         "Informative Category")
 166                        (t
 167                         "Unknown Category"))))
 168         (setq attributes (delq 'general-category attributes))
 169         )
 170       (when (setq value (get-char-attribute char 'bidi-category))
 171         (insert (format "(bidi-category\t. %S)
 172     "
 173                         value))
 174         (setq attributes (delq 'bidi-category attributes))
 175         )
 176       (when (setq value (get-char-attribute char 'mirrored))
 177         (insert (format "(mirrored\t\t. %S)
 178     "
 179                         value))
 180         (setq attributes (delq 'mirrored attributes))
 181         )
 182       (cond
 183        ((setq value (get-char-attribute char 'decimal-digit-value))
 184         (insert (format "(decimal-digit-value . %S)
 185     "
 186                         value))
 187         (setq attributes (delq 'decimal-digit-value attributes))
 188         (when (setq value (get-char-attribute char 'digit-value))
 189           (insert (format "(digit-value\t . %S)
 190     "
 191                           value))
 192           (setq attributes (delq 'digit-value attributes))
 193           )
 194         (when (setq value (get-char-attribute char 'numeric-value))
 195           (insert (format "(numeric-value\t . %S)
 196     "
 197                           value))
 198           (setq attributes (delq 'numeric-value attributes))
 199           )
 200         )
 201        (t
 202         (when (setq value (get-char-attribute char 'digit-value))
 203           (insert (format "(digit-value\t. %S)
 204     "
 205                           value))
 206           (setq attributes (delq 'digit-value attributes))
 207           )
 208         (when (setq value (get-char-attribute char 'numeric-value))
 209           (insert (format "(numeric-value\t. %S)
 210     "
 211                           value))
 212           (setq attributes (delq 'numeric-value attributes))
 213           )))
 214       (when (setq value (get-char-attribute char 'iso-10646-comment))
 215         (insert (format "(iso-10646-comment\t. %S)
 216     "
 217                         value))
 218         (setq attributes (delq 'iso-10646-comment attributes))
 219         )
 220       (when (setq value (get-char-attribute char 'morohashi-daikanwa))
 221         (insert (format "(morohashi-daikanwa\t%s)
 222     "
 223                         (mapconcat (function prin1-to-string) value " ")))
 224         (setq attributes (delq 'morohashi-daikanwa attributes))
 225         )
 226       (setq radical nil
 227             strokes nil)
 228       (when (setq value (get-char-attribute char 'ideographic-radical))
 229         (setq radical value)
 230         (insert (format "(ideographic-radical . %S)\t; %c
 231     "
 232                         radical
 233                         (aref ideographic-radicals radical)))
 234         (setq attributes (delq 'ideographic-radical attributes))
 235         )
 236       (when (setq value (get-char-attribute char 'ideographic-strokes))
 237         (setq strokes value)
 238         (insert (format "(ideographic-strokes . %S)
 239     "
 240                         strokes))
 241         (setq attributes (delq 'ideographic-strokes attributes))
 242         )
 243       (when (setq value (get-char-attribute char 'kangxi-radical))
 244         (unless (eq value radical)
 245           (insert (format "(kangxi-radical\t . %S)\t; %c
 246     "
 247                           value
 248                           (aref ideographic-radicals value)))
 249           (or radical
 250               (setq radical value)))
 251         (setq attributes (delq 'kangxi-radical attributes))
 252         )
 253       (when (setq value (get-char-attribute char 'kangxi-strokes))
 254         (unless (eq value strokes)
 255           (insert (format "(kangxi-strokes\t . %S)
 256     "
 257                           value))
 258           (or strokes
 259               (setq strokes value)))
 260         (setq attributes (delq 'kangxi-strokes attributes))
 261         )
 262       (when (setq value (get-char-attribute char 'japanese-radical))
 263         (unless (eq value radical)
 264           (insert (format "(japanese-radical\t . %S)\t; %c
 265     "
 266                           value
 267                           (aref ideographic-radicals value)))
 268           (or radical
 269               (setq radical value)))
 270         (setq attributes (delq 'japanese-radical attributes))
 271         )
 272       (when (setq value (get-char-attribute char 'japanese-strokes))
 273         (unless (eq value strokes)
 274           (insert (format "(japanese-strokes\t . %S)
 275     "
 276                           value))
 277           (or strokes
 278               (setq strokes value)))
 279         (setq attributes (delq 'japanese-strokes attributes))
 280         )
 281       (when (setq value (get-char-attribute char 'cns-radical))
 282         (insert (format "(cns-radical\t . %S)\t; %c
 283     "
 284                         value
 285                         (aref ideographic-radicals value)))
 286         (setq attributes (delq 'cns-radical attributes))
 287         )
 288       (when (setq value (get-char-attribute char 'cns-strokes))
 289         (unless (eq value strokes)
 290           (insert (format "(cns-strokes\t . %S)
 291     "
 292                           value))
 293           (or strokes
 294               (setq strokes value)))
 295         (setq attributes (delq 'cns-strokes attributes))
 296         )
 297       (when (setq value (get-char-attribute char 'shinjigen-1-radical))
 298         (unless (eq value radical)
 299           (insert (format "(shinjigen-1-radical . %S)\t; %c
 300     "
 301                           value
 302                           (aref ideographic-radicals value)))
 303           (or radical
 304               (setq radical value)))
 305         (setq attributes (delq 'shinjigen-1-radical attributes))
 306         )
 307       (when (setq value (get-char-attribute char 'total-strokes))
 308         (insert (format "(total-strokes\t . %S)
 309     "
 310                         value))
 311         (setq attributes (delq 'total-strokes attributes))
 312         )
 313       (when (setq value (get-char-attribute char '->ideograph))
 314         (insert (format "(->ideograph\t%s)
 315     "
 316                         (mapconcat (lambda (code)
 317                                      (cond ((symbolp code)
 318                                             (symbol-name code))
 319                                            ((integerp code)
 320                                             (format "#x%04X" code))
 321                                            (t
 322                                             (format "\n     %S" code))))
 323                                    value " ")))
 324         (setq attributes (delq '->ideograph attributes))
 325         )
 326       (when (setq value (get-char-attribute char '->decomposition))
 327         (insert (format "(->decomposition\t%s)
 328     "
 329                         (mapconcat (lambda (code)
 330                                      (cond ((symbolp code)
 331                                             (symbol-name code))
 332                                            ((characterp code)
 333                                             (if readable
 334                                                 (format "%S" code)
 335                                               (format "#x%04X"
 336                                                       (char-int code))
 337                                               ))
 338                                            ((integerp code)
 339                                             (format "#x%04X" code))
 340                                            (t
 341                                             (format "\n     %S" code))))
 342                                    value " ")))
 343         (setq attributes (delq '->decomposition attributes))
 344         )
 345       (when (setq value (get-char-attribute char '->uppercase))
 346         (insert (format "(->uppercase\t%s)
 347     "
 348                         (mapconcat (lambda (code)
 349                                      (cond ((symbolp code)
 350                                             (symbol-name code))
 351                                            ((integerp code)
 352                                             (format "#x%04X" code))
 353                                            (t
 354                                             (format "\n     %S" code))))
 355                                    value " ")))
 356         (setq attributes (delq '->uppercase attributes))
 357         )
 358       (when (setq value (get-char-attribute char '->lowercase))
 359         (insert (format "(->lowercase\t%s)
 360     "
 361                         (mapconcat (lambda (code)
 362                                      (cond ((symbolp code)
 363                                             (symbol-name code))
 364                                            ((integerp code)
 365                                             (format "#x%04X" code))
 366                                            (t
 367                                             (format "\n     %S" code))))
 368                                    value " ")))
 369         (setq attributes (delq '->lowercase attributes))
 370         )
 371       (when (setq value (get-char-attribute char '->titlecase))
 372         (insert (format "(->titlecase\t%s)
 373     "
 374                         (mapconcat (lambda (code)
 375                                      (cond ((symbolp code)
 376                                             (symbol-name code))
 377                                            ((integerp code)
 378                                             (format "#x%04X" code))
 379                                            (t
 380                                             (format "\n     %S" code))))
 381                                    value " ")))
 382         (setq attributes (delq '->titlecase attributes))
 383         )
 384       (when (setq value (get-char-attribute char '->mojikyo))
 385         (insert (format "(->mojikyo\t\t. %06d)\t; %c
 386     "
 387                         value (decode-char 'mojikyo value)))
 388         (setq attributes (delq '->mojikyo attributes))
 389         )
 390       (setq rest ccs-attributes)
 391       (while (and rest
 392                     (progn
 393                       (setq value (get-char-attribute char (car rest)))
 394                       (if value
 395                           (if (>= (length (symbol-name (car rest))) 19)
 396                               (progn
 397                                 (setq has-long-ccs-name t)
 398                                 nil)
 399                             t)
 400                         t)))
 401           (setq rest (cdr rest)))
 402       (while attributes
 403         (setq name (car attributes))
 404         (if (setq value (get-char-attribute char name))
 405             (cond ((string-match "^->" (symbol-name name))
 406                    (insert
 407                     (format "(%-18s %s)
 408     "
 409                             name
 410                             (mapconcat (lambda (code)
 411                                          (cond ((symbolp code)
 412                                                 (symbol-name code))
 413                                                ((integerp code)
 414                                                 (format "#x%04X" code))
 415                                                (t
 416                                                 (format "\n     %S" code))))
 417                                        value " "))))
 418                   ((consp value)
 419                    (insert (format "(%-18s %s)
 420     "
 421                                    name
 422                                    (mapconcat (function prin1-to-string)
 423                                               value " "))))
 424                   ((eq name 'jisx0208-1978/4X)
 425                    (insert (format "(%-18s . #x%04X)
 426     "
 427                                    name value)))
 428                   (t
 429                    (insert (format "(%-18s . %S)
 430     "
 431                                    name value)))
 432                   ))
 433         (setq attributes (cdr attributes)))
 434       (while ccs-attributes
 435         (setq name (car ccs-attributes))
 436         (if (setq value (get-char-attribute char name))
 437             (insert
 438              (format
 439               (if has-long-ccs-name
 440                   (cond ((eq name 'ideograph-daikanwa)
 441                          "(%-26s . %05d)\t; %c
 442     "
 443                          )
 444                         ((eq name 'mojikyo)
 445                          "(%-26s . %06d)\t; %c
 446     "
 447                          )
 448                         (t
 449                          "(%-26s . #x%X)\t; %c
 450     "
 451                          ))
 452                 (cond ((eq name 'ideograph-daikanwa)
 453                        "(%-18s . %05d)\t; %c
 454     "
 455                        )
 456                       ((eq name 'mojikyo)
 457                        "(%-18s . %06d)\t; %c
 458     "
 459                        )
 460                       (t
 461                        "(%-18s . #x%X)\t; %c
 462     "
 463                        )))
 464               name
 465               (if (= (charset-iso-graphic-plane name) 1)
 466                   (logior value
 467                           (cond ((= (charset-dimension name) 1)
 468                                  #x80)
 469                                 ((= (charset-dimension name) 2)
 470                                  #x8080)
 471                                 ((= (charset-dimension name) 3)
 472                                  #x808080)
 473                                 (t 0)))
 474                 value)
 475               (decode-builtin-char name value))))
 476         (setq ccs-attributes (cdr ccs-attributes)))
 477       (insert "))\n")
 478       (goto-char (point-min))
 479       (while (re-search-forward "[ \t]+$" nil t)
 480         (replace-match ""))
 481       (goto-char (point-max))
 482       (tabify (point-min)(point-max))
 483       )))
 484
 485 ;;;###autoload
 486 (defun char-db-update-comment ()
 487   (interactive)
 488   (save-excursion
 489     (goto-char (point-min))
 490     (let (cdef table char)
 491       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 492         (goto-char (match-beginning 1))
 493         (setq cdef (read (current-buffer)))
 494         (when (find-charset (car cdef))
 495           (goto-char (match-end 0))
 496           (setq char
 497                 (if (and
 498                      (not (eq (car cdef) 'ideograph-daikanwa))
 499                      (or (memq (car cdef) '(ascii latin-viscii-upper
 500                                                   latin-viscii-lower
 501                                                   arabic-iso8859-6
 502                                                   japanese-jisx0213-1
 503                                                   japanese-jisx0213-2))
 504                          (= (char-int (charset-iso-final-char (car cdef)))
 505                             0)))
 506                     (apply (function make-char) cdef)
 507                   (if (setq table (charset-mapping-table (car cdef)))
 508                       (set-charset-mapping-table (car cdef) nil))
 509                   (prog1
 510                       (apply (function make-char) cdef)
 511                     (if table
 512                         (set-charset-mapping-table (car cdef) table)))))
 513           (when (not (or (< (char-int char) 32)
 514                          (and (<= 128 (char-int char))
 515                               (< (char-int char) 160))))
 516             (delete-region (point) (point-at-eol))
 517             (insert (format "\t; %c" char)))
 518           )))))
 519
 520 (defun insert-char-data-with-variant (char &optional script printable)
 521   (insert-char-data char printable)
 522   (let ((variants (or (char-variants char)
 523                       (let ((ucs (get-char-attribute char '->ucs)))
 524                         (if ucs
 525                             (delete char (char-variants (int-char ucs)))))))
 526         variant vs)
 527     (while variants
 528       (setq variant (car variants))
 529       (if (or (null script)
 530               (null (setq vs (get-char-attribute variant 'script)))
 531               (memq script vs))
 532           (insert-char-data variant printable))
 533       (setq variants (cdr variants))
 534       )))
 535
 536 (defun insert-char-range-data (min max &optional script)
 537   (let ((code min)
 538         char)
 539     (while (<= code max)
 540       (setq char (decode-char 'ucs code))
 541       (if (get-char-attribute char 'ucs)
 542           (insert-char-data-with-variant char script))
 543       (setq code (1+ code))
 544       )))
 545
 546 (defun write-char-range-data-to-file (min max file &optional script)
 547   (let ((coding-system-for-write 'utf-8))
 548     (with-temp-buffer
 549       (insert-char-range-data min max script)
 550       (write-region (point-min)(point-max) file))))
 551
 552 (defvar what-character-original-window-configuration)
 553
 554 ;;;###autoload
 555 (defun what-char-definition (char)
 556   (interactive (list (char-after)))
 557   (let ((buf (get-buffer-create "*Character Description*"))
 558         (the-buf (current-buffer))
 559         (win-conf (current-window-configuration)))
 560     (pop-to-buffer buf)
 561     (make-local-variable 'what-character-original-window-configuration)
 562     (setq what-character-original-window-configuration win-conf)
 563     (setq buffer-read-only nil)
 564     (erase-buffer)
 565     (condition-case err
 566         (progn
 567           (insert-char-data-with-variant char nil 'printable)
 568           ;; (char-db-update-comment)
 569           (set-buffer-modified-p nil)
 570           (view-mode the-buf (lambda (buf)
 571                                (set-window-configuration
 572                                 what-character-original-window-configuration)
 573                                ))
 574           (goto-char (point-min)))
 575       (error (progn
 576                (set-window-configuration
 577                 what-character-original-window-configuration)
 578                (signal (car err) (cdr err)))))))
 579
 580 (provide 'char-db-util)
 581
 582 ;;; char-db-util.el ends here