1 ;;; ids-find.el --- search utility based on Ideographic-structures
3 ;; Copyright (C) 2002,2003,2005 MORIOKA Tomohiko
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode
8 ;; This file is a part of Tomoyo-Tools.
10 ;; This program 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.
15 ;; This program 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 this program; 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.
27 (defun ids-index-store-char (product component)
28 (let ((ret (char-feature component 'ideographic-products)))
29 (unless (memq product ret)
30 (put-char-attribute component 'ideographic-products
32 (when (setq ret (char-feature component 'ideographic-structure))
33 (ids-index-store-structure product ret))))
35 (defun ids-index-store-structure (product structure)
37 (dolist (cell (cdr structure))
39 (setq cell (plist-get cell :char)))
40 (cond ((characterp cell)
41 (ids-index-store-char product cell))
42 ((setq ret (assq 'ideographic-structure cell))
43 (ids-index-store-structure product (cdr ret)))
44 ((setq ret (find-char cell))
45 (ids-index-store-char product ret))))))
48 (defun ids-update-index ()
52 (ids-index-store-structure c v)
54 'ideographic-structure)
55 (save-char-attribute-table 'ideographic-products))
58 (mount-char-attribute-table 'ideographic-products)
61 (defun ids-find-all-products (char)
63 (dolist (cell (char-feature char 'ideographic-products))
64 (unless (memq cell dest)
65 (setq dest (cons cell dest)))
66 (setq dest (union dest (ids-find-all-products cell))))
70 (defun char-component-variants (char)
73 ((setq ret (char-feature char '<-ideographic-component-forms))
75 (setq dest (union dest (char-component-variants c)))))
76 ((setq ret (get-char-attribute char '->ucs-unified))
77 (setq dest (cons char ret))
79 (setq dest (union dest
81 c '->ideographic-component-forms))))
83 ((and (setq ret (get-char-attribute char '=>ucs))
84 (setq uchr (decode-char '=ucs ret)))
85 (setq dest (cons uchr (char-variants uchr)))
87 (setq dest (union dest
89 c '->ideographic-component-forms))))
92 (map-char-family (lambda (c)
94 (setq dest (cons c dest)))
98 c '->ideographic-component-forms)))
104 (defun ideographic-products-find (&rest components)
105 (if (stringp (car components))
106 (setq components (car components)))
107 (let ((len (length components))
110 (dolist (variant (char-component-variants (elt components 0)))
111 (dolist (product (get-char-attribute variant 'ideographic-products))
112 (unless (memq product products)
113 (setq products (cons product products)))))
119 (dolist (variant (char-component-variants (elt components i)))
120 (dolist (product (get-char-attribute
121 variant 'ideographic-products))
122 (unless (memq product products)
123 (when (memq product dest)
124 (setq products (cons product products))))))
125 (setq dest products)))
130 (defun ideographic-structure-char= (c1 c2)
133 (let ((m1 (char-ucs c1))
138 (unless (characterp b2)
139 (setq b2 (find-char b2)))
141 (ideographic-structure-char= c1 b2)))
143 c2 '<-ideographic-component-forms))
145 (setq m1 (car (get-char-attribute c1 '<-radical))
146 m2 (car (get-char-attribute c2 '<-radical)))
147 (unless (characterp m1)
148 (setq m1 (find-char m1)))
149 (unless (characterp m2)
150 (setq m2 (find-char m2)))
152 (ideographic-structure-char= m1 m2))))))))
154 (defun ideographic-structure-member-compare-components (component s-component)
156 (cond ((char-ref= component s-component #'ideographic-structure-char=))
158 (if (setq ret (assq 'ideographic-structure s-component))
159 (ideographic-structure-member component (cdr ret))))
160 ((setq ret (get-char-attribute s-component 'ideographic-structure))
161 (ideographic-structure-member component ret)))))
164 (defun ideographic-structure-member (component structure)
165 "Return non-nil if COMPONENT is included in STRUCTURE."
166 (or (memq component structure)
168 (setq structure (cdr structure))
169 (ideographic-structure-member-compare-components
170 component (car structure)))
172 (setq structure (cdr structure))
173 (ideographic-structure-member-compare-components
174 component (car structure)))
176 (setq structure (cdr structure))
178 (ideographic-structure-member-compare-components
179 component (car structure))))))
183 (defun ideographic-structure-repertoire-p (structure components)
184 "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
186 (let (ret s-component)
188 (while (setq structure (cdr structure))
189 (setq s-component (car structure))
190 (unless (characterp s-component)
191 (if (setq ret (find-char s-component))
192 (setq s-component ret)))
195 (if (setq ret (assq 'ideographic-structure s-component))
196 (ideographic-structure-repertoire-p
197 (cdr ret) components)))
198 ((member* s-component components
199 :test #'ideographic-structure-char=))
201 (get-char-attribute s-component
202 'ideographic-structure))
203 (ideographic-structure-repertoire-p ret components)))
208 (defvar ids-find-result-buffer "*ids-chars*")
210 (defun ids-find-format-line (c v)
211 (format "%c\t%s\t%s\n"
213 (or (let ((ucs (or (char-ucs c)
214 (encode-char c 'ucs))))
216 (cond ((<= ucs #xFFFF)
217 (format " U+%04X" ucs))
219 (format "U-%08X" ucs)))))
221 (or (ideographic-structure-to-ids v)
225 (defun ids-find-chars-including-components (components)
226 "Search Ideographs whose structures have COMPONENTS."
227 (interactive "sComponents : ")
228 (with-current-buffer (get-buffer-create ids-find-result-buffer)
229 (setq buffer-read-only nil)
231 (dolist (c (ideographic-products-find components))
232 (insert (ids-find-format-line
233 c (char-feature c 'ideographic-structure)))
236 (goto-char (point-min)))
237 (view-buffer ids-find-result-buffer))
238 ;; (defun ids-find-chars-including-components (components)
239 ;; "Search Ideographs whose structures have COMPONENTS."
240 ;; (interactive "sComponents : ")
241 ;; (with-current-buffer (get-buffer-create ids-find-result-buffer)
242 ;; (setq buffer-read-only nil)
244 ;; (map-char-attribute
246 ;; (when (every (lambda (p)
247 ;; (ideographic-structure-member p v))
249 ;; (insert (ids-find-format-line c v)))
251 ;; 'ideographic-structure)
252 ;; (goto-char (point-min)))
253 ;; (view-buffer ids-find-result-buffer))
256 (define-obsolete-function-alias 'ideographic-structure-search-chars
257 'ids-find-chars-including-components)
260 (defun ids-find-chars-covered-by-components (components)
261 "Search Ideographs which structures are consisted by subsets of COMPONENTS."
262 (interactive "sComponents: ")
263 (if (stringp components)
264 (setq components (string-to-char-list components)))
265 (with-current-buffer (get-buffer-create ids-find-result-buffer)
266 (setq buffer-read-only nil)
271 (when (ideographic-structure-repertoire-p v components)
272 (insert (ids-find-format-line c v))))
273 'ideographic-structure))
274 (goto-char (point-min)))
275 (view-buffer ids-find-result-buffer))
283 ;;; ids-find.el ends here