Add `===shuowen-jiguge-A30' characters.
[chise/xemacs-chise.git] / lisp / utf-2000 / ideograph-subr.el
1 ;;; ideograph-subr.el --- basic lisp subroutines about Ideographs -*- coding: utf-8-er; -*-
2
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2010
4 ;;   MORIOKA Tomohiko.
5
6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
8
9 ;; This file is part of XEmacs CHISE.
10
11 ;; XEmacs CHISE is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
15
16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
19 ;; General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Code:
27
28 (require 'chise-subr)
29
30
31 ;;; @ radical code
32 ;;;
33
34 (defconst ideographic-radicals
35   (let ((v (make-vector 215 nil))
36         (i 1))
37     (while (< i 215)
38       (aset v i (decode-char '=ucs (+ #x2EFF i)))
39       (setq i (1+ i)))
40     v))
41
42 ;;;###autoload
43 (defun ideographic-radical (number)
44   "Return character corresponding with Kangxi-radical number."
45   (aref ideographic-radicals number))
46
47
48 ;;; @ char feature
49 ;;;
50
51 (defun get-char-feature-from-domains (char feature domains
52                                            &optional tester arg
53                                            ignore-sisters)
54   (map-char-family
55    (lambda (ch)
56      (let (ret)
57        (catch 'tag
58          (dolist (domain domains)
59            (if (and (or (null tester)
60                         (equal (or (char-feature
61                                     ch (expand-char-feature-name
62                                         tester domain))
63                                    (char-feature ch tester))
64                                arg))
65                     (setq ret (or (char-feature
66                                    ch (expand-char-feature-name
67                                        feature domain))
68                                   (char-feature ch feature))))
69                (throw 'tag ret))))))
70    char ignore-sisters))
71
72
73 ;;; @@ radical
74 ;;;
75
76 ;;;###autoload
77 (defun char-ideographic-radical (char &optional radical ignore-sisters)
78   (let (ret)
79     (or (if radical
80             (get-char-feature-from-domains
81              char 'ideographic-radical (cons nil char-db-feature-domains)
82              'ideographic-radical radical ignore-sisters)
83           (get-char-feature-from-domains
84            char 'ideographic-radical (cons nil char-db-feature-domains)
85            ignore-sisters))
86         ;; (catch 'tag
87         ;;   (dolist (domain char-db-feature-domains)
88         ;;     (if (and (setq ret (char-feature
89         ;;                         char
90         ;;                         (intern
91         ;;                          (format "%s@%s"
92         ;;                                  'ideographic-radical domain))))
93         ;;              (or (eq ret radical)
94         ;;                  (null radical)))
95         ;;         (throw 'tag ret))))
96         (catch 'tag
97           (dolist (cell (get-char-attribute char 'ideographic-))
98             (if (and (setq ret (plist-get cell :radical))
99                      (or (eq ret radical)
100                          (null radical)))
101                 (throw 'tag ret))))
102         (get-char-feature-from-domains
103          char 'ideographic-radical (cons nil char-db-feature-domains))
104         ;; (char-feature char 'ideographic-radical)
105         (progn
106           (setq ret
107                 (or (get-char-attribute char 'daikanwa-radical)
108                     (get-char-attribute char 'kangxi-radical)
109                     (get-char-attribute char 'japanese-radical)
110                     (get-char-attribute char 'korean-radical)))
111           (when ret
112             (put-char-attribute char 'ideographic-radical ret)
113             ret)))))
114
115
116 ;;; @@ strokes of non-radical parts
117 ;;;
118
119 ;;;###autoload
120 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
121   (if radical
122       (get-char-feature-from-domains char 'ideographic-strokes domains
123                                      'ideographic-radical radical)
124     (get-char-feature-from-domains char 'ideographic-strokes domains)))
125
126 (defvar ideograph-radical-strokes-vector
127   ;;0  1  2  3  4  5  6  7  8  9
128   [nil 1  1  1  1  1  1  2  2  2
129     2  2  2  2  2  2  2  2  2  2
130     2  2  2  2  2  2  2  2  2  2
131     3  3  3  3  3  3  3  3  3  3
132     3  3  3  3  3  3  3  3  3  3
133     3  3  3  3  3  3  3  3  3  3
134     3  4  4  4  3  4  4  4  4  4
135     4  4  4  4  4  4  4  4  4  4
136     4  4  4  4  4  3  4  4  4  4
137     4  4  4  4  3  5  4  5  5  5
138     ;; 100
139     5  5  5  5  5  5  5  5  5  5
140     5  5  5  5  5  5  5  5  6  6
141     6  6  6  6  6  6  6  6  6  6
142     4  6  6  6  6  6  6  6  6  6
143     4  6  6  6  6  6  6  7  7  7
144     7  7  7  7  7  7  7  7  7  7
145     7  7  4  3  7  7  7  8  7  8
146     3  8  8  8  8  8  9  9  9  9
147     9  9  9  9  8  9  9 10 10 10
148    10 10 10 10 10 11 11 11 11 11
149    ;; 200
150    11 12 12 12 12 13 13 13 13 14
151    14 15 16 16 17])
152
153 ;;;###autoload
154 (defun char-ideographic-strokes (char &optional radical preferred-domains)
155   (let (ret)
156     (or (catch 'tag
157           (dolist (cell (get-char-attribute char 'ideographic-))
158             (if (and (setq ret (plist-get cell :radical))
159                      (or (eq ret radical)
160                          (null radical)))
161                 (throw 'tag (plist-get cell :strokes)))))
162         (char-ideographic-strokes-from-domains
163          char (append preferred-domains
164                       (cons nil
165                             char-db-feature-domains))
166          radical)
167         (get-char-attribute char 'daikanwa-strokes)
168         (let ((strokes
169                (or (get-char-attribute char 'kangxi-strokes)
170                    (get-char-attribute char 'japanese-strokes)
171                    (get-char-attribute char 'korean-strokes)
172                    (let ((r (char-ideographic-radical char))
173                          (ts (get-char-attribute char 'total-strokes)))
174                      (if (and r ts)
175                          (- ts (aref ideograph-radical-strokes-vector r))))
176                    )))
177           (when strokes
178             (put-char-attribute char 'ideographic-strokes strokes)
179             strokes)))))
180
181
182 ;;; @@ total-strokes
183 ;;;
184
185 ;;;###autoload
186 (defun char-total-strokes-from-domains (char domains)
187   (let (ret)
188     (catch 'tag
189       (dolist (domain domains)
190         (if (setq ret (char-feature
191                        char
192                        (intern
193                         (format "%s@%s"
194                                 'total-strokes domain))))
195             (throw 'tag ret))))))
196
197 ;;;###autoload
198 (defun char-total-strokes (char &optional preferred-domains)
199   (or (char-total-strokes-from-domains char preferred-domains)
200       (char-feature char 'total-strokes)
201       (char-total-strokes-from-domains char char-db-feature-domains)))
202
203
204 ;;; @ end
205 ;;;
206
207 (provide 'ideograph-subr)
208
209 ;;; ideograph-subr.el ends here