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

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 1999,2000,2001,2002 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 nil=-int< (a b)
 132 ;;   (cond ((null a) nil)
 133 ;;         ((null b) nil)
 134 ;;         (t (< a b))))
 135
 136 ;; (defun nil>-int< (a b)
 137 ;;   (cond ((null a) nil)
 138 ;;         ((null b) t)
 139 ;;         (t (< a b))))
 140
 141 (defun char-representative-of-daikanwa (char)
 142   (if (get-char-attribute char 'ideograph-daikanwa)
 143       char
 144     (let ((m (get-char-attribute char 'morohashi-daikanwa))
 145           m-m m-s pat)
 146       (or (when m
 147             (setq m-m (pop m))
 148             (setq m-s (pop m))
 149             (if (= m-s 0)
 150                 (decode-char 'ideograph-daikanwa m-m)
 151               (when m
 152                 (setq pat (list m-m m-s))
 153                 (map-char-attribute (lambda (c v)
 154                                       (if (equal pat v)
 155                                           c))
 156                                     'morohashi-daikanwa))))
 157           char))))
 158
 159 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 160   (catch 'tag
 161     (let (a1 a2 accessor tester dm)
 162       (while (and accessors testers)
 163         (setq accessor (car accessors)
 164               tester (car testers)
 165               dm (car defaulters))
 166         (when (and accessor tester)
 167           (setq a1 (funcall accessor c1)
 168                 a2 (funcall accessor c2))
 169           (cond ((null a1)
 170                  (if a2
 171                      (cond ((eq dm '<)
 172                             (throw 'tag t))
 173                            ((eq dm '>)
 174                             (throw 'tag nil)))))
 175                 ((null a2)
 176                  (cond ((eq dm '<)
 177                         (throw 'tag nil))
 178                        ((eq dm '>)
 179                         (throw 'tag t))))
 180                 (t
 181                  (cond ((funcall tester a1 a2)
 182                         (throw 'tag t))
 183                        ((funcall tester a2 a1)
 184                         (throw 'tag nil))))))
 185         (setq accessors (cdr accessors)
 186               testers (cdr testers)
 187               defaulters (cdr defaulters))))))
 188
 189 (defun char-daikanwa-strokes (char)
 190   (let ((drc (char-representative-of-daikanwa char)))
 191     (char-ideographic-strokes
 192      (if (= (get-char-attribute drc 'ideographic-radical)
 193             (get-char-attribute char 'ideographic-radical))
 194          drc
 195        char))))
 196
 197 ;;;###autoload
 198 (defun char-daikanwa (char)
 199   (or (get-char-attribute char 'ideograph-daikanwa)
 200       (get-char-attribute char 'morohashi-daikanwa)))
 201
 202 ;;;###autoload
 203 (defun char-ucs (char)
 204   (or (get-char-attribute char 'ucs)
 205       (get-char-attribute char '=>ucs)
 206       (get-char-attribute char '->ucs)))
 207
 208 (defun char-id (char)
 209   (logand (char-int char) #x3FFFFFFF))
 210
 211 (defun ideograph-char< (a b)
 212   (char-attributes-poly<
 213    a b
 214    '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 215    '(< morohashi-daikanwa< < <)
 216    '(> > > >)))
 217
 218 (defun insert-ideograph-radical-char-data (radical)
 219   (let ((chars
 220          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 221                (function ideograph-char<)))
 222         attributes ccss)
 223     (dolist (name (char-attribute-list))
 224       (unless (memq name char-db-ignored-attributes)
 225         (if (find-charset name)
 226             (push name ccss)
 227           (push name attributes))))
 228     (setq attributes (sort attributes #'char-attribute-name<)
 229           ccss (sort ccss #'char-attribute-name<))
 230     (aset ideograph-radical-chars-vector radical chars)
 231     (dolist (char chars)
 232       (when (some (lambda (ccs)
 233                     (encode-char char ccs))
 234                   ccss)
 235         (insert-char-data char nil attributes ccss)))))
 236
 237 (defun write-ideograph-radical-char-data (radical file)
 238   (if (file-directory-p file)
 239       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 240         (if (string-match "KANGXI RADICAL " name)
 241             (setq name (capitalize (substring name (match-end 0)))))
 242         (setq name (mapconcat (lambda (char)
 243                                 (if (eq char ? )
 244                                     "-"
 245                                   (char-to-string char))) name ""))
 246         (setq file
 247               (expand-file-name
 248                (format "Ideograph-R%03d-%s.el" radical name)
 249                file))))
 250   (with-temp-buffer
 251     (insert-ideograph-radical-char-data radical)
 252     (char-db-update-comment)
 253     (let ((coding-system-for-write 'utf-8))
 254       (write-region (point-min)(point-max) file)
 255       )))
 256
 257 (defun ideographic-structure= (char1 char2)
 258   (if (char-ref-p char1)
 259       (setq char1 (plist-get char1 :char)))
 260   (if (char-ref-p char2)
 261       (setq char2 (plist-get char2 :char)))
 262   (let ((s1 (if (characterp char1)
 263                 (get-char-attribute char1 'ideographic-structure)
 264               (cdr (assq 'ideographic-structure char1))))
 265         (s2 (if (characterp char2)
 266                 (get-char-attribute char2 'ideographic-structure)
 267               (cdr (assq 'ideographic-structure char2))))
 268         e1 e2)
 269     (if (or (null s1)(null s2))
 270         (char-spec= char1 char2)
 271       (catch 'tag
 272         (while (and s1 s2)
 273           (setq e1 (car s1)
 274                 e2 (car s2))
 275           (unless (ideographic-structure= e1 e2)
 276             (throw 'tag nil))
 277           (setq s1 (cdr s1)
 278                 s2 (cdr s2)))
 279         (and (null s1)(null s2))))))
 280
 281 ;;;###autoload
 282 (defun ideographic-structure-find-char (structure)
 283   (let (rest)
 284     (map-char-attribute (lambda (char value)
 285                           (setq rest structure)
 286                           (catch 'tag
 287                             (while (and rest value)
 288                               (unless (ideographic-structure=
 289                                        (car rest)(car value))
 290                                 (throw 'tag nil))
 291                               (setq rest (cdr rest)
 292                                     value (cdr value)))
 293                             (unless (or rest value)
 294                               char)))
 295                         'ideographic-structure)))
 296
 297 (provide 'ideograph-util)
 298
 299 ;;; ideograph-util.el ends here