1 ;;; ideograph-util.el --- Ideographic Character Database utility
3 ;; Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko.
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
8 ;; This file is part of XEmacs UTF-2000.
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.
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.
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.
27 (require 'char-db-util)
29 (defvar ideograph-radical-chars-vector
30 (make-vector 215 nil))
32 (defun char-ideographic-radical (char)
33 (or (get-char-attribute char 'ideographic-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))))
40 (put-char-attribute char 'ideographic-radical radical)
43 (defvar ideograph-radical-strokes-vector
45 [nil 1 1 1 1 1 1 2 2 2
64 9 9 9 9 8 9 9 10 10 10
65 10 10 10 10 10 11 11 11 11 11
67 11 12 12 12 12 13 13 13 13 14
70 (defun char-ideographic-strokes (char)
71 (or (get-char-attribute char 'daikanwa-strokes)
72 (get-char-attribute char 'ideographic-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)))
80 (- ts (aref ideograph-radical-strokes-vector r))))
83 (put-char-attribute char 'ideographic-strokes strokes)
87 (defun update-ideograph-radical-table ()
91 (lambda (char radical)
93 (or (null (setq script (get-char-attribute char 'script)))
94 (memq 'Ideograph script)))
97 (aref ideograph-radical-chars-vector radical)))
98 (char-ideographic-strokes char)
99 (aset ideograph-radical-chars-vector radical
102 'ideographic-radical)))
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))
113 (defun morohashi-daikanwa< (a b)
118 (cond ((eq (car a) 'ho)
120 (int-list< (cdr a)(cdr b))
131 ;; (defun nil=-int< (a b)
132 ;; (cond ((null a) nil)
136 ;; (defun nil>-int< (a b)
137 ;; (cond ((null a) nil)
141 (defun char-representative-of-daikanwa (char)
142 (if (get-char-attribute char 'ideograph-daikanwa)
144 (let ((m (get-char-attribute char 'morohashi-daikanwa))
150 (decode-char 'ideograph-daikanwa m-m)
152 (setq pat (list m-m m-s))
153 (map-char-attribute (lambda (c v)
156 'morohashi-daikanwa))))
159 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
161 (let (a1 a2 accessor tester dm)
162 (while (and accessors testers)
163 (setq accessor (car accessors)
166 (when (and accessor tester)
167 (setq a1 (funcall accessor c1)
168 a2 (funcall accessor c2))
181 (cond ((funcall tester a1 a2)
183 ((funcall tester a2 a1)
184 (throw 'tag nil))))))
185 (setq accessors (cdr accessors)
186 testers (cdr testers)
187 defaulters (cdr defaulters))))))
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))
198 (defun char-daikanwa (char)
199 (or (get-char-attribute char 'ideograph-daikanwa)
200 (get-char-attribute char 'morohashi-daikanwa)))
203 (defun char-ucs (char)
204 (or (get-char-attribute char 'ucs)
205 (get-char-attribute char '=>ucs)
206 (get-char-attribute char '->ucs)))
208 (defun char-id (char)
209 (logand (char-int char) #x3FFFFFFF))
211 (defun ideograph-char< (a b)
212 (char-attributes-poly<
214 '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
215 '(< morohashi-daikanwa< < <)
218 (defun insert-ideograph-radical-char-data (radical)
220 (sort (copy-list (aref ideograph-radical-chars-vector radical))
221 (function ideograph-char<)))
223 (dolist (name (char-attribute-list))
224 (unless (memq name char-db-ignored-attributes)
225 (if (find-charset name)
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)
232 (when (some (lambda (ccs)
233 (encode-char char ccs))
235 (insert-char-data char nil attributes ccss)))))
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)
245 (char-to-string char))) name ""))
248 (format "Ideograph-R%03d-%s.el" radical name)
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)
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))))
269 (if (or (null s1)(null s2))
270 (char-spec= char1 char2)
275 (unless (ideographic-structure= e1 e2)
279 (and (null s1)(null s2))))))
282 (defun ideographic-structure-find-char (structure)
284 (map-char-attribute (lambda (char value)
285 (setq rest structure)
287 (while (and rest value)
288 (unless (ideographic-structure=
289 (car rest)(car value))
291 (setq rest (cdr rest)
293 (unless (or rest value)
295 'ideographic-structure)))
297 (provide 'ideograph-util)
299 ;;; ideograph-util.el ends here