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