1 ;;; ideograph-util.el --- Ideographic Character Database utility
3 ;; Copyright (C) 1999,2000,2001 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)
114 (cond ((eq (car a) 'ho)
116 (int-list< (cdr a)(cdr b))
127 (defun ideograph-char< (a b)
128 (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
129 (b-m-m (get-char-attribute b 'ideograph-daikanwa))
135 (setq a-s (char-ideographic-strokes a))
136 (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
139 (setq a-m-m (car a-m-r)
141 (if (= (car a-m-r) 0)
143 (setq ret (decode-char 'ideograph-daikanwa a-m-m))
144 (if (= (get-char-attribute ret 'ideographic-radical)
145 (get-char-attribute a 'ideographic-radical))
146 (setq a-s (char-ideographic-strokes ret))
147 (setq a-s (char-ideographic-strokes a))))
148 (setq a-s (char-ideographic-strokes
151 (setq pat (list a-m-m (car a-m-r)))
152 (or (map-char-attribute (lambda (c v)
159 (setq a-s (char-ideographic-strokes a))))
161 (setq b-s (char-ideographic-strokes b))
162 (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
165 (setq b-m-m (car b-m-r)
167 (if (= (car b-m-r) 0)
169 (setq ret (decode-char 'ideograph-daikanwa b-m-m))
170 (if (= (get-char-attribute ret 'ideographic-radical)
171 (get-char-attribute b 'ideographic-radical))
172 (setq b-s (char-ideographic-strokes ret))
173 (setq b-s (char-ideographic-strokes b))))
174 (setq b-s (char-ideographic-strokes
177 (setq pat (list b-m-m (car b-m-r)))
178 (or (map-char-attribute (lambda (c v)
185 (setq b-s (char-ideographic-strokes b))))
191 (morohashi-daikanwa< (cons a-m-m a-m-r)
196 (setq a-u (get-char-attribute a 'ucs)
197 b-u (get-char-attribute b 'ucs))
201 (setq b-u (or (get-char-attribute b '=>ucs)
202 (get-char-attribute b '->ucs)))
206 (setq a-u (or (get-char-attribute a '=>ucs)
207 (get-char-attribute a '->ucs)))
211 (setq b-u (or (get-char-attribute b '=>ucs)
212 (get-char-attribute b '->ucs)))
216 (if (or b-u (or (get-char-attribute b '=>ucs)
217 (get-char-attribute b '->ucs)))
219 (< (char-int a)(char-int b)))))))
223 (defun insert-ideograph-radical-char-data (radical)
225 (sort (copy-list (aref ideograph-radical-chars-vector radical))
226 (function ideograph-char<)))
227 (attributes (sort (char-attribute-list) #'char-attribute-name<))
228 (ccs (sort (charset-list) #'char-attribute-name<)))
229 (aset ideograph-radical-chars-vector radical chars)
231 (insert-char-data (car chars) nil attributes ccs)
232 (setq chars (cdr chars)))))
234 (defun write-ideograph-radical-char-data (radical file)
235 (if (file-directory-p file)
236 (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
237 (if (string-match "KANGXI RADICAL " name)
238 (setq name (capitalize (substring name (match-end 0)))))
239 (setq name (mapconcat (lambda (char)
242 (char-to-string char))) name ""))
245 (format "Ideograph-R%03d-%s.el" radical name)
248 (insert-ideograph-radical-char-data radical)
249 (char-db-update-comment)
250 (let ((coding-system-for-write 'utf-8))
251 (write-region (point-min)(point-max) file)
254 (provide 'ideograph-util)
256 ;;; ideograph-util.el ends here