2b8d259f5c5e62b1b587e8ca2d4d617058b3ef09
[chise/xemacs-chise.git-] / lisp / utf-2000 / ideograph-util.el
1 ;;; ideograph-util.el --- Ideographic Character Database utility
2
3 ;; Copyright (C) 1999 MORIOKA Tomohiko.
4
5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
7
8 ;; This file is part of UTF-2000.
9
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)
13 ;; any later version.
14
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.
19
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
23 ;; 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-ideograph-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 (defun char-ideograph-strokes (char)
44   (or (get-char-attribute char 'ideographic-strokes)
45       (let ((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))))
50         (when strokes
51           (put-char-attribute char 'ideographic-strokes strokes)
52           strokes))))
53
54 ;;;###autoload
55 (defun update-ideograph-radical-table ()
56   (interactive)
57   (let ((i #x3400)
58         j
59         char radical
60         (charsets '(japanese-jisx0208-1978
61                     japanese-jisx0208
62                     japanese-jisx0208-1990
63                     japanese-jisx0212
64                     chinese-cns11643-1
65                     chinese-cns11643-2
66                     chinese-cns11643-3
67                     chinese-cns11643-4
68                     chinese-cns11643-5
69                     chinese-cns11643-6
70                     chinese-cns11643-7
71                     korean-ksc5601
72                     chinese-gb2312
73                     chinese-isoir165
74                     chinese-big5-1
75                     chinese-big5-2))
76         ret)
77     (while (<= i #x9FFF)
78       (setq char (int-char i))
79       (when (setq radical (char-ideograph-radical char))
80         (or (get-char-attribute char 'ucs)
81             (put-char-attribute char 'ucs i))
82         (if (not (memq char
83                        (setq ret
84                              (aref ideograph-radical-chars-vector radical))))
85             (aset ideograph-radical-chars-vector radical
86                   (cons char ret))))
87       (setq i (1+ i)))
88     (setq i #x100000)
89     (while (<= i #x10FFFF)
90       (setq char (int-char i))
91       (when (setq radical (char-ideograph-radical char))
92         (if (not (memq char
93                        (setq ret
94                              (aref ideograph-radical-chars-vector radical))))
95             (aset ideograph-radical-chars-vector radical
96                   (cons char ret))))
97       (setq i (1+ i)))
98     (setq i 0)
99     (while (< i 256)
100       (setq j 0)
101       (while (< j 256)
102         (setq char (make-char 'ideograph-daikanwa i j))
103         (if (and (setq radical (char-ideograph-radical char))
104                  (not
105                   (memq char
106                         (setq ret
107                               (aref ideograph-radical-chars-vector radical)))))
108             (aset ideograph-radical-chars-vector radical
109                   (cons char ret)))
110         (setq j (1+ j)))
111       (setq i (1+ i)))
112     (while charsets
113       (setq i 33)
114       (while (< i 127)
115         (setq j 33)
116         (while (< j 127)
117           (setq char (make-char (car charsets) i j))
118           (if (and (setq radical (char-ideograph-radical char))
119                    (not (memq char
120                               (setq ret
121                                     (aref ideograph-radical-chars-vector
122                                           radical)))))
123               (aset ideograph-radical-chars-vector radical
124                     (cons char ret)))
125           (setq j (1+ j)))
126         (setq i (1+ i)))
127       (setq charsets (cdr charsets)))
128     ))
129
130 (defun ideograph-char< (a b)
131   (let (ra rb)
132     (cond
133      ((setq ra (or (get-char-attribute a 'morohashi-daikanwa)
134                    (get-char-attribute a 'non-morohashi)))
135       (cond
136        ((setq rb (or (get-char-attribute b 'morohashi-daikanwa)
137                      (get-char-attribute b 'non-morohashi)))
138         (cond
139          ((= (car ra)(car rb))
140           (cond ((eq (car (cdr ra))(car (cdr rb)))
141                  (cond ((< (length ra)(length rb)))
142                        ((= (length ra)(length rb))
143                         (cond ((integerp (nth 2 ra))
144                                (cond ((integerp (nth 2 rb))
145                                       (< (nth 2 ra)(nth 2 rb)))
146                                      (t nil)))
147                               (t
148                                (cond ((setq ra (get-char-attribute a 'ucs))
149                                       (cond
150                                        ((setq rb (get-char-attribute b 'ucs))
151                                         (< ra rb))
152                                        (t))))))))
153                  )
154                 ((null (car (cdr ra))))
155                 ((null (car (cdr rb)))
156                  nil)
157                 (t (< (car (cdr ra))(car (cdr rb))))))
158          (t (< (car ra)(car rb)))))
159        ((setq ra (get-char-attribute a 'ucs))
160         (cond
161          ((setq rb (get-char-attribute b 'ucs))
162           (< ra rb))))
163        (t
164         (cond
165          ((setq ra (char-ideograph-strokes a))
166           (cond ((setq rb (char-ideograph-strokes b))
167                  (cond ((= ra rb)
168                         (not (char-ideograph-strokes b)))
169                        ((< ra rb))))))
170          )))))))
171
172 (defun insert-ideograph-radical-char-data (radical)
173   (let ((chars
174          (sort (copy-list (aref ideograph-radical-chars-vector radical))
175                (function ideograph-char<))))
176     (while chars
177       (insert-char-data (car chars))
178       (setq chars (cdr chars)))))
179
180 (defun write-ideograph-radical-char-data (radical file)
181   (if (file-directory-p file)
182       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
183         (if (string-match "KANGXI RADICAL " name)
184             (setq name (capitalize (substring name (match-end 0)))))
185         (setq file
186               (expand-file-name
187                (format "Ideograph-R%03d-%s.el" radical name)
188                file))))
189   (with-temp-buffer
190     (insert-ideograph-radical-char-data radical)
191     (write-region (point-min)(point-max) file)))
192
193 (provide 'ideograph-util)
194
195 ;;; ideograph-util.el ends here