git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/utf-2000/char-db-util.el

   1 ;;; char-db-util.el --- Character Database utility
   2
   3 ;; Copyright (C) 1998,1999,2000,2001 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of 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-attributes (char &optional readable
 117                                     attributes ccs-attributes
 118                                     column)
 119   (setq attributes
 120         (if attributes
 121             (copy-sequence attributes)
 122           (sort (char-attribute-list) #'char-attribute-name<)))
 123   (setq ccs-attributes
 124         (if ccs-attributes
 125             (copy-sequence ccs-attributes)
 126           (sort (charset-list) #'char-attribute-name<)))
 127   (unless column
 128     (setq column (current-column)))
 129   (let (name value has-long-ccs-name rest
 130         radical strokes
 131         (line-breaking
 132          (concat "\n" (make-string (1+ column) ?\ ))))
 133     (insert "(")
 134     (when (setq value (get-char-attribute char 'name))
 135       (insert (format
 136                (if (> (length value) 47)
 137                    "(name . %S)%s"
 138                  "(name\t\t. %S)%s")
 139                value line-breaking))
 140       (setq attributes (delq 'name attributes))
 141       )
 142     (when (setq value (get-char-attribute char 'script))
 143       (insert (format "(script\t\t%s)%s"
 144                       (mapconcat (function prin1-to-string)
 145                                  value " ")
 146                       line-breaking))
 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%s"
 151                       value (decode-char 'ucs value)
 152                       line-breaking))
 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%s"
 158                (mapconcat (lambda (cell)
 159                             (format "%S" cell))
 160                           value " ")
 161                (cond ((rassoc value unidata-normative-category-alist)
 162                       "Normative Category")
 163                      ((rassoc value unidata-informative-category-alist)
 164                       "Informative Category")
 165                      (t
 166                       "Unknown Category"))
 167                line-breaking))
 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)%s"
 172                       value
 173                       line-breaking))
 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)%s"
 179                       value
 180                       line-breaking))
 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)%s"
 186                       value
 187                       line-breaking))
 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)%s"
 191                         value
 192                         line-breaking))
 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)%s"
 197                         value
 198                         line-breaking))
 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)%s"
 205                         value
 206                         line-breaking))
 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)%s"
 211                         value
 212                         line-breaking))
 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)%s"
 217                       value
 218                       line-breaking))
 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)%s"
 223                       (mapconcat (function prin1-to-string) value " ")
 224                       line-breaking))
 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%s"
 232                       radical
 233                       (aref ideographic-radicals radical)
 234                       line-breaking))
 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)%s"
 240                       strokes
 241                       line-breaking))
 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%s"
 247                         value
 248                         (aref ideographic-radicals value)
 249                         line-breaking))
 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)%s"
 257                         value
 258                         line-breaking))
 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%s"
 266                         value
 267                         (aref ideographic-radicals value)
 268                         line-breaking))
 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)%s"
 276                         value
 277                         line-breaking))
 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%s"
 284                       value
 285                       (aref ideographic-radicals value)
 286                       line-breaking))
 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)%s"
 292                         value
 293                         line-breaking))
 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%s"
 301                         value
 302                         (aref ideographic-radicals value)
 303                         line-breaking))
 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       . %S)%s"
 310                       value
 311                       line-breaking))
 312       (setq attributes (delq 'total-strokes attributes))
 313       )
 314     (when (setq value (get-char-attribute char '->ideograph))
 315       (insert (format "(->ideograph\t%s)%s"
 316                       (mapconcat (lambda (code)
 317                                    (cond ((symbolp code)
 318                                           (symbol-name code))
 319                                          ((integerp code)
 320                                           (format "#x%04X" code))
 321                                          (t
 322                                           (format "%s%S" line-breaking code))))
 323                                  value " ")
 324                       line-breaking))
 325       (setq attributes (delq '->ideograph attributes))
 326       )
 327     (when (setq value (get-char-attribute char '->decomposition))
 328       (insert (format "(->decomposition\t%s)%s"
 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 "%s%S" line-breaking code))))
 342                                  value " ")
 343                       line-breaking))
 344       (setq attributes (delq '->decomposition attributes))
 345       )
 346     (when (setq value (get-char-attribute char '->uppercase))
 347       (insert (format "(->uppercase\t%s)%s"
 348                       (mapconcat (lambda (code)
 349                                    (cond ((symbolp code)
 350                                           (symbol-name code))
 351                                          ((integerp code)
 352                                           (format "#x%04X" code))
 353                                          (t
 354                                           (format "%s%S" line-breaking code))))
 355                                  value " ")
 356                       line-breaking))
 357       (setq attributes (delq '->uppercase attributes))
 358       )
 359     (when (setq value (get-char-attribute char '->lowercase))
 360       (insert (format "(->lowercase\t%s)%s"
 361                       (mapconcat (lambda (code)
 362                                    (cond ((symbolp code)
 363                                           (symbol-name code))
 364                                          ((integerp code)
 365                                           (format "#x%04X" code))
 366                                          (t
 367                                           (format "%s%S" line-breaking code))))
 368                                  value " ")
 369                       line-breaking))
 370       (setq attributes (delq '->lowercase attributes))
 371       )
 372     (when (setq value (get-char-attribute char '->titlecase))
 373       (insert (format "(->titlecase\t%s)%s"
 374                       (mapconcat (lambda (code)
 375                                    (cond ((symbolp code)
 376                                           (symbol-name code))
 377                                          ((integerp code)
 378                                           (format "#x%04X" code))
 379                                          (t
 380                                           (format "%s%S" line-breaking code))))
 381                                  value " ")
 382                       line-breaking))
 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%s"
 387                       value (decode-char 'mojikyo value)
 388                       line-breaking))
 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)%s"
 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 "%s%S"
 417                                                       line-breaking code))))
 418                                      value " ")
 419                           line-breaking)))
 420                 ((consp value)
 421                  (insert (format "(%-18s " name))
 422                  (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
 423                        cell ret
 424                        rest key al cal
 425                        separator)
 426                    (while (consp value)
 427                      (setq cell (car value))
 428                      (if (and (consp cell)
 429                               (consp (car cell))
 430                               (setq ret (condition-case nil
 431                                             (define-char cell)
 432                                           (error nil))))
 433                          (progn
 434                            (setq rest cell
 435                                  al nil
 436                                  cal nil)
 437                            (while rest
 438                              (setq key (car (car rest)))
 439                              (if (find-charset key)
 440                                  (setq cal (cons key cal))
 441                                (setq al (cons key al)))
 442                              (setq rest (cdr rest)))
 443                            (if separator
 444                                (insert lbs))
 445                            (insert-char-attributes ret
 446                                                    readable
 447                                                    al cal)
 448                            (setq separator lbs))
 449                        (if separator
 450                            (insert separator))
 451                        (insert (prin1-to-string cell))
 452                        (setq separator " "))
 453                      (setq value (cdr value))))
 454                  (insert ")")
 455                  (insert line-breaking))
 456                 ((eq name 'jisx0208-1978/4X)
 457                  (insert (format "(%-18s . #x%04X)%s"
 458                                  name value
 459                                  line-breaking)))
 460                 (t
 461                  (insert (format "(%-18s . %S)%s"
 462                                  name value
 463                                  line-breaking)))
 464                 ))
 465       (setq attributes (cdr attributes)))
 466     (while ccs-attributes
 467       (setq name (car ccs-attributes))
 468       (if (setq value (get-char-attribute char name))
 469           (insert
 470            (format
 471             (if has-long-ccs-name
 472                 (cond ((eq name 'ideograph-daikanwa)
 473                        "(%-26s . %05d)\t; %c%s"
 474                        )
 475                       ((eq name 'mojikyo)
 476                        "(%-26s . %06d)\t; %c%s"
 477                        )
 478                       (t
 479                        "(%-26s . #x%X)\t; %c%s"
 480                        ))
 481               (cond ((eq name 'ideograph-daikanwa)
 482                      "(%-18s . %05d)\t; %c%s"
 483                      )
 484                     ((eq name 'mojikyo)
 485                      "(%-18s . %06d)\t; %c%s"
 486                      )
 487                     (t
 488                      "(%-18s . #x%X)\t; %c%s"
 489                      )))
 490             name
 491             (if (= (charset-iso-graphic-plane name) 1)
 492                 (logior value
 493                         (cond ((= (charset-dimension name) 1)
 494                                #x80)
 495                               ((= (charset-dimension name) 2)
 496                                #x8080)
 497                               ((= (charset-dimension name) 3)
 498                                #x808080)
 499                               (t 0)))
 500               value)
 501             (decode-builtin-char name value)
 502             line-breaking)))
 503       (setq ccs-attributes (cdr ccs-attributes)))
 504     (insert ")")))
 505
 506 (defun insert-char-data (char &optional readable
 507                               attributes ccs-attributes)
 508   (save-restriction
 509     (narrow-to-region (point)(point))
 510     (insert "(define-char
 511   '")
 512     (insert-char-attributes char readable
 513                             attributes ccs-attributes)
 514     (insert ")\n")
 515     (goto-char (point-min))
 516     (while (re-search-forward "[ \t]+$" nil t)
 517       (replace-match ""))
 518     (goto-char (point-max))
 519     (tabify (point-min)(point-max))
 520     ))
 521
 522 ;;;###autoload
 523 (defun char-db-update-comment ()
 524   (interactive)
 525   (save-excursion
 526     (goto-char (point-min))
 527     (let (cdef table char)
 528       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 529         (goto-char (match-beginning 1))
 530         (setq cdef (read (current-buffer)))
 531         (when (find-charset (car cdef))
 532           (goto-char (match-end 0))
 533           (setq char
 534                 (if (and
 535                      (not (eq (car cdef) 'ideograph-daikanwa))
 536                      (or (memq (car cdef) '(ascii latin-viscii-upper
 537                                                   latin-viscii-lower
 538                                                   arabic-iso8859-6
 539                                                   japanese-jisx0213-1
 540                                                   japanese-jisx0213-2))
 541                          (= (char-int (charset-iso-final-char (car cdef)))
 542                             0)))
 543                     (apply (function make-char) cdef)
 544                   (if (setq table (charset-mapping-table (car cdef)))
 545                       (set-charset-mapping-table (car cdef) nil))
 546                   (prog1
 547                       (apply (function make-char) cdef)
 548                     (if table
 549                         (set-charset-mapping-table (car cdef) table)))))
 550           (when (not (or (< (char-int char) 32)
 551                          (and (<= 128 (char-int char))
 552                               (< (char-int char) 160))))
 553             (delete-region (point) (point-at-eol))
 554             (insert (format "\t; %c" char)))
 555           )))))
 556
 557 (defun insert-char-data-with-variant (char &optional script printable
 558                                            no-ucs-variant)
 559   (insert-char-data char printable)
 560   (let ((variants (or (char-variants char)
 561                       (let ((ucs (get-char-attribute char '->ucs)))
 562                         (if ucs
 563                             (delete char (char-variants (int-char ucs)))))))
 564         variant vs)
 565     (while variants
 566       (setq variant (car variants))
 567       (if (or (null script)
 568               (null (setq vs (get-char-attribute variant 'script)))
 569               (memq script vs))
 570           (or (and no-ucs-variant (get-char-attribute variant 'ucs))
 571               (insert-char-data variant printable)))
 572       (setq variants (cdr variants))
 573       )))
 574
 575 (defun insert-char-range-data (min max &optional script)
 576   (let ((code min)
 577         char)
 578     (while (<= code max)
 579       (setq char (decode-char 'ucs code))
 580       (if (get-char-attribute char 'ucs)
 581           (insert-char-data-with-variant char script nil 'no-ucs-variant))
 582       (setq code (1+ code))
 583       )))
 584
 585 (defun write-char-range-data-to-file (min max file &optional script)
 586   (let ((coding-system-for-write 'utf-8))
 587     (with-temp-buffer
 588       (insert-char-range-data min max script)
 589       (write-region (point-min)(point-max) file))))
 590
 591 (defvar what-character-original-window-configuration)
 592
 593 ;;;###autoload
 594 (defun what-char-definition (char)
 595   (interactive (list (char-after)))
 596   (let ((buf (get-buffer-create "*Character Description*"))
 597         (the-buf (current-buffer))
 598         (win-conf (current-window-configuration)))
 599     (pop-to-buffer buf)
 600     (make-local-variable 'what-character-original-window-configuration)
 601     (setq what-character-original-window-configuration win-conf)
 602     (setq buffer-read-only nil)
 603     (erase-buffer)
 604     (condition-case err
 605         (progn
 606           (insert-char-data-with-variant char nil 'printable)
 607           ;; (char-db-update-comment)
 608           (set-buffer-modified-p nil)
 609           (view-mode the-buf (lambda (buf)
 610                                (set-window-configuration
 611                                 what-character-original-window-configuration)
 612                                ))
 613           (goto-char (point-min)))
 614       (error (progn
 615                (set-window-configuration
 616                 what-character-original-window-configuration)
 617                (signal (car err) (cdr err)))))))
 618
 619 (provide 'char-db-util)
 620
 621 ;;; char-db-util.el ends here