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 insert-char-data (char)
  65   (let ((data (char-attribute-alist char))
  66         cell ret name has-long-ccs-name rest)
  67     (when data
  68       (save-restriction
  69         (narrow-to-region (point)(point))
  70         (insert "(define-char
  71   '(")
  72         (when (setq cell (assq 'name data))
  73           (setq cell (cdr cell))
  74           (insert (format
  75                    (if (> (length cell) 47)
  76                        "(name . %S)
  77     "
  78                      "(name\t\t. %S)
  79     ")
  80                    cell))
  81           (setq data (del-alist 'name data))
  82           )
  83         (when (setq cell (assq 'name data))
  84           (setq cell (cdr cell))
  85           (insert (format
  86                    (if (> (length cell) 47)
  87                        "(name . %S)
  88     "
  89                      "(name\t\t. %S)
  90     ")
  91                    cell))
  92           (setq data (del-alist 'name data))
  93           )
  94         (when (setq cell (assq 'ucs data))
  95           (setq cell (cdr cell))
  96           (insert (format "(ucs\t\t. #x%04X)
  97     "
  98                           cell))
  99           (setq data (del-alist 'ucs data))
 100           )
 101         (when (setq cell (assq '->ucs data))
 102           (setq cell (cdr cell))
 103           (insert (format "(->ucs\t\t. #x%04X)
 104     "
 105                           cell))
 106           (setq data (del-alist '->ucs data))
 107           )
 108         (when (setq cell (assq 'general-category data))
 109           (setq ret (cdr cell))
 110           (insert (format
 111                    "(general-category\t%s) ; %s
 112     "
 113                    (mapconcat (lambda (cell)
 114                                 (format "%S" cell))
 115                               ret " ")
 116                    (cond ((rassoc (cdr cell)
 117                                   unidata-normative-category-alist)
 118                           "Normative Category")
 119                          ((rassoc (cdr cell)
 120                                   unidata-informative-category-alist)
 121                           "Informative Category")
 122                          (t
 123                           "Unknown Category"))))
 124           (setq data (del-alist 'general-category data))
 125           )
 126         (when (setq cell (assq 'bidi-category data))
 127           (setq cell (cdr cell))
 128           (insert (format "(bidi-category\t. %S)
 129     "
 130                           cell))
 131           (setq data (del-alist 'bidi-category data))
 132           )
 133         (when (setq cell (assq 'mirrored data))
 134           (setq cell (cdr cell))
 135           (insert (format "(mirrored\t\t. %S)
 136     "
 137                           cell))
 138           (setq data (del-alist 'mirrored data))
 139           )
 140         (when (setq cell (assq 'decimal-digit-value data))
 141           (setq cell (cdr cell))
 142           (insert (format "(decimal-digit-value . %S)
 143     "
 144                           cell))
 145           (setq data (del-alist 'decimal-digit-value data))
 146           (when (setq cell (assq 'digit-value data))
 147             (setq cell (cdr cell))
 148             (insert (format "(digit-value\t . %S)
 149     "
 150                             cell))
 151             (setq data (del-alist 'digit-value data))
 152             )
 153           (when (setq cell (assq 'numeric-value data))
 154             (setq cell (cdr cell))
 155             (insert (format "(numeric-value\t . %S)
 156     "
 157                             cell))
 158             (setq data (del-alist 'numeric-value data))
 159             )
 160           )
 161         (setq data (sort data
 162                          (lambda (a b)
 163                            (let ((ka (car a))
 164                                  (kb (car b)))
 165                              (cond ((find-charset ka)
 166                                     (cond ((find-charset kb)
 167                                            (cond ((= (charset-dimension ka)
 168                                                      (charset-dimension kb))
 169                                                   (< (charset-final ka)
 170                                                      (charset-final kb)))
 171                                                  (t
 172                                                   (< (charset-dimension ka)
 173                                                      (charset-dimension kb))
 174                                                   )))
 175                                           (t)))
 176                                    ((find-charset kb)
 177                                     t)
 178                                    ((symbolp ka)
 179                                     (cond ((symbolp kb)
 180                                            (string< (symbol-name ka)
 181                                                     (symbol-name kb)))
 182                                           (t)))
 183                                    ((symbolp kb)
 184                                     nil))))))
 185         (setq rest data)
 186         (while (and rest
 187                     (progn
 188                       (setq cell (car rest))
 189                       (if (setq ret (find-charset (car cell)))
 190                           (if (>= (length (symbol-name (charset-name ret))) 19)
 191                               (progn
 192                                 (setq has-long-ccs-name t)
 193                                 nil)
 194                             t)
 195                         t)))
 196           (setq rest (cdr rest)))
 197         (while data
 198           (setq cell (car data))
 199           (cond ((setq ret (find-charset (car cell)))
 200                  (insert (format (if has-long-ccs-name
 201                                      "(%-26s %s)
 202     "
 203                                    "(%-18s %s)
 204     "
 205                                    )
 206                                  (charset-name ret)
 207                                  (mapconcat (lambda (b)
 208                                               (format "#x%02X" b)
 209                                               )
 210                                             (cdr cell) " "))))
 211                 ((string-match "^->" (symbol-name (car cell)))
 212                  (insert
 213                   (format "(%-18s %s)
 214     "
 215                           (car cell)
 216                           (mapconcat (lambda (code)
 217                                        (cond ((symbolp code)
 218                                               (symbol-name code))
 219                                              ((integerp code)
 220                                               (format "#x%04X" code))
 221                                              (t
 222                                               (format "\n     %S" code))))
 223                                      (cdr cell) " "))))
 224                 ((consp (cdr cell))
 225                  (insert (format "%S
 226     "
 227                                  cell)))
 228                 (t
 229                  (insert (format "(%-18s . %S)
 230     "
 231                                  (car cell)(cdr cell)))
 232                  ))
 233           (setq data (cdr data)))
 234         (insert "))\n")
 235         (goto-char (point-min))
 236         (while (re-search-forward "[ \t]+$" nil t)
 237           (replace-match ""))
 238         (goto-char (point-max))
 239         (tabify (point-min)(point-max))
 240         ))))
 241
 242 (defun insert-char-range-data (min max)
 243   (let ((code min))
 244     (while (<= code max)
 245       (insert-char-data (int-char code))
 246       (setq code (1+ code))
 247       )))
 248
 249 (defun write-char-range-data-to-file (min max file)
 250   (with-temp-buffer
 251     (insert-char-range-data min max)
 252     (write-region (point-min)(point-max) file)))
 253
 254 (defun char-db-update-comment ()
 255   (interactive)
 256   (save-excursion
 257     (goto-char (point-min))
 258     (let (cdef table)
 259       (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t)
 260         (goto-char (match-beginning 1))
 261         (setq cdef (read (current-buffer)))
 262         (when (find-charset (car cdef))
 263           (goto-char (match-end 0))
 264           (if (setq table (charset-mapping-table (car cdef)))
 265               (set-charset-mapping-table (car cdef) nil))
 266           (delete-region (point) (point-at-eol))
 267           (insert (format "\t; %c" (apply #'make-char cdef)))
 268           (if table
 269               (set-charset-mapping-table (car cdef) table))
 270           )))))
 271
 272 ;;;###autoload
 273 (defun what-char-definition (char)
 274   (interactive (list (char-after)))
 275   (let ((buf (get-buffer-create "*Character Description*"))
 276         (the-buf (current-buffer))
 277         (win-conf (current-window-configuration)))
 278     (pop-to-buffer buf)
 279     (make-local-variable 'what-character-original-window-configuration)
 280     (setq what-character-original-window-configuration win-conf)
 281     (setq buffer-read-only nil)
 282     (erase-buffer)
 283     (condition-case err
 284         (progn
 285           (insert-char-data char)
 286           (set-buffer-modified-p nil)
 287           (view-mode the-buf (lambda (buf)
 288                                (set-window-configuration
 289                                 what-character-original-window-configuration)
 290                                ))
 291           (goto-char (point-min)))
 292       (error (progn
 293                (set-window-configuration
 294                 what-character-original-window-configuration)
 295                (signal (car err) (cdr err)))))))
 296
 297 (provide 'char-db-util)
 298
 299 ;;; char-db-util.el ends here