lisp/utf-2000/ideograph-util.el

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 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 XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but 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 UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'char-db-util)
  28
  29 (defvar ideograph-radical-chars-vector
  30   (make-vector 215 nil))
  31
  32 (defun char-ideographic-radical (char)
  33   (or (get-char-attribute char 'ideographic-radical)
  34       (let ((radical
  35              (or (get-char-attribute char 'daikanwa-radical)
  36                  (get-char-attribute char 'kangxi-radical)
  37                  (get-char-attribute char 'japanese-radical)
  38                  (get-char-attribute char 'korean-radical))))
  39         (when radical
  40           (put-char-attribute char 'ideographic-radical radical)
  41           radical))))
  42
  43 (defvar ideograph-radical-strokes-vector
  44   ;;0  1  2  3  4  5  6  7  8  9
  45   [nil 1  1  1  1  1  1  2  2  2
  46     2  2  2  2  2  2  2  2  2  2
  47     2  2  2  2  2  2  2  2  2  2
  48     3  3  3  3  3  3  3  3  3  3
  49     3  3  3  3  3  3  3  3  3  3
  50     3  3  3  3  3  3  3  3  3  3
  51     3  4  4  4  3  4  4  4  4  4
  52     4  4  4  4  4  4  4  4  4  4
  53     4  4  4  4  4  3  4  4  4  4
  54     4  4  4  4  3  5  4  5  5  5
  55     ;; 100
  56     5  5  5  5  5  5  5  5  5  5
  57     5  5  5  5  5  5  5  5  6  6
  58     6  6  6  6  6  6  6  6  6  6
  59     4  6  6  6  6  6  6  6  6  6
  60     4  6  6  6  6  6  6  7  7  7
  61     7  7  7  7  7  7  7  7  7  7
  62     7  7  4  3  7  7  7  8  7  8
  63     3  8  8  8  8  8  9  9  9  9
  64     9  9  9  9  8  9  9 10 10 10
  65    10 10 10 10 10 11 11 11 11 11
  66    ;; 200
  67    11 12 12 12 12 13 13 13 13 14
  68    14 15 16 16 17])
  69
  70 (defun char-ideographic-strokes (char)
  71   (or (get-char-attribute char 'daikanwa-strokes)
  72       (get-char-attribute char 'ideographic-strokes)
  73       (let ((strokes
  74              (or (get-char-attribute char 'kangxi-strokes)
  75                  (get-char-attribute char 'japanese-strokes)
  76                  (get-char-attribute char 'korean-strokes)
  77                  (let ((r (char-ideographic-radical char))
  78                        (ts (get-char-attribute char 'total-strokes)))
  79                    (if (and r ts)
  80                        (- ts (aref ideograph-radical-strokes-vector r))))
  81                  )))
  82         (when strokes
  83           (put-char-attribute char 'ideographic-strokes strokes)
  84           strokes))))
  85
  86 ;;;###autoload
  87 (defun update-ideograph-radical-table ()
  88   (interactive)
  89   (let (ret script)
  90     (map-char-attribute
  91      (lambda (char radical)
  92        (when (and radical
  93                   (or (null (setq script (get-char-attribute char 'script)))
  94                       (memq 'Ideograph script)))
  95          (unless (memq char
  96                        (setq ret
  97                              (aref ideograph-radical-chars-vector radical)))
  98            (char-ideographic-strokes char)
  99            (aset ideograph-radical-chars-vector radical
 100                  (cons char ret))))
 101        nil)
 102      'ideographic-radical)))
 103
 104 (defun int-list< (a b)
 105   (if (numberp (car a))
 106       (if (numberp (car b))
 107           (if (= (car a) (car b))
 108               (int-list< (cdr a)(cdr b))
 109             (< (car a) (car b)))
 110         nil)
 111     (numberp (car b))))
 112
 113 (defun morohashi-daikanwa< (a b)
 114   (if (integerp a)
 115       (setq a (list a)))
 116   (if (integerp b)
 117       (setq b (list b)))
 118   (cond ((eq (car a) 'ho)
 119          (if (eq (car b) 'ho)
 120              (int-list< (cdr a)(cdr b))
 121            nil))
 122         ((numberp (car a))
 123          (if (eq (car b) 'ho)
 124              t
 125            (int-list< a b)))
 126         (t
 127          (if (eq (car b) 'ho)
 128              t
 129            (int-list< a b)))))
 130
 131 (defun char-representative-of-daikanwa (char)
 132   (if (get-char-attribute char 'ideograph-daikanwa)
 133       char
 134     (let ((m (get-char-attribute char 'morohashi-daikanwa))
 135           m-m m-s pat)
 136       (or (when m
 137             (setq m-m (pop m))
 138             (setq m-s (pop m))
 139             (if (= m-s 0)
 140                 (decode-char 'ideograph-daikanwa m-m)
 141               (when m
 142                 (setq pat (list m-m m-s))
 143                 (map-char-attribute (lambda (c v)
 144                                       (if (equal pat v)
 145                                           c))
 146                                     'morohashi-daikanwa))))
 147           char))))
 148
 149 (defun ideograph-char< (a b)
 150   (let (a-m b-m a-s b-s a-u b-u ret)
 151     (setq ret (char-representative-of-daikanwa a))
 152     (setq a-s (char-ideographic-strokes
 153                (if (= (get-char-attribute ret 'ideographic-radical)
 154                       (get-char-attribute a 'ideographic-radical))
 155                    ret
 156                  a)))
 157     (setq ret (char-representative-of-daikanwa b))
 158     (setq b-s (char-ideographic-strokes
 159                (if (= (get-char-attribute ret 'ideographic-radical)
 160                       (get-char-attribute b 'ideographic-radical))
 161                    ret
 162                  b)))
 163     (if a-s
 164         (if b-s
 165             (if (= a-s b-s)
 166                 (if (setq a-m (or (get-char-attribute a 'ideograph-daikanwa)
 167                                   (get-char-attribute a 'morohashi-daikanwa)))
 168                     (if (setq b-m
 169                               (or (get-char-attribute b 'ideograph-daikanwa)
 170                                   (get-char-attribute b 'morohashi-daikanwa)))
 171                         (morohashi-daikanwa< a-m b-m)
 172                       t)
 173                   (if (setq b-m
 174                             (or (get-char-attribute b 'ideograph-daikanwa)
 175                                 (get-char-attribute b 'morohashi-daikanwa)))
 176                       nil
 177                     (setq a-u (get-char-attribute a 'ucs)
 178                           b-u (get-char-attribute b 'ucs))
 179                     (if a-u
 180                         (if b-u
 181                             (< a-u b-u)
 182                           (setq b-u (or (get-char-attribute b '=>ucs)
 183                                         (get-char-attribute b '->ucs)))
 184                           (if b-u
 185                               (<= a-u b-u)
 186                             t))
 187                       (setq a-u (or (get-char-attribute a '=>ucs)
 188                                     (get-char-attribute a '->ucs)))
 189                       (if a-u
 190                           (if b-u
 191                               (< a-u b-u)
 192                             (setq b-u (or (get-char-attribute b '=>ucs)
 193                                           (get-char-attribute b '->ucs)))
 194                             (if b-u
 195                                 (< a-u b-u)
 196                               t))
 197                         (if (or b-u (or (get-char-attribute b '=>ucs)
 198                                         (get-char-attribute b '->ucs)))
 199                             nil
 200                           (< (char-int a)(char-int b)))))))
 201               (< a-s b-s))
 202           t))))
 203
 204 (defun insert-ideograph-radical-char-data (radical)
 205   (let ((chars
 206          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 207                (function ideograph-char<)))
 208         attributes ccs)
 209     (dolist (name (char-attribute-list))
 210       (if (find-charset name)
 211           (push name ccs)
 212         (push name attributes)))
 213     (setq attributes (sort attributes #'char-attribute-name<)
 214           ccs (sort ccs #'char-attribute-name<))
 215     (aset ideograph-radical-chars-vector radical chars)
 216     (while chars
 217       (insert-char-data (car chars) nil attributes ccs)
 218       (setq chars (cdr chars)))))
 219
 220 (defun write-ideograph-radical-char-data (radical file)
 221   (if (file-directory-p file)
 222       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 223         (if (string-match "KANGXI RADICAL " name)
 224             (setq name (capitalize (substring name (match-end 0)))))
 225         (setq name (mapconcat (lambda (char)
 226                                 (if (eq char ? )
 227                                     "-"
 228                                   (char-to-string char))) name ""))
 229         (setq file
 230               (expand-file-name
 231                (format "Ideograph-R%03d-%s.el" radical name)
 232                file))))
 233   (with-temp-buffer
 234     (insert-ideograph-radical-char-data radical)
 235     (char-db-update-comment)
 236     (let ((coding-system-for-write 'utf-8))
 237       (write-region (point-min)(point-max) file)
 238       )))
 239
 240 (defun ideographic-structure= (char1 char2)
 241   (if (char-ref-p char1)
 242       (setq char1 (plist-get char1 :char)))
 243   (if (char-ref-p char2)
 244       (setq char2 (plist-get char2 :char)))
 245   (let ((s1 (if (characterp char1)
 246                 (get-char-attribute char1 'ideographic-structure)
 247               (cdr (assq 'ideographic-structure char1))))
 248         (s2 (if (characterp char2)
 249                 (get-char-attribute char2 'ideographic-structure)
 250               (cdr (assq 'ideographic-structure char2))))
 251         e1 e2)
 252     (if (or (null s1)(null s2))
 253         (char-spec= char1 char2)
 254       (catch 'tag
 255         (while (and s1 s2)
 256           (setq e1 (car s1)
 257                 e2 (car s2))
 258           (unless (ideographic-structure= e1 e2)
 259             (throw 'tag nil))
 260           (setq s1 (cdr s1)
 261                 s2 (cdr s2)))
 262         (and (null s1)(null s2))))))
 263
 264 ;;;###autoload
 265 (defun ideographic-structure-find-char (structure)
 266   (let (rest)
 267     (map-char-attribute (lambda (char value)
 268                           (setq rest structure)
 269                           (catch 'tag
 270                             (while (and rest value)
 271                               (unless (ideographic-structure=
 272                                        (car rest)(car value))
 273                                 (throw 'tag nil))
 274                               (setq rest (cdr rest)
 275                                     value (cdr value)))
 276                             (unless (or rest value)
 277                               char)))
 278                         'ideographic-structure)))
 279
 280 (provide 'ideograph-util)
 281
 282 ;;; ideograph-util.el ends here