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