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 (get-char-attribute ; char-feature
29 component 'ideographic-products)))
30 (unless (memq product ret)
31 (put-char-attribute component 'ideographic-products
33 ;; (when ret (setq ret (get-char-attribute ; char-feature
34 ;; component 'ideographic-structure))
35 ;; (ids-index-store-structure product ret))
38 (defun ids-index-store-structure (product structure)
40 (dolist (cell (cdr structure))
42 (setq cell (plist-get cell :char)))
43 (cond ((characterp cell)
44 (ids-index-store-char product cell))
45 ((setq ret (assq 'ideographic-structure cell))
46 (ids-index-store-structure product (cdr ret)))
47 ;; ((setq ret (find-char cell))
48 ;; (ids-index-store-char product ret))
52 (defun ids-update-index ()
56 (ids-index-store-structure c v)
58 'ideographic-structure)
59 (save-char-attribute-table 'ideographic-products))
62 (mount-char-attribute-table 'ideographic-products)
65 (defun ids-find-all-products (char)
67 (dolist (cell (char-feature char 'ideographic-products))
68 (unless (memq cell dest)
69 (setq dest (cons cell dest)))
70 (setq dest (union dest (ids-find-all-products cell))))
74 (defun char-component-variants (char)
77 ((setq ret (char-feature char '<-ideographic-component-forms))
79 (setq dest (union dest (char-component-variants c)))))
80 ((setq ret (get-char-attribute char '->ucs-unified))
81 (setq dest (cons char ret))
83 (setq dest (union dest
85 c '->ideographic-component-forms))))
87 ((and (setq ret (get-char-attribute char '=>ucs))
88 (setq uchr (decode-char '=ucs ret)))
89 (setq dest (cons uchr (char-variants uchr)))
91 (setq dest (union dest
93 c '->ideographic-component-forms))))
96 (map-char-family (lambda (c)
98 (setq dest (cons c dest)))
102 c '->ideographic-component-forms)))
108 (defun ideographic-products-find (&rest components)
109 (if (stringp (car components))
110 (setq components (car components)))
111 (let ((len (length components))
114 (dolist (variant (char-component-variants (elt components 0)))
115 (dolist (product (get-char-attribute variant 'ideographic-products))
116 (unless (memq product products)
117 (setq products (cons product products)))))
123 (dolist (variant (char-component-variants (elt components i)))
124 (dolist (product (get-char-attribute
125 variant 'ideographic-products))
126 (unless (memq product products)
127 (when (memq product dest)
128 (setq products (cons product products))))))
129 (setq dest products)))
134 (defun ideographic-structure-char= (c1 c2)
137 (let ((m1 (char-ucs c1))
142 (unless (characterp b2)
143 (setq b2 (find-char b2)))
145 (ideographic-structure-char= c1 b2)))
147 c2 '<-ideographic-component-forms))
149 (setq m1 (car (get-char-attribute c1 '<-radical))
150 m2 (car (get-char-attribute c2 '<-radical)))
151 (unless (characterp m1)
152 (setq m1 (find-char m1)))
153 (unless (characterp m2)
154 (setq m2 (find-char m2)))
156 (ideographic-structure-char= m1 m2))))))))
158 (defun ideographic-structure-member-compare-components (component s-component)
160 (cond ((char-ref= component s-component #'ideographic-structure-char=))
162 (if (setq ret (assq 'ideographic-structure s-component))
163 (ideographic-structure-member component (cdr ret))))
164 ((setq ret (get-char-attribute s-component 'ideographic-structure))
165 (ideographic-structure-member component ret)))))
168 (defun ideographic-structure-member (component structure)
169 "Return non-nil if COMPONENT is included in STRUCTURE."
170 (or (memq component structure)
172 (setq structure (cdr structure))
173 (ideographic-structure-member-compare-components
174 component (car structure)))
176 (setq structure (cdr structure))
177 (ideographic-structure-member-compare-components
178 component (car structure)))
180 (setq structure (cdr structure))
182 (ideographic-structure-member-compare-components
183 component (car structure))))))
187 (defun ideographic-structure-repertoire-p (structure components)
188 "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
190 (let (ret s-component)
192 (while (setq structure (cdr structure))
193 (setq s-component (car structure))
194 (unless (characterp s-component)
195 (if (setq ret (find-char s-component))
196 (setq s-component ret)))
199 (if (setq ret (assq 'ideographic-structure s-component))
200 (ideographic-structure-repertoire-p
201 (cdr ret) components)))
202 ((member* s-component components
203 :test #'ideographic-structure-char=))
205 (get-char-attribute s-component
206 'ideographic-structure))
207 (ideographic-structure-repertoire-p ret components)))
212 (defvar ids-find-result-buffer "*ids-chars*")
214 (defun ids-find-format-line (c v)
215 (format "%c\t%s\t%s\n"
217 (or (let ((ucs (or (char-ucs c)
218 (encode-char c 'ucs))))
220 (cond ((<= ucs #xFFFF)
221 (format " U+%04X" ucs))
223 (format "U-%08X" ucs)))))
225 (or (ideographic-structure-to-ids v)
228 (defun ids-insert-chars-including-components (components level)
230 (dolist (c (ideographic-products-find components))
231 (setq is (char-feature c 'ideographic-structure))
232 ;; to avoid problems caused by wrong indexes
233 (when (every (lambda (cc)
234 (ideographic-structure-member cc is))
236 ;;(ids-insert-chars-including-components (char-to-string c) (1+ level))
241 (insert (ids-find-format-line c is))
243 (ids-insert-chars-including-components
244 (char-to-string c) (1+ level))
249 (defun ids-find-chars-including-components (components)
250 "Search Ideographs whose structures have COMPONENTS."
251 (interactive "sComponents : ")
252 (with-current-buffer (get-buffer-create ids-find-result-buffer)
253 (setq buffer-read-only nil)
255 (ids-insert-chars-including-components components 0)
257 ;; (dolist (c (ideographic-products-find components))
258 ;; (setq is (char-feature c 'ideographic-structure))
259 ;; ;; to avoid problems caused by wrong indexes
260 ;; ;; (when (every (lambda (cc)
261 ;; ;; (ideographic-structure-member cc is))
263 ;; (dolist (dc (ideographic-products-find (char-to-string c)))
264 ;; (setq dis (char-feature dc 'ideographic-structure))
265 ;; ;; ;; to avoid problems caused by wrong indexes
266 ;; ;; (when (every (lambda (dcc)
267 ;; ;; (ideographic-structure-member dcc is))
270 ;; (insert (ids-find-format-line dc dis))
274 ;; (insert (ids-find-format-line c is))
279 (goto-char (point-min)))
280 (view-buffer ids-find-result-buffer))
281 ;; (defun ids-find-chars-including-components (components)
282 ;; "Search Ideographs whose structures have COMPONENTS."
283 ;; (interactive "sComponents : ")
284 ;; (with-current-buffer (get-buffer-create ids-find-result-buffer)
285 ;; (setq buffer-read-only nil)
287 ;; (map-char-attribute
289 ;; (when (every (lambda (p)
290 ;; (ideographic-structure-member p v))
292 ;; (insert (ids-find-format-line c v)))
294 ;; 'ideographic-structure)
295 ;; (goto-char (point-min)))
296 ;; (view-buffer ids-find-result-buffer))
299 (define-obsolete-function-alias 'ideographic-structure-search-chars
300 'ids-find-chars-including-components)
303 (defun ids-find-chars-covered-by-components (components)
304 "Search Ideographs which structures are consisted by subsets of COMPONENTS."
305 (interactive "sComponents: ")
306 (if (stringp components)
307 (setq components (string-to-char-list components)))
308 (with-current-buffer (get-buffer-create ids-find-result-buffer)
309 (setq buffer-read-only nil)
314 (when (ideographic-structure-repertoire-p v components)
315 (insert (ids-find-format-line c v))))
316 'ideographic-structure))
317 (goto-char (point-min)))
318 (view-buffer ids-find-result-buffer))
326 ;;; ids-find.el ends here