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       (unless (eq (setq value (get-char-attribute char 'mirrored 'empty))
 177                   'empty)
 178         (insert (format "(mirrored\t\t. %S)
 179     "
 180                         value))
 181         (setq attributes (delq 'mirrored attributes))
 182         )
 183       (cond
 184        ((setq value (get-char-attribute char 'decimal-digit-value))
 185         (insert (format "(decimal-digit-value . %S)
 186     "
 187                         value))
 188         (setq attributes (delq 'decimal-digit-value attributes))
 189         (when (setq value (get-char-attribute char 'digit-value))
 190           (insert (format "(digit-value\t . %S)
 191     "
 192                           value))
 193           (setq attributes (delq 'digit-value attributes))
 194           )
 195         (when (setq value (get-char-attribute char 'numeric-value))
 196           (insert (format "(numeric-value\t . %S)
 197     "
 198                           value))
 199           (setq attributes (delq 'numeric-value attributes))
 200           )
 201         )
 202        (t
 203         (when (setq value (get-char-attribute char 'digit-value))
 204           (insert (format "(digit-value\t. %S)
 205     "
 206                           value))
 207           (setq attributes (delq 'digit-value attributes))
 208           )
 209         (when (setq value (get-char-attribute char 'numeric-value))
 210           (insert (format "(numeric-value\t. %S)
 211     "
 212                           value))
 213           (setq attributes (delq 'numeric-value attributes))
 214           )))
 215       (when (setq value (get-char-attribute char 'iso-10646-comment))
 216         (insert (format "(iso-10646-comment\t. %S)
 217     "
 218                         value))
 219         (setq attributes (delq 'iso-10646-comment attributes))
 220         )
 221       (when (setq value (get-char-attribute char 'morohashi-daikanwa))
 222         (insert (format "(morohashi-daikanwa\t%s)
 223     "
 224                         (mapconcat (function prin1-to-string) value " ")))
 225         (setq attributes (delq 'morohashi-daikanwa attributes))
 226         )
 227       (setq radical nil
 228             strokes nil)
 229       (when (setq value (get-char-attribute char 'ideographic-radical))
 230         (setq radical value)
 231         (insert (format "(ideographic-radical . %S)\t; %c
 232     "
 233                         radical
 234                         (aref ideographic-radicals radical)))
 235         (setq attributes (delq 'ideographic-radical attributes))
 236         )
 237       (when (setq value (get-char-attribute char 'ideographic-strokes))
 238         (setq strokes value)
 239         (insert (format "(ideographic-strokes . %S)
 240     "
 241                         strokes))
 242         (setq attributes (delq 'ideographic-strokes attributes))
 243         )
 244       (when (setq value (get-char-attribute char 'kangxi-radical))
 245         (unless (eq value radical)
 246           (insert (format "(kangxi-radical\t . %S)\t; %c
 247     "
 248                           value
 249                           (aref ideographic-radicals value)))
 250           (or radical
 251               (setq radical value)))
 252         (setq attributes (delq 'kangxi-radical attributes))
 253         )
 254       (when (setq value (get-char-attribute char 'kangxi-strokes))
 255         (unless (eq value strokes)
 256           (insert (format "(kangxi-strokes\t . %S)
 257     "
 258                           value))
 259           (or strokes
 260               (setq strokes value)))
 261         (setq attributes (delq 'kangxi-strokes attributes))
 262         )
 263       (when (setq value (get-char-attribute char 'japanese-radical))
 264         (unless (eq value radical)
 265           (insert (format "(japanese-radical\t . %S)\t; %c
 266     "
 267                           value
 268                           (aref ideographic-radicals value)))
 269           (or radical
 270               (setq radical value)))
 271         (setq attributes (delq 'japanese-radical attributes))
 272         )
 273       (when (setq value (get-char-attribute char 'japanese-strokes))
 274         (unless (eq value strokes)
 275           (insert (format "(japanese-strokes\t . %S)
 276     "
 277                           value))
 278           (or strokes
 279               (setq strokes value)))
 280         (setq attributes (delq 'japanese-strokes attributes))
 281         )
 282       (when (setq value (get-char-attribute char 'cns-radical))
 283         (insert (format "(cns-radical\t . %S)\t; %c
 284     "
 285                         value
 286                         (aref ideographic-radicals value)))
 287         (setq attributes (delq 'cns-radical attributes))
 288         )
 289       (when (setq value (get-char-attribute char 'cns-strokes))
 290         (unless (eq value strokes)
 291           (insert (format "(cns-strokes\t . %S)
 292     "
 293                           value))
 294           (or strokes
 295               (setq strokes value)))
 296         (setq attributes (delq 'cns-strokes attributes))
 297         )
 298       (when (setq value (get-char-attribute char 'shinjigen-1-radical))
 299         (unless (eq value radical)
 300           (insert (format "(shinjigen-1-radical . %S)\t; %c
 301     "
 302                           value
 303                           (aref ideographic-radicals value)))
 304           (or radical
 305               (setq radical value)))
 306         (setq attributes (delq 'shinjigen-1-radical attributes))
 307         )
 308       (when (setq value (get-char-attribute char 'total-strokes))
 309         (insert (format "(total-strokes\t . %S)
 310     "
 311                         value))
 312         (setq attributes (delq 'total-strokes attributes))
 313         )
 314       (when (setq value (get-char-attribute char '->ideograph))
 315         (insert (format "(->ideograph\t%s)
 316     "
 317                         (mapconcat (lambda (code)
 318                                      (cond ((symbolp code)
 319                                             (symbol-name code))
 320                                            ((integerp code)
 321                                             (format "#x%04X" code))
 322                                            (t
 323                                             (format "\n     %S" code))))
 324                                    value " ")))
 325         (setq attributes (delq '->ideograph attributes))
 326         )
 327       (when (setq value (get-char-attribute char '->decomposition))
 328         (insert (format "(->decomposition\t%s)
 329     "
 330                         (mapconcat (lambda (code)
 331                                      (cond ((symbolp code)
 332                                             (symbol-name code))
 333                                            ((characterp code)
 334                                             (if readable
 335                                                 (format "%S" code)
 336                                               (format "#x%04X"
 337                                                       (char-int code))
 338                                               ))
 339                                            ((integerp code)
 340                                             (format "#x%04X" code))
 341                                            (t
 342                                             (format "\n     %S" code))))
 343                                    value " ")))
 344         (setq attributes (delq '->decomposition attributes))
 345         )
 346       (when (setq value (get-char-attribute char '->uppercase))
 347         (insert (format "(->uppercase\t%s)
 348     "
 349                         (mapconcat (lambda (code)
 350                                      (cond ((symbolp code)
 351                                             (symbol-name code))
 352                                            ((integerp code)
 353                                             (format "#x%04X" code))
 354                                            (t
 355                                             (format "\n     %S" code))))
 356                                    value " ")))
 357         (setq attributes (delq '->uppercase attributes))
 358         )
 359       (when (setq value (get-char-attribute char '->lowercase))
 360         (insert (format "(->lowercase\t%s)
 361     "
 362                         (mapconcat (lambda (code)
 363                                      (cond ((symbolp code)
 364                                             (symbol-name code))
 365                                            ((integerp code)
 366                                             (format "#x%04X" code))
 367                                            (t
 368                                             (format "\n     %S" code))))
 369                                    value " ")))
 370         (setq attributes (delq '->lowercase attributes))
 371         )
 372       (when (setq value (get-char-attribute char '->titlecase))
 373         (insert (format "(->titlecase\t%s)
 374     "
 375                         (mapconcat (lambda (code)
 376                                      (cond ((symbolp code)
 377                                             (symbol-name code))
 378                                            ((integerp code)
 379                                             (format "#x%04X" code))
 380                                            (t
 381                                             (format "\n     %S" code))))
 382                                    value " ")))
 383         (setq attributes (delq '->titlecase attributes))
 384         )
 385       (when (setq value (get-char-attribute char '->mojikyo))
 386         (insert (format "(->mojikyo\t\t. %06d)\t; %c
 387     "
 388                         value (decode-char 'mojikyo value)))
 389         (setq attributes (delq '->mojikyo attributes))
 390         )
 391       (setq rest ccs-attributes)
 392       (while (and rest
 393                     (progn
 394                       (setq value (get-char-attribute char (car rest)))
 395                       (if value
 396                           (if (>= (length (symbol-name (car rest))) 19)
 397                               (progn
 398                                 (setq has-long-ccs-name t)
 399                                 nil)
 400                             t)
 401                         t)))
 402           (setq rest (cdr rest)))
 403       (while attributes
 404         (setq name (car attributes))
 405         (if (setq value (get-char-attribute char name))
 406             (cond ((string-match "^->" (symbol-name name))
 407                    (insert
 408                     (format "(%-18s %s)
 409     "
 410                             name
 411                             (mapconcat (lambda (code)
 412                                          (cond ((symbolp code)
 413                                                 (symbol-name code))
 414                                                ((integerp code)
 415                                                 (format "#x%04X" code))
 416                                                (t
 417                                                 (format "\n     %S" code))))
 418                                        value " "))))
 419                   ((consp value)
 420                    (insert (format "(%-18s %s)
 421     "
 422                                    name
 423                                    (mapconcat (function prin1-to-string)
 424                                               value " "))))
 425                   ((eq name 'jisx0208-1978/4X)
 426                    (insert (format "(%-18s . #x%04X)
 427     "
 428                                    name value)))
 429                   (t
 430                    (insert (format "(%-18s . %S)
 431     "
 432                                    name value)))
 433                   ))
 434         (setq attributes (cdr attributes)))
 435       (while ccs-attributes
 436         (setq name (car ccs-attributes))
 437         (if (setq value (get-char-attribute char name))
 438             (insert
 439              (format
 440               (if has-long-ccs-name
 441                   (cond ((eq name 'ideograph-daikanwa)
 442                          "(%-26s . %05d)\t; %c
 443     "
 444                          )
 445                         ((eq name 'mojikyo)
 446                          "(%-26s . %06d)\t; %c
 447     "
 448                          )
 449                         (t
 450                          "(%-26s . #x%X)\t; %c
 451     "
 452                          ))
 453                 (cond ((eq name 'ideograph-daikanwa)
 454                        "(%-18s . %05d)\t; %c
 455     "
 456                        )
 457                       ((eq name 'mojikyo)
 458                        "(%-18s . %06d)\t; %c
 459     "
 460                        )
 461                       (t
 462                        "(%-18s . #x%X)\t; %c
 463     "
 464                        )))
 465               name
 466               (if (= (charset-iso-graphic-plane name) 1)
 467                   (logior value
 468                           (cond ((= (charset-dimension name) 1)
 469                                  #x80)
 470                                 ((= (charset-dimension name) 2)
 471                                  #x8080)
 472                                 ((= (charset-dimension name) 3)
 473                                  #x808080)
 474                                 (t 0)))
 475                 value)
 476               (decode-builtin-char name value))))
 477         (setq ccs-attributes (cdr ccs-attributes)))
 478       (insert "))\n")
 479       (goto-char (point-min))
 480       (while (re-search-forward "[ \t]+$" nil t)
 481         (replace-match ""))
 482       (goto-char (point-max))
 483       (tabify (point-min)(point-max))
 484       )))
 485
 486 ;;;###autoload
 487 (defun char-db-update-comment ()
 488   (interactive)
 489   (save-excursion
 490     (goto-char (point-min))
 491     (let (cdef table char)
 492       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 493         (goto-char (match-beginning 1))
 494         (setq cdef (read (current-buffer)))
 495         (when (find-charset (car cdef))
 496           (goto-char (match-end 0))
 497           (setq char
 498                 (if (and
 499                      (not (eq (car cdef) 'ideograph-daikanwa))
 500                      (or (memq (car cdef) '(ascii latin-viscii-upper
 501                                                   latin-viscii-lower
 502                                                   arabic-iso8859-6
 503                                                   japanese-jisx0213-1
 504                                                   japanese-jisx0213-2))
 505                          (= (char-int (charset-iso-final-char (car cdef)))
 506                             0)))
 507                     (apply (function make-char) cdef)
 508                   (if (setq table (charset-mapping-table (car cdef)))
 509                       (set-charset-mapping-table (car cdef) nil))
 510                   (prog1
 511                       (apply (function make-char) cdef)
 512                     (if table
 513                         (set-charset-mapping-table (car cdef) table)))))
 514           (when (not (or (< (char-int char) 32)
 515                          (and (<= 128 (char-int char))
 516                               (< (char-int char) 160))))
 517             (delete-region (point) (point-at-eol))
 518             (insert (format "\t; %c" char)))
 519           )))))
 520
 521 (defun insert-char-data-with-variant (char &optional script printable
 522                                            no-ucs-variant)
 523   (insert-char-data char printable)
 524   (let ((variants (or (char-variants char)
 525                       (let ((ucs (get-char-attribute char '->ucs)))
 526                         (if ucs
 527                             (delete char (char-variants (int-char ucs)))))))
 528         variant vs)
 529     (while variants
 530       (setq variant (car variants))
 531       (if (or (null script)
 532               (null (setq vs (get-char-attribute variant 'script)))
 533               (memq script vs))
 534           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 535               (insert-char-data variant printable)))
 536       (setq variants (cdr variants))
 537       )))
 538
 539 (defun insert-char-range-data (min max &optional script)
 540   (let ((code min)
 541         char)
 542     (while (<= code max)
 543       (setq char (decode-char 'ucs code))
 544       (if (get-char-attribute char 'ucs)
 545           (insert-char-data-with-variant char script nil 'no-ucs-variant))
 546       (setq code (1+ code))
 547       )))
 548
 549 (defun write-char-range-data-to-file (min max file &optional script)
 550   (let ((coding-system-for-write 'utf-8))
 551     (with-temp-buffer
 552       (insert-char-range-data min max script)
 553       (write-region (point-min)(point-max) file))))
 554
 555 (defvar what-character-original-window-configuration)
 556
 557 ;;;###autoload
 558 (defun what-char-definition (char)
 559   (interactive (list (char-after)))
 560   (let ((buf (get-buffer-create "*Character Description*"))
 561         (the-buf (current-buffer))
 562         (win-conf (current-window-configuration)))
 563     (pop-to-buffer buf)
 564     (make-local-variable 'what-character-original-window-configuration)
 565     (setq what-character-original-window-configuration win-conf)
 566     (setq buffer-read-only nil)
 567     (erase-buffer)
 568     (condition-case err
 569         (progn
 570           (insert-char-data-with-variant char nil 'printable)
 571           ;; (char-db-update-comment)
 572           (set-buffer-modified-p nil)
 573           (view-mode the-buf (lambda (buf)
 574                                (set-window-configuration
 575                                 what-character-original-window-configuration)
 576                                ))
 577           (goto-char (point-min)))
 578       (error (progn
 579                (set-window-configuration
 580                 what-character-original-window-configuration)
 581                (signal (car err) (cdr err)))))))
 582
 583 (provide 'char-db-util)
 584
 585 ;;; char-db-util.el ends here