1 ;;; ideograph-subr.el --- basic lisp subroutines about Ideographs -*- coding: utf-8-er; -*-
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2010
6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
9 ;; This file is part of XEmacs CHISE.
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.
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.
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.
34 (defconst ideographic-radicals
35 (let ((v (make-vector 215 nil))
38 (aset v i (decode-char '=ucs (+ #x2EFF i)))
43 (defun ideographic-radical (number)
44 "Return character corresponding with Kangxi-radical number."
45 (aref ideographic-radicals number))
51 (defun get-char-feature-from-domains (char feature domains
58 (dolist (domain domains)
59 (if (and (or (null tester)
60 (equal (or (char-feature
61 ch (expand-char-feature-name
63 (char-feature ch tester))
65 (setq ret (or (char-feature
66 ch (expand-char-feature-name
68 (char-feature ch feature))))
76 (defun char-ideographic-radical (char &optional radical ignore-sisters)
79 (get-char-feature-from-domains
80 char 'ideographic-radical (cons nil char-db-feature-domains)
81 'ideographic-radical radical ignore-sisters)
82 (get-char-feature-from-domains
83 char 'ideographic-radical (cons nil char-db-feature-domains)
86 ;; (dolist (domain char-db-feature-domains)
87 ;; (if (and (setq ret (char-feature
91 ;; 'ideographic-radical domain))))
92 ;; (or (eq ret radical)
94 ;; (throw 'tag ret))))
96 (dolist (cell (get-char-attribute char 'ideographic-))
97 (if (and (setq ret (plist-get cell :radical))
101 (get-char-feature-from-domains
102 char 'ideographic-radical (cons nil char-db-feature-domains))
103 ;; (char-feature char 'ideographic-radical)
106 (or (get-char-attribute char 'daikanwa-radical)
107 (get-char-attribute char 'kangxi-radical)
108 (get-char-attribute char 'japanese-radical)
109 (get-char-attribute char 'korean-radical)))
111 (put-char-attribute char 'ideographic-radical ret)
115 ;;; @@ strokes of non-radical parts
119 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
121 (get-char-feature-from-domains char 'ideographic-strokes domains
122 'ideographic-radical radical)
123 (get-char-feature-from-domains char 'ideographic-strokes domains)))
125 (defvar ideograph-radical-strokes-vector
126 ;;0 1 2 3 4 5 6 7 8 9
127 [nil 1 1 1 1 1 1 2 2 2
146 9 9 9 9 8 9 9 10 10 10
147 10 10 10 10 10 11 11 11 11 11
149 11 12 12 12 12 13 13 13 13 14
153 (defun char-ideographic-strokes (char &optional radical preferred-domains)
156 (dolist (cell (get-char-attribute char 'ideographic-))
157 (if (and (setq ret (plist-get cell :radical))
160 (throw 'tag (plist-get cell :strokes)))))
161 (char-ideographic-strokes-from-domains
162 char (append preferred-domains
164 char-db-feature-domains))
166 (get-char-attribute char 'daikanwa-strokes)
168 (or (get-char-attribute char 'kangxi-strokes)
169 (get-char-attribute char 'japanese-strokes)
170 (get-char-attribute char 'korean-strokes)
171 (let ((r (char-ideographic-radical char))
172 (ts (get-char-attribute char 'total-strokes)))
174 (- ts (aref ideograph-radical-strokes-vector r))))
177 (put-char-attribute char 'ideographic-strokes strokes)
185 (defun char-total-strokes-from-domains (char domains)
188 (dolist (domain domains)
189 (if (setq ret (char-feature
193 'total-strokes domain))))
194 (throw 'tag ret))))))
197 (defun char-total-strokes (char &optional preferred-domains)
198 (or (char-total-strokes-from-domains char preferred-domains)
199 (char-feature char 'total-strokes)
200 (char-total-strokes-from-domains char char-db-feature-domains)))
206 (provide 'ideograph-subr)
208 ;;; ideograph-subr.el ends here