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 (defun char-attribute-name< (ka kb)
  65   (cond
  66    ((find-charset ka)
  67     (cond
  68      ((find-charset kb)
  69       (cond
  70        ((= (charset-dimension ka)
  71            (charset-dimension kb))
  72         (cond ((= (charset-chars ka)(charset-chars kb))
  73                (cond
  74                 ((>= (charset-final ka) ?@)
  75                  (if (>= (charset-final kb) ?@)
  76                      (< (charset-final ka)
  77                         (charset-final kb))
  78                    t))
  79                 ((>= (charset-final ka) ?0)
  80                  (cond
  81                   ((>= (charset-final kb) ?@)
  82                    nil)
  83                   ((>= (charset-final kb) ?0)
  84                    (< (charset-final ka)
  85                       (charset-final kb)))
  86                   (t)))))
  87               ((<= (charset-chars ka)(charset-chars kb)))))
  88        (t
  89         (< (charset-dimension ka)
  90            (charset-dimension kb))
  91         )))
  92      (t)))
  93    ((find-charset kb)
  94     t)
  95    ((symbolp ka)
  96     (cond ((symbolp kb)
  97            (string< (symbol-name ka)
  98                     (symbol-name kb)))
  99           (t)))
 100    ((symbolp kb)
 101     nil)))
 102
 103 (defun insert-char-data (char)
 104   (let ((data (char-attribute-alist char))
 105         cell ret name has-long-ccs-name rest)
 106     (when data
 107       (save-restriction
 108         (narrow-to-region (point)(point))
 109         (insert "(define-char
 110   '(")
 111         (when (setq cell (assq 'name data))
 112           (setq cell (cdr cell))
 113           (insert (format
 114                    (if (> (length cell) 47)
 115                        "(name . %S)
 116     "
 117                      "(name\t\t. %S)
 118     ")
 119                    cell))
 120           (setq data (del-alist 'name data))
 121           )
 122         (when (setq cell (assq 'name data))
 123           (setq cell (cdr cell))
 124           (insert (format
 125                    (if (> (length cell) 47)
 126                        "(name . %S)
 127     "
 128                      "(name\t\t. %S)
 129     ")
 130                    cell))
 131           (setq data (del-alist 'name data))
 132           )
 133         (when (setq cell (assq 'ucs data))
 134           (setq cell (cdr cell))
 135           (insert (format "(ucs\t\t. #x%04X)
 136     "
 137                           cell))
 138           (setq data (del-alist 'ucs data))
 139           )
 140         (when (setq cell (assq '->ucs data))
 141           (setq cell (cdr cell))
 142           (insert (format "(->ucs\t\t. #x%04X)
 143     "
 144                           cell))
 145           (setq data (del-alist '->ucs data))
 146           )
 147         (when (setq cell (assq 'general-category data))
 148           (setq ret (cdr cell))
 149           (insert (format
 150                    "(general-category\t%s) ; %s
 151     "
 152                    (mapconcat (lambda (cell)
 153                                 (format "%S" cell))
 154                               ret " ")
 155                    (cond ((rassoc (cdr cell)
 156                                   unidata-normative-category-alist)
 157                           "Normative Category")
 158                          ((rassoc (cdr cell)
 159                                   unidata-informative-category-alist)
 160                           "Informative Category")
 161                          (t
 162                           "Unknown Category"))))
 163           (setq data (del-alist 'general-category data))
 164           )
 165         (when (setq cell (assq 'bidi-category data))
 166           (setq cell (cdr cell))
 167           (insert (format "(bidi-category\t. %S)
 168     "
 169                           cell))
 170           (setq data (del-alist 'bidi-category data))
 171           )
 172         (when (setq cell (assq 'mirrored data))
 173           (setq cell (cdr cell))
 174           (insert (format "(mirrored\t\t. %S)
 175     "
 176                           cell))
 177           (setq data (del-alist 'mirrored data))
 178           )
 179         (cond
 180          ((setq cell (assq 'decimal-digit-value data))
 181           (setq cell (cdr cell))
 182           (insert (format "(decimal-digit-value . %S)
 183     "
 184                           cell))
 185           (setq data (del-alist 'decimal-digit-value data))
 186           (when (setq cell (assq 'digit-value data))
 187             (setq cell (cdr cell))
 188             (insert (format "(digit-value\t . %S)
 189     "
 190                             cell))
 191             (setq data (del-alist 'digit-value data))
 192             )
 193           (when (setq cell (assq 'numeric-value data))
 194             (setq cell (cdr cell))
 195             (insert (format "(numeric-value\t . %S)
 196     "
 197                             cell))
 198             (setq data (del-alist 'numeric-value data))
 199             )
 200           )
 201          (t
 202           (when (setq cell (assq 'digit-value data))
 203             (setq cell (cdr cell))
 204             (insert (format "(digit-value\t. %S)
 205     "
 206                             cell))
 207             (setq data (del-alist 'digit-value data))
 208             )
 209           (when (setq cell (assq 'numeric-value data))
 210             (setq cell (cdr cell))
 211             (insert (format "(numeric-value\t. %S)
 212     "
 213                             cell))
 214             (setq data (del-alist 'numeric-value data))
 215             )))
 216         (when (setq cell (assq 'iso-10646-comment data))
 217           (setq cell (cdr cell))
 218           (insert (format "(iso-10646-comment\t. %S)
 219     "
 220                           cell))
 221           (setq data (del-alist 'iso-10646-comment data))
 222           )
 223         (when (setq cell (assq '->decomposition data))
 224           (setq cell (cdr cell))
 225           (insert (format "(->decomposition\t%s)
 226     "
 227                           (mapconcat (lambda (code)
 228                                        (cond ((symbolp code)
 229                                               (symbol-name code))
 230                                              ((integerp code)
 231                                               (format "#x%04X" code))
 232                                              (t
 233                                               (format "\n     %S" code))))
 234                                      cell " ")))
 235           (setq data (del-alist '->decomposition data))
 236           )
 237         (when (setq cell (assq '->uppercase data))
 238           (setq cell (cdr cell))
 239           (insert (format "(->uppercase\t%s)
 240     "
 241                           (mapconcat (lambda (code)
 242                                        (cond ((symbolp code)
 243                                               (symbol-name code))
 244                                              ((integerp code)
 245                                               (format "#x%04X" code))
 246                                              (t
 247                                               (format "\n     %S" code))))
 248                                      cell " ")))
 249           (setq data (del-alist '->uppercase data))
 250           )
 251         (when (setq cell (assq '->lowercase data))
 252           (setq cell (cdr cell))
 253           (insert (format "(->lowercase\t%s)
 254     "
 255                           (mapconcat (lambda (code)
 256                                        (cond ((symbolp code)
 257                                               (symbol-name code))
 258                                              ((integerp code)
 259                                               (format "#x%04X" code))
 260                                              (t
 261                                               (format "\n     %S" code))))
 262                                      cell " ")))
 263           (setq data (del-alist '->lowercase data))
 264           )
 265         (when (setq cell (assq '->titlecase data))
 266           (setq cell (cdr cell))
 267           (insert (format "(->titlecase\t%s)
 268     "
 269                           (mapconcat (lambda (code)
 270                                        (cond ((symbolp code)
 271                                               (symbol-name code))
 272                                              ((integerp code)
 273                                               (format "#x%04X" code))
 274                                              (t
 275                                               (format "\n     %S" code))))
 276                                      cell " ")))
 277           (setq data (del-alist '->titlecase data))
 278           )
 279         (setq data
 280               (sort data
 281                     (lambda (a b)
 282                       (char-attribute-name< (car a)(car b)))))
 283         (setq rest data)
 284         (while (and rest
 285                     (progn
 286                       (setq cell (car rest))
 287                       (if (setq ret (find-charset (car cell)))
 288                           (if (>= (length (symbol-name (charset-name ret))) 19)
 289                               (progn
 290                                 (setq has-long-ccs-name t)
 291                                 nil)
 292                             t)
 293                         t)))
 294           (setq rest (cdr rest)))
 295         (while data
 296           (setq cell (car data))
 297           (cond ((setq ret (find-charset (car cell)))
 298                  (insert (format (if has-long-ccs-name
 299                                      "(%-26s %s)
 300     "
 301                                    "(%-18s %s)
 302     "
 303                                    )
 304                                  (charset-name ret)
 305                                  (mapconcat
 306                                   (lambda (b)
 307                                     (format "#x%02X"
 308                                             (if (= (charset-graphic ret) 1)
 309                                                 (logior b #x80)
 310                                               b)))
 311                                   (cdr cell) " "))))
 312                 ((string-match "^->" (symbol-name (car cell)))
 313                  (insert
 314                   (format "(%-18s %s)
 315     "
 316                           (car cell)
 317                           (mapconcat (lambda (code)
 318                                        (cond ((symbolp code)
 319                                               (symbol-name code))
 320                                              ((integerp code)
 321                                               (format "#x%04X" code))
 322                                              (t
 323                                               (format "\n     %S" code))))
 324                                      (cdr cell) " "))))
 325                 ((consp (cdr cell))
 326                  (insert (format "%S
 327     "
 328                                  cell)))
 329                 (t
 330                  (insert (format "(%-18s . %S)
 331     "
 332                                  (car cell)(cdr cell)))
 333                  ))
 334           (setq data (cdr data)))
 335         (insert "))\n")
 336         (goto-char (point-min))
 337         (while (re-search-forward "[ \t]+$" nil t)
 338           (replace-match ""))
 339         (goto-char (point-max))
 340         (tabify (point-min)(point-max))
 341         ))))
 342
 343 ;;;###autoload
 344 (defun char-db-update-comment ()
 345   (interactive)
 346   (save-excursion
 347     (goto-char (point-min))
 348     (let (cdef table char)
 349       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 350         (goto-char (match-beginning 1))
 351         (setq cdef (read (current-buffer)))
 352         (when (find-charset (car cdef))
 353           (goto-char (match-end 0))
 354           (setq char
 355                 (if (or (memq (car cdef) '(ascii latin-viscii-upper
 356                                                  latin-viscii-lower
 357                                                  arabic-iso8859-6))
 358                         (= (char-int (charset-final (car cdef))) 0))
 359                     (apply (function make-char) cdef)
 360                   (if (setq table (charset-mapping-table (car cdef)))
 361                       (set-charset-mapping-table (car cdef) nil))
 362                   (prog1
 363                       (apply (function make-char) cdef)
 364                     (if table
 365                         (set-charset-mapping-table (car cdef) table)))))
 366           (when (not (or (< (char-int char) 32)
 367                          (and (<= 128 (char-int char))
 368                               (< (char-int char) 160))))
 369             (delete-region (point) (point-at-eol))
 370             (insert (format "\t; %c" char)))
 371           )))))
 372
 373 (defun insert-char-data-with-variant (char)
 374   (insert-char-data char)
 375   (let ((variants (char-variants char)))
 376     (while variants
 377       (insert-char-data (car variants))
 378       (setq variants (cdr variants))
 379       )))
 380
 381 (defun insert-char-range-data (min max)
 382   (let ((code min)
 383         char
 384         variants)
 385     (while (<= code max)
 386       (setq char (int-char code))
 387       (insert-char-data-with-variant char)
 388       (setq code (1+ code))
 389       )))
 390
 391 (defun write-char-range-data-to-file (min max file)
 392   (with-temp-buffer
 393     (insert-char-range-data min max)
 394     (write-region (point-min)(point-max) file)))
 395
 396 ;;;###autoload
 397 (defun what-char-definition (char)
 398   (interactive (list (char-after)))
 399   (let ((buf (get-buffer-create "*Character Description*"))
 400         (the-buf (current-buffer))
 401         (win-conf (current-window-configuration)))
 402     (pop-to-buffer buf)
 403     (make-local-variable 'what-character-original-window-configuration)
 404     (setq what-character-original-window-configuration win-conf)
 405     (setq buffer-read-only nil)
 406     (erase-buffer)
 407     (condition-case err
 408         (progn
 409           (insert-char-data-with-variant char)
 410           (char-db-update-comment)
 411           (set-buffer-modified-p nil)
 412           (view-mode the-buf (lambda (buf)
 413                                (set-window-configuration
 414                                 what-character-original-window-configuration)
 415                                ))
 416           (goto-char (point-min)))
 417       (error (progn
 418                (set-window-configuration
 419                 what-character-original-window-configuration)
 420                (signal (car err) (cdr err)))))))
 421
 422 (provide 'char-db-util)
 423
 424 ;;; char-db-util.el ends here