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 UTF-2000.
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)
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.
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
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 ()
92 (charsets '(japanese-jisx0208-1978
94 japanese-jisx0208-1990
112 (setq char (decode-char 'ucs i))
113 (when (and (or (null (setq script (get-char-attribute char 'script)))
114 (memq 'Ideograph script))
115 (setq radical (char-ideographic-radical char)))
116 (or (get-char-attribute char 'ucs)
117 (put-char-attribute char 'ucs i))
118 (char-ideographic-strokes char)
121 (aref ideograph-radical-chars-vector radical))))
122 (aset ideograph-radical-chars-vector radical
126 (while (<= i #x10FFFF)
127 (setq char (decode-char 'ucs i))
128 (when (and (or (null (setq script (get-char-attribute char 'script)))
129 (memq 'Ideograph script))
130 (setq radical (char-ideographic-radical char)))
133 (aref ideograph-radical-chars-vector radical))))
134 (aset ideograph-radical-chars-vector radical
139 (setq char (decode-char 'ideograph-gt i))
140 (if (and (setq radical (char-ideographic-radical char))
144 (aref ideograph-radical-chars-vector radical)))))
145 (aset ideograph-radical-chars-vector radical
150 (setq char (decode-char 'ideograph-daikanwa i))
151 (if (and (setq radical (char-ideographic-radical char))
155 (aref ideograph-radical-chars-vector radical)))))
156 (aset ideograph-radical-chars-vector radical
160 (while (< i (* 94 60 22))
161 (setq char (decode-char 'mojikyo i))
162 (if (and (setq radical (char-ideographic-radical char))
166 (aref ideograph-radical-chars-vector radical)))))
167 (aset ideograph-radical-chars-vector radical
175 (setq char (make-char (car charsets) i j))
176 (if (and (or (null (setq script (get-char-attribute char 'script)))
177 (memq 'Ideograph script))
178 (setq radical (char-ideographic-radical char))
181 (aref ideograph-radical-chars-vector
183 (aset ideograph-radical-chars-vector radical
187 (setq charsets (cdr charsets)))
190 (defun int-list< (a b)
191 (if (numberp (car a))
192 (if (numberp (car b))
193 (if (= (car a) (car b))
194 (int-list< (cdr a)(cdr b))
199 (defun morohashi-daikanwa< (a b)
200 (cond ((eq (car a) 'ho)
202 (int-list< (cdr a)(cdr b))
213 (defun ideograph-char< (a b)
214 (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
215 (b-m-m (get-char-attribute b 'ideograph-daikanwa))
220 (setq a-s (char-ideographic-strokes a))
221 (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
224 (setq a-m-m (car a-m-r)
226 (if (= (car a-m-r) 0)
228 (setq ret (decode-char 'ideograph-daikanwa a-m-m))
229 (if (= (get-char-attribute ret 'ideographic-radical)
230 (get-char-attribute a 'ideographic-radical))
231 (setq a-s (char-ideographic-strokes ret))
232 (setq a-s (char-ideographic-strokes a))))
233 (if (setq m (get-char-attribute a '->mojikyo))
234 (setq a-s (char-ideographic-strokes
235 (decode-char 'mojikyo m)))
236 (setq a-s (char-ideographic-strokes a)))))
237 (setq a-s (char-ideographic-strokes a))))
239 (setq b-s (char-ideographic-strokes b))
240 (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
243 (setq b-m-m (car b-m-r)
245 (if (= (car b-m-r) 0)
247 (setq ret (decode-char 'ideograph-daikanwa b-m-m))
248 (if (= (get-char-attribute ret 'ideographic-radical)
249 (get-char-attribute b 'ideographic-radical))
250 (setq b-s (char-ideographic-strokes ret))
251 (setq b-s (char-ideographic-strokes b))))
252 (if (setq m (get-char-attribute b '->mojikyo))
253 (setq b-s (char-ideographic-strokes
254 (decode-char 'mojikyo m)))
255 (setq b-s (char-ideographic-strokes b)))))
256 (setq b-s (char-ideographic-strokes b))))
262 (morohashi-daikanwa< (cons a-m-m a-m-r)
267 (setq a-u (get-char-attribute a 'ucs)
268 b-u (get-char-attribute b 'ucs))
272 (setq b-u (get-char-attribute b '->ucs))
276 (setq a-u (get-char-attribute a '->ucs))
280 (setq b-u (get-char-attribute b '->ucs))
284 (if (or b-u (get-char-attribute b '->ucs))
286 (< (char-int a)(char-int b)))))))
290 ;; (defun ideograph-char< (a b)
291 ;; (let (ra rb mma mmb msa msb)
294 ;; (if (setq ra (or (get-char-attribute a 'non-morohashi)
295 ;; (get-char-attribute a 'morohashi-daikanwa)))
296 ;; (setq msa (cdr ra)
298 ;; (setq mma (get-char-attribute a 'ideograph-daikanwa))))
301 ;; (if (setq rb (or (get-char-attribute b 'non-morohashi)
302 ;; (get-char-attribute b 'morohashi-daikanwa)))
303 ;; (setq msb (cdr rb)
305 ;; (setq mmb (get-char-attribute b 'ideograph-daikanwa))))
308 ;; (cond ((eq (car msa)(car msb))
309 ;; (cond ((< (length msa)(length msb)))
310 ;; ((= (length msa)(length msb))
311 ;; (cond ((integerp (nth 1 msa))
312 ;; (cond ((integerp (nth 1 msb))
313 ;; (< (nth 1 msa)(nth 1 msb)))
316 ;; (cond ((setq ra (get-char-attribute a 'ucs))
318 ;; ((setq rb (get-char-attribute b 'ucs))
322 ;; ((null (car msa)))
325 ;; (t (< (car msa)(car msb)))))
328 ;; ((or (get-char-attribute b 'non-morohashi)
329 ;; (get-char-attribute b 'morohashi-daikanwa)
330 ;; (get-char-attribute b 'ideograph-daikanwa))
332 ;; ((setq ra (get-char-attribute a 'ucs))
334 ;; ((setq rb (get-char-attribute b 'ucs))
338 ;; ((setq ra (char-ideographic-strokes a))
339 ;; (cond ((setq rb (char-ideographic-strokes b))
341 ;; (not (char-ideographic-strokes b)))
345 (defun insert-ideograph-radical-char-data (radical)
347 (sort (copy-list (aref ideograph-radical-chars-vector radical))
348 (function ideograph-char<)))
349 (attributes (sort (char-attribute-list) #'char-attribute-name<))
350 (ccs (sort (charset-list) #'char-attribute-name<)))
351 (aset ideograph-radical-chars-vector radical chars)
353 (insert-char-data (car chars) nil attributes ccs)
354 (setq chars (cdr chars)))))
356 (defun write-ideograph-radical-char-data (radical file)
357 (if (file-directory-p file)
358 (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
359 (if (string-match "KANGXI RADICAL " name)
360 (setq name (capitalize (substring name (match-end 0)))))
361 (setq name (mapconcat (lambda (char)
364 (char-to-string char))) name ""))
367 (format "Ideograph-R%03d-%s.el" radical name)
370 (insert-ideograph-radical-char-data radical)
371 (char-db-update-comment)
372 (let ((coding-system-for-write 'utf-8))
373 (write-region (point-min)(point-max) file)
376 (provide 'ideograph-util)
378 ;;; ideograph-util.el ends here