1 ;;; ideograph-util.el --- Ideographic Character Database utility
3 ;; Copyright (C) 1999,2000 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-ideograph-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 (defun char-ideograph-strokes (char)
44 (or (get-char-attribute char 'ideographic-strokes)
46 (or (get-char-attribute char 'daikanwa-strokes)
47 (get-char-attribute char 'kangxi-strokes)
48 (get-char-attribute char 'japanese-strokes)
49 (get-char-attribute char 'korean-strokes))))
51 (put-char-attribute char 'ideographic-strokes strokes)
55 (defun update-ideograph-radical-table ()
60 (charsets '(japanese-jisx0208-1978
62 japanese-jisx0208-1990
80 (setq char (decode-char 'ucs i))
81 (when (and (or (null (setq script (get-char-attribute char 'script)))
82 (memq 'Ideograph script))
83 (setq radical (char-ideograph-radical char)))
84 (or (get-char-attribute char 'ucs)
85 (put-char-attribute char 'ucs i))
86 (char-ideograph-strokes char)
89 (aref ideograph-radical-chars-vector radical))))
90 (aset ideograph-radical-chars-vector radical
94 (while (<= i #x10FFFF)
95 (setq char (decode-char 'ucs i))
96 (when (and (or (null (setq script (get-char-attribute char 'script)))
97 (memq 'Ideograph script))
98 (setq radical (char-ideograph-radical char)))
101 (aref ideograph-radical-chars-vector radical))))
102 (aset ideograph-radical-chars-vector radical
107 (setq char (decode-char 'ideograph-daikanwa i))
108 (if (and (setq radical (char-ideograph-radical char))
112 (aref ideograph-radical-chars-vector radical)))))
113 (aset ideograph-radical-chars-vector radical
121 (setq char (make-char (car charsets) i j))
122 (if (and (or (null (setq script (get-char-attribute char 'script)))
123 (memq 'Ideograph script))
124 (setq radical (char-ideograph-radical char))
127 (aref ideograph-radical-chars-vector
129 (aset ideograph-radical-chars-vector radical
133 (setq charsets (cdr charsets)))
136 (defun ideograph-char< (a b)
137 (let (ra rb mma mmb msa msb)
140 (if (setq ra (or (get-char-attribute a 'non-morohashi)
141 (get-char-attribute a 'morohashi-daikanwa)))
144 (setq mma (get-char-attribute a 'ideograph-daikanwa))))
147 (if (setq rb (or (get-char-attribute b 'non-morohashi)
148 (get-char-attribute b 'morohashi-daikanwa)))
151 (setq mmb (get-char-attribute b 'ideograph-daikanwa))))
154 (cond ((eq (car msa)(car msb))
155 (cond ((< (length msa)(length msb)))
156 ((= (length msa)(length msb))
157 (cond ((integerp (nth 1 msa))
158 (cond ((integerp (nth 1 msb))
159 (< (nth 1 msa)(nth 1 msb)))
162 (cond ((setq ra (get-char-attribute a 'ucs))
164 ((setq rb (get-char-attribute b 'ucs))
171 (t (< (car msa)(car msb)))))
174 ((or (get-char-attribute b 'non-morohashi)
175 (get-char-attribute b 'morohashi-daikanwa)
176 (get-char-attribute b 'ideograph-daikanwa))
178 ((setq ra (get-char-attribute a 'ucs))
180 ((setq rb (get-char-attribute b 'ucs))
184 ((setq ra (char-ideograph-strokes a))
185 (cond ((setq rb (char-ideograph-strokes b))
187 (not (char-ideograph-strokes b)))
191 (defun insert-ideograph-radical-char-data (radical)
193 (sort (copy-list (aref ideograph-radical-chars-vector radical))
194 (function ideograph-char<)))
195 (attributes (sort (char-attribute-list) #'char-attribute-name<))
196 (ccs (sort (charset-list) #'char-attribute-name<)))
197 (aset ideograph-radical-chars-vector radical chars)
199 (insert-char-data (car chars) nil attributes ccs)
200 (setq chars (cdr chars)))))
202 (defun write-ideograph-radical-char-data (radical file)
203 (if (file-directory-p file)
204 (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
205 (if (string-match "KANGXI RADICAL " name)
206 (setq name (capitalize (substring name (match-end 0)))))
207 (setq name (mapconcat (lambda (char)
210 (char-to-string char))) name ""))
213 (format "Ideograph-R%03d-%s.el" radical name)
216 (insert-ideograph-radical-char-data radical)
217 (char-db-update-comment)
218 (let ((coding-system-for-write 'utf-8))
219 (write-region (point-min)(point-max) file)
222 (provide 'ideograph-util)
224 ;;; ideograph-util.el ends here