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