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