1 ;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*-
3 ;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020 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 CHISE-IDS.
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 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)))
36 (defun ids-index-store-structure (product structure)
38 (dolist (cell (cdr structure))
40 (setq cell (plist-get cell :char)))
41 (cond ((characterp cell)
42 (ids-index-store-char product cell))
43 ((setq ret (assq 'ideographic-structure cell))
44 (ids-index-store-structure product (cdr ret)))
45 ((setq ret (find-char cell))
46 (ids-index-store-char product ret))
50 (defun ids-update-index (&optional in-memory)
54 (ids-index-store-structure c v)
56 'ideographic-structure)
59 (ids-index-store-structure c v)
61 'ideographic-structure@apparent)
63 (save-char-attribute-table 'ideographic-products)))
66 (mount-char-attribute-table 'ideographic-products)
69 (defun ids-find-all-products (char)
71 (dolist (cell (char-feature char 'ideographic-products))
72 (unless (memq cell dest)
73 (setq dest (cons cell dest)))
74 (setq dest (union dest (ids-find-all-products cell))))
77 (defun of-component-features ()
79 (dolist (feature (char-attribute-list))
80 (when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
81 (symbol-name feature))
83 (list* '<-mistakable '->mistakable
86 '<-original '->original
90 (defun to-component-features ()
92 (dolist (feature (char-attribute-list))
93 (when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
94 (symbol-name feature))
99 (defun char-component-variants (char)
100 (let ((dest (list char))
102 (dolist (feature (to-component-features))
103 (if (setq ret (get-char-attribute char feature))
105 (setq dest (union dest (char-component-variants c))))))
107 ;; ((setq ret (some (lambda (feature)
108 ;; (get-char-attribute char feature))
109 ;; (to-component-features)))
111 ;; (setq dest (union dest (char-component-variants c))))
113 ((setq ret (get-char-attribute char '->ucs-unified))
114 (setq dest (cons char ret))
116 (setq dest (union dest
117 (some (lambda (feature)
118 (get-char-attribute c feature))
119 (of-component-features))
122 ((and (setq ret (get-char-attribute char '=>ucs))
123 (setq uchr (decode-char '=ucs ret)))
124 (setq dest (cons uchr (char-variants uchr)))
126 (setq dest (union dest
127 (some (lambda (feature)
128 (get-char-attribute c feature))
129 (of-component-features))
135 (unless (memq c dest)
136 (setq dest (cons c dest)))
139 (some (lambda (feature)
140 (char-feature c feature))
141 (of-component-features))
149 (defun ideographic-products-find (&rest components)
150 (if (stringp (car components))
151 (setq components (string-to-char-list (car components))))
153 (dolist (variant (char-component-variants (car components)))
156 (get-char-attribute variant 'ideographic-products))))
159 (setq components (cdr components)))
161 (dolist (variant (char-component-variants (car components)))
164 (get-char-attribute variant 'ideographic-products))))
165 (setq dest (intersection dest products)))
168 (defun ideograph-find-products-with-variants (components &optional ignored-chars)
169 (if (stringp components)
170 (setq components (string-to-char-list components)))
172 (dolist (variant (char-component-variants (car components)))
176 (get-char-attribute variant 'ideographic-products)
180 (setq components (cdr components)))
182 (dolist (variant (char-component-variants (car components)))
186 (get-char-attribute variant 'ideographic-products)
188 (setq dest (intersection dest products)))
191 (defun ideograph-find-products (components &optional ignored-chars)
192 (if (stringp components)
193 (setq components (string-to-char-list components)))
195 ;; (dolist (variant (char-component-variants (car components)))
198 ;; (get-char-attribute variant 'ideographic-products))))
199 ;; (setq dest products)
200 (setq dest (get-char-attribute (car components) 'ideographic-products))
202 (setq components (cdr components)))
203 ;; (setq products nil)
204 ;; (dolist (variant (char-component-variants (car components)))
207 ;; (get-char-attribute variant 'ideographic-products))))
208 (setq products (get-char-attribute (car components) 'ideographic-products))
209 (setq dest (intersection dest products)))
213 (defun ideographic-structure-char= (c1 c2)
216 (let ((m1 (char-ucs c1))
220 (memq c1 (char-component-variants c2)))))))
222 (defun ideographic-structure-member-compare-components (component s-component)
224 (cond ((char-ref= component s-component #'ideographic-structure-char=))
226 (if (setq ret (assq 'ideographic-structure s-component))
227 (ideographic-structure-member component (cdr ret))))
228 ((setq ret (get-char-attribute s-component 'ideographic-structure))
229 (ideographic-structure-member component ret)))))
232 (defun ideographic-structure-member (component structure)
233 "Return non-nil if COMPONENT is included in STRUCTURE."
234 (or (memq component structure)
236 (setq structure (cdr structure))
237 (ideographic-structure-member-compare-components
238 component (car structure)))
240 (setq structure (cdr structure))
241 (ideographic-structure-member-compare-components
242 component (car structure)))
244 (setq structure (cdr structure))
246 (ideographic-structure-member-compare-components
247 component (car structure))))))
251 (defun ideographic-structure-repertoire-p (structure components)
252 "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
254 (let (ret s-component)
256 (while (setq structure (cdr structure))
257 (setq s-component (car structure))
258 (unless (characterp s-component)
259 (if (setq ret (find-char s-component))
260 (setq s-component ret)))
263 (if (setq ret (assq 'ideographic-structure s-component))
264 (ideographic-structure-repertoire-p
265 (cdr ret) components)))
266 ((member* s-component components
267 :test #'ideographic-structure-char=))
269 (get-char-attribute s-component
270 'ideographic-structure))
271 (ideographic-structure-repertoire-p ret components)))
276 (defvar ids-find-result-buffer "*ids-chars*")
278 (defun ids-find-format-line (c v)
279 (format "%c\t%s\t%s\n"
281 (or (let ((ucs (or (char-ucs c)
282 (encode-char c 'ucs))))
284 (cond ((<= ucs #xFFFF)
285 (format " U+%04X" ucs))
287 (format "U-%08X" ucs)))))
289 (or (ideographic-structure-to-ids v)
292 (defun ids-insert-chars-including-components* (components
293 &optional level ignored-chars)
297 (dolist (c (sort (copy-tree (ideograph-find-products components
300 (if (setq as (char-total-strokes a))
301 (if (setq bs (char-total-strokes b))
303 (ideograph-char< a b)
306 (ideograph-char< a b)))))
307 (unless (memq c ignored-chars)
308 (setq is (char-feature c 'ideographic-structure))
313 (insert (ids-find-format-line c is))
315 (ids-insert-chars-including-components*
316 (char-to-string c) (1+ level)
317 (cons c ignored-chars))))
322 (defun ids-insert-chars-including-components (components
323 &optional level ignored-chars)
328 (ids-insert-chars-including-components* components
329 level ignored-chars)))
331 (dolist (c ignored-chars)
332 (dolist (vc (char-component-variants c))
333 (unless (memq vc ignored-chars)
334 (when (setq is (get-char-attribute vc 'ideographic-structure))
339 (insert (ids-find-format-line vc is))
341 (ids-insert-chars-including-components*
342 (char-to-string vc) (1+ level)
343 (cons vc ignored-chars)))))))
344 (dolist (c (sort (copy-tree (ideograph-find-products-with-variants
345 components ignored-chars))
347 (if (setq as (char-total-strokes a))
348 (if (setq bs (char-total-strokes b))
350 (ideograph-char< a b)
353 (ideograph-char< a b)))))
354 (unless (memq c ignored-chars)
355 (setq is (get-char-attribute c 'ideographic-structure))
360 (insert (ids-find-format-line c is))
362 (ids-insert-chars-including-components*
363 (char-to-string c) (1+ level)
364 (cons c ignored-chars))))
370 (defun ids-find-chars-including-components (components)
371 "Search Ideographs whose structures have COMPONENTS."
372 (interactive "sComponents : ")
373 (with-current-buffer (get-buffer-create ids-find-result-buffer)
374 (setq buffer-read-only nil)
376 (ids-insert-chars-including-components components 0 nil)
377 ;; (let ((ignored-chars
379 ;; (ids-insert-chars-including-components components 0 nil
380 ;; #'ideograph-find-products)))
382 ;; (setq rest ignored-chars)
383 ;; ;; (dolist (c rest)
384 ;; ;; (setq ignored-chars
385 ;; ;; (union ignored-chars
386 ;; ;; (ids-insert-chars-including-components
387 ;; ;; (list c) 0 ignored-chars
388 ;; ;; #'ideograph-find-products-with-variants))))
389 ;; (ids-insert-chars-including-components components 0 ignored-chars
390 ;; #'ideograph-find-products-with-variants))
391 (goto-char (point-min)))
392 (view-buffer ids-find-result-buffer))
395 (define-obsolete-function-alias 'ideographic-structure-search-chars
396 'ids-find-chars-including-components)
399 (defun ids-find-chars-covered-by-components (components)
400 "Search Ideographs which structures are consisted by subsets of COMPONENTS."
401 (interactive "sComponents: ")
402 (if (stringp components)
403 (setq components (string-to-char-list components)))
404 (with-current-buffer (get-buffer-create ids-find-result-buffer)
405 (setq buffer-read-only nil)
409 (when (ideographic-structure-repertoire-p v components)
410 (insert (ids-find-format-line c v))))
411 'ideographic-structure)
412 (goto-char (point-min)))
413 (view-buffer ids-find-result-buffer))
416 (defun ideographic-structure-merge-components-alist (ca1 ca2)
417 (let ((dest-alist ca1)
420 (if (setq ret (assq (car cell) dest-alist))
421 (setcdr ret (+ (cdr ret)(cdr cell)))
422 (setq dest-alist (cons cell dest-alist))))
425 (defun ideographic-structure-to-components-alist (structure)
426 (apply #'ideographic-structure-to-components-alist* structure))
428 (defun ideographic-structure-to-components-alist* (operator component1 component2
431 (let (dest-alist ret)
433 (cond ((characterp component1)
434 (unless (encode-char component1 'ascii)
435 (list (cons component1 1)))
437 ((setq ret (assq 'ideographic-structure component1))
438 (ideographic-structure-to-components-alist (cdr ret))
440 ((setq ret (find-char component1))
444 (ideographic-structure-merge-components-alist
446 (cond ((characterp component2)
447 (unless (encode-char component2 'ascii)
448 (list (cons component2 1)))
450 ((setq ret (assq 'ideographic-structure component2))
451 (ideographic-structure-to-components-alist (cdr ret))
453 ((setq ret (find-char component2))
456 (if (memq operator '(?\u2FF2 ?\u2FF3))
457 (ideographic-structure-merge-components-alist
459 (cond ((characterp component3)
460 (unless (encode-char component3 'ascii)
461 (list (cons component3 1)))
463 ((setq ret (assq 'ideographic-structure component3))
464 (ideographic-structure-to-components-alist (cdr ret))
466 ((setq ret (find-char component3))
471 (defun ids-find-merge-variables (ve1 ve2)
477 (let ((dest-alist ve1)
481 (setq cell (car rest))
482 (if (setq ret (assq (car cell) ve1))
483 (eq (cdr ret)(cdr cell))
484 (setq dest-alist (cons cell dest-alist))))
485 (setq rest (cdr rest)))
491 (defun ideographic-structure-equal (structure1 structure2)
492 (let (dest-alist ret)
493 (and (setq dest-alist (ideographic-structure-character=
494 (car structure1)(car structure2)))
495 (setq ret (ideographic-structure-character=
496 (nth 1 structure1)(nth 1 structure2)))
497 (setq dest-alist (ids-find-merge-variables dest-alist ret))
498 (setq ret (ideographic-structure-character=
499 (nth 2 structure1)(nth 2 structure2)))
500 (setq dest-alist (ids-find-merge-variables dest-alist ret))
501 (if (memq (car structure1) '(?\u2FF2 ?\u2FF3))
502 (and (setq ret (ideographic-structure-character=
503 (nth 3 structure1)(nth 3 structure2)))
504 (setq dest-alist (ids-find-merge-variables dest-alist ret)))
508 (defun ideographic-structure-character= (c1 c2)
510 (cond ((characterp c1)
511 (cond ((encode-char c1 'ascii)
515 (if (encode-char c2 'ascii)
519 ((setq ret2 (find-char c2))
522 ((setq ret2 (assq 'ideographic-structure c2))
523 (and (setq ret (get-char-attribute c1 'ideographic-structure))
524 (ideographic-structure-equal ret (cdr ret2)))
527 ((setq ret (assq 'ideographic-structure c1))
528 (cond ((characterp c2)
529 (if (encode-char c2 'ascii)
531 (and (setq ret2 (get-char-attribute c2 'ideographic-structure))
532 (ideographic-structure-equal (cdr ret) ret2)))
534 ((setq ret2 (find-char c2))
535 (and (setq ret2 (get-char-attribute ret2 'ideographic-structure))
536 (ideographic-structure-equal (cdr ret) ret2))
538 ((setq ret2 (assq 'ideographic-structure c2))
539 (ideographic-structure-equal (cdr ret)(cdr ret2))
542 ((setq ret (find-char c1))
543 (cond ((characterp c2)
544 (if (encode-char c2 'ascii)
548 ((setq ret2 (find-char c2))
551 ((setq ret2 (assq 'ideographic-structure c2))
552 (and (setq ret (get-char-attribute ret 'ideographic-structure))
553 (ideographic-structure-equal ret (cdr ret2))
557 (defun ideographic-structure-find-chars (structure)
558 (let ((comp-alist (ideographic-structure-to-components-alist structure))
561 (sort (mapcar (lambda (cell)
562 (if (setq ret (get-char-attribute
563 (car cell) 'ideographic-products))
564 (cons ret (length ret))
568 (< (cdr a)(cdr b))))))
569 (when (or (and (setq str
570 (get-char-attribute pc 'ideographic-structure))
571 (ideographic-structure-equal str structure))
573 (get-char-attribute pc 'ideographic-structure@apparent))
574 (ideographic-structure-equal str structure)))
575 (setq pl (cons pc pl))
580 (defun ideographic-char-count-components (char component)
583 (cond ((eq char component)
585 ((setq structure (get-char-attribute char 'ideographic-structure))
586 (dolist (cell (ideographic-structure-to-components-alist structure))
589 (if (eq (car cell) char)
591 (* (ideographic-char-count-components (car cell) component)
599 (defun ideographic-character-get-structure (character)
600 "Return ideographic-structure of CHARACTER.
601 CHARACTER can be a character or char-spec."
603 (cond ((characterp character)
604 (get-char-attribute character 'ideographic-structure)
606 ((setq ret (assq 'ideographic-structure character))
609 ((setq ret (find-char character))
610 (get-char-attribute ret 'ideographic-structure)
614 (defun ideographic-char-match-component (char component)
615 "Return non-nil if character CHAR has COMPONENT in ideographic-structure.
616 COMPONENT can be a character or char-spec."
617 (or (ideographic-structure-character= char component)
618 (let ((str (ideographic-character-get-structure char)))
620 (or (ideographic-char-match-component (nth 1 str) component)
621 (ideographic-char-match-component (nth 2 str) component)
622 (if (memq (car str) '(?\u2FF2 ?\u2FF3))
623 (ideographic-char-match-component (nth 3 str) component)))))))
625 (defun ideographic-structure-char< (a b)
626 (let ((sa (get-char-attribute a 'ideographic-structure))
627 (sb (get-char-attribute b 'ideographic-structure))
631 (setq tsa (char-total-strokes a)
632 tsb (char-total-strokes b))
637 (ideograph-char< a b)))
641 (ideograph-char< a b))))
649 (setq tsa (char-total-strokes a)
650 tsb (char-total-strokes b))
655 (ideograph-char< a b)))
659 (ideograph-char< a b)))
664 (defun ideographic-chars-to-is-a-tree (chars)
665 (let (comp char products others dest rest
667 (setq chars (sort chars #'ideographic-structure-char<))
669 (setq comp (pop chars)
674 (setq char (pop rest))
676 ((ideographic-char-match-component char comp)
683 ;; (nreverse products)
685 (sort (ideographic-chars-to-is-a-tree products)
687 (setq la (length (cdr a))
691 (ideograph-char< (car a) (car b))
693 ;; (setq tsa (char-total-strokes (car a))
694 ;; tsb (char-total-strokes (car b)))
700 ;; (car a) (car b))))
704 ;; (ideograph-char< (car a) (car b)))))
712 (defun ids-find-chars-including-ids* (operator component1 component2
713 &optional component3)
714 (let ((comp-alist (ideographic-structure-to-components-alist*
715 operator component1 component2 component3))
717 (list (list* 'ideographic-structure
718 operator component1 component2
720 (list component3)))))
723 (sort (mapcar (lambda (cell)
724 (if (setq ret (get-char-attribute
725 (car cell) 'ideographic-products))
726 (cons ret (length ret))
730 (< (cdr a)(cdr b))))))
731 (when (and (every (lambda (cell)
732 (>= (ideographic-char-count-components pc (car cell))
735 (or (ideographic-char-match-component pc comp-spec)
736 (and (setq str (get-char-attribute pc 'ideographic-structure))
737 (ideographic-char-match-component
740 'ideographic-structure
741 (functional-ideographic-structure-to-apparent-structure
745 (ideographic-chars-to-is-a-tree rest)))
747 (defun ids-find-chars-including-ids (structure)
748 (if (characterp structure)
749 (setq structure (get-char-attribute structure 'ideographic-structure)))
750 (apply #'ids-find-chars-including-ids* structure))
752 (defun functional-ideographic-structure-to-apparent-structure (structure)
753 (ideographic-structure-compare-functional-and-apparent
754 structure nil 'conversion-only)
755 ;; (ideographic-structure-compact
756 ;; (let (enc enc-str enc2-str new-str)
758 ;; ((eq (car structure) ?⿸)
759 ;; (setq enc (nth 1 structure))
760 ;; (when (setq enc-str
761 ;; (cond ((characterp enc)
762 ;; (get-char-attribute enc 'ideographic-structure)
765 ;; (cdr (assq 'ideographic-structure enc))
768 ;; ((eq (car enc-str) ?⿰)
769 ;; (list ?⿰ (nth 1 enc-str)
770 ;; (list (list 'ideographic-structure
773 ;; (nth 2 structure))))
775 ;; ((and (eq (car enc-str) ?⿲)
776 ;; (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
777 ;; (eq (nth 2 enc-str) ?丨))
779 ;; (decode-char '=big5-cdp #x8B7A)
780 ;; (list (list 'ideographic-structure
783 ;; (nth 2 structure))))
785 ;; ((eq (car enc-str) ?⿱)
786 ;; (list ?⿱ (nth 1 enc-str)
788 ;; (cons 'ideographic-structure
789 ;; (or (functional-ideographic-structure-to-apparent-structure
793 ;; ((characterp (nth 2 enc-str))
794 ;; (if (or (eq (encode-char
818 ;; (eq (or (encode-char
823 ;; '=big5-cdp-itaiji-001))
826 ;; (get-char-attribute
828 ;; 'ideographic-structure))
834 ;; (assq 'ideographic-structure
835 ;; (nth 2 enc-str))))
845 ;; ((eq (car enc-str) ?⿸)
846 ;; (list ?⿸ (nth 1 enc-str)
848 ;; (cons 'ideographic-structure
852 ;; ((characterp (nth 2 enc-str))
853 ;; (if (memq (char-ucs (nth 2 enc-str))
861 ;; (nth 2 structure))))))
864 ;; ((eq (car structure) ?⿹)
865 ;; (setq enc (nth 1 structure))
866 ;; (when (setq enc-str
867 ;; (cond ((characterp enc)
868 ;; (get-char-attribute enc 'ideographic-structure)
871 ;; (cdr (assq 'ideographic-structure enc))
874 ;; ((eq (car enc-str) ?⿰)
876 ;; (list (list 'ideographic-structure
879 ;; (nth 2 structure)))
883 ;; ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
884 ;; (setq enc (nth 1 structure))
885 ;; (when (setq enc-str
886 ;; (cond ((characterp enc)
887 ;; (get-char-attribute enc 'ideographic-structure)
890 ;; (cdr (assq 'ideographic-structure enc))
893 ;; ((eq (car enc-str) ?⿺)
895 ;; (list (list 'ideographic-structure
901 ;; ((eq (car enc-str) ?⿱)
903 ;; (list (list 'ideographic-structure
911 ;; ((eq (car structure) ?⿴)
912 ;; (setq enc (nth 1 structure))
913 ;; (when (setq enc-str
914 ;; (cond ((characterp enc)
915 ;; (get-char-attribute enc 'ideographic-structure)
918 ;; (cdr (assq 'ideographic-structure enc))
921 ;; ((eq (car enc-str) ?⿱)
923 ;; ((and (characterp (nth 2 enc-str))
924 ;; (or (memq (char-ucs (nth 2 enc-str)) '(#x56D7 #x5F51 #x897F))
925 ;; (eq (char-feature (nth 2 enc-str) '=>big5-cdp)
929 ;; (list (list 'ideographic-structure
932 ;; (nth 2 structure)))
935 ;; ((and (characterp (nth 2 enc-str))
936 ;; (eq (char-ucs (nth 2 enc-str)) #x51F5))
939 ;; (list (list 'ideographic-structure
942 ;; (nth 2 structure)))
945 ;; ((and (characterp (nth 1 enc-str))
946 ;; (eq (char-feature (nth 1 enc-str) '=>ucs@component)
949 ;; (list (list 'ideographic-structure
952 ;; (nth 2 structure)))
964 ;; ((eq (car structure) ?⿶)
965 ;; (setq enc (nth 1 structure))
966 ;; (when (setq enc-str
967 ;; (cond ((characterp enc)
968 ;; (get-char-attribute enc 'ideographic-structure)
971 ;; (cdr (assq 'ideographic-structure enc))
974 ;; ((eq (car enc-str) ?⿱)
975 ;; (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
976 ;; (when (and enc2-str
977 ;; (eq (car enc2-str) ?⿰))
979 ;; (list (list 'ideographic-structure
983 ;; (nth 2 enc2-str)))
986 ;; ((eq (car enc-str) ?⿳)
987 ;; (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
988 ;; (when (and enc2-str
989 ;; (eq (car enc2-str) ?⿰))
991 ;; (list (list 'ideographic-structure
995 ;; (nth 2 enc2-str)))
999 ;; ((eq (car enc-str) ?⿲)
1002 ;; (list (list 'ideographic-structure
1004 ;; (nth 2 structure)
1005 ;; (nth 2 enc-str)))
1008 ;; ((eq (car enc-str) ?⿴)
1009 ;; (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1010 ;; (when (and enc2-str
1011 ;; (eq (car enc2-str) ?⿰))
1014 ;; (list (list 'ideographic-structure
1016 ;; (nth 2 structure)
1017 ;; (nth 2 enc-str)))
1018 ;; (nth 2 enc2-str)))
1021 ;; ((eq (car structure) ?⿵)
1022 ;; (setq enc (nth 1 structure))
1023 ;; (when (setq enc-str
1024 ;; (cond ((characterp enc)
1025 ;; (get-char-attribute enc 'ideographic-structure)
1028 ;; (cdr (assq 'ideographic-structure enc))
1031 ;; ((eq (car enc-str) ?⿱)
1032 ;; (setq enc2-str (ideographic-character-get-structure (nth 2 enc-str)))
1033 ;; (when (and enc2-str
1034 ;; (eq (car enc2-str) ?⿰))
1037 ;; (list (list 'ideographic-structure
1040 ;; (nth 2 structure)
1041 ;; (nth 2 enc2-str)))))
1043 ;; ((eq (car enc-str) ?⿳)
1044 ;; (setq enc2-str (ideographic-character-get-structure (nth 3 enc-str)))
1045 ;; (when (and enc2-str
1046 ;; (eq (car enc2-str) ?⿰))
1050 ;; (list (list 'ideographic-structure
1053 ;; (nth 2 structure)
1054 ;; (nth 2 enc2-str)))))
1056 ;; ((eq (car enc-str) ?⿲)
1059 ;; (list (list 'ideographic-structure
1062 ;; (nth 2 structure)))
1065 ;; ((eq (car enc-str) ?⿴)
1066 ;; (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1067 ;; (when (and enc2-str
1068 ;; (eq (car enc2-str) ?⿰))
1071 ;; (list (list 'ideographic-structure
1074 ;; (nth 2 structure)))
1075 ;; (nth 2 enc2-str)))
1078 ;; ((eq (car structure) ?⿻)
1079 ;; (setq enc (nth 1 structure))
1080 ;; (when (setq enc-str
1081 ;; (cond ((characterp enc)
1082 ;; (get-char-attribute enc 'ideographic-structure)
1085 ;; (cdr (assq 'ideographic-structure enc))
1088 ;; ((eq (car enc-str) ?⿱)
1091 ;; (nth 2 structure)
1099 (defun ideographic-structure-compact (structure)
1100 (let ((rest structure)
1104 (setq cell (pop rest))
1107 (cond ((setq ret (assq 'ideographic-structure cell))
1108 (setq sub (cdr ret))
1114 (if (setq ret (ideographic-structure-find-chars sub))
1116 (list (cons 'ideographic-structure sub))))
1118 (setq dest (cons cell dest)))
1121 (defun ideographic-structure-compare-functional-and-apparent (structure
1124 (let (enc enc-str enc2-str new-str new-str-c f-res a-res ret)
1126 ((eq (car structure) ?⿸)
1127 (setq enc (nth 1 structure))
1129 (cond ((characterp enc)
1130 (get-char-attribute enc 'ideographic-structure)
1133 (cdr (assq 'ideographic-structure enc))
1136 ((eq (car enc-str) ?⿰)
1137 (unless conversion-only
1138 (setq f-res (ids-find-chars-including-ids enc-str)))
1139 (setq new-str (list ?⿱
1143 (if (setq ret (ideographic-structure-find-chars new-str))
1145 (list (cons 'ideographic-structure new-str))))
1147 (list ?⿰ (nth 1 enc-str) new-str-c)
1148 (setq a-res (ids-find-chars-including-ids new-str))
1153 (list ?⿰ (nth 1 enc-str) new-str-c)
1156 ((and (eq (car enc-str) ?⿲)
1157 (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
1158 (eq (nth 2 enc-str) ?丨))
1159 (unless conversion-only
1160 (setq f-res (ids-find-chars-including-ids enc-str)))
1161 (setq new-str (list ?⿱
1165 (if (setq ret (ideographic-structure-find-chars new-str))
1167 (list (cons 'ideographic-structure new-str))))
1169 (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
1170 (setq a-res (ids-find-chars-including-ids new-str))
1175 (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
1178 ((eq (car enc-str) ?⿱)
1179 (unless conversion-only
1180 (setq f-res (ids-find-chars-including-ids enc-str)))
1184 ((characterp (nth 2 enc-str))
1185 (if (or (eq (encode-char (nth 2 enc-str) '=>ucs@component)
1187 (eq (encode-char (nth 2 enc-str) '=>ucs@component)
1189 (eq (encode-char (nth 2 enc-str) '=>ucs@component)
1191 (eq (encode-char (nth 2 enc-str) '=big5-cdp)
1193 (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
1195 (eq (encode-char (nth 2 enc-str) '=big5-cdp)
1197 (eq (or (encode-char (nth 2 enc-str) '=>big5-cdp)
1198 (encode-char (nth 2 enc-str) '=big5-cdp-itaiji-001))
1200 (eq (car (get-char-attribute (nth 2 enc-str)
1201 'ideographic-structure))
1205 ((eq (car (cdr (assq 'ideographic-structure (nth 2 enc-str))))
1213 (if (setq ret (ideographic-structure-find-chars new-str))
1215 (list (cons 'ideographic-structure new-str))))
1217 (list ?⿱ (nth 1 enc-str) new-str-c)
1218 (setq a-res (ids-find-chars-including-ids new-str))
1223 (list ?⿱ (nth 1 enc-str) new-str-c)
1224 (if (eq (car new-str) ?⿸)
1228 ((eq (car enc-str) ?⿸)
1229 (unless conversion-only
1230 (setq f-res (ids-find-chars-including-ids enc-str)))
1231 (setq new-str (list (cond
1232 ((characterp (nth 2 enc-str))
1233 (if (memq (char-ucs (nth 2 enc-str))
1243 (if (setq ret (ideographic-structure-find-chars new-str))
1245 (list (cons 'ideographic-structure new-str))))
1247 (list ?⿸ (nth 1 enc-str) new-str-c)
1248 (setq a-res (ids-find-chars-including-ids new-str))
1253 (list ?⿸ (nth 1 enc-str) new-str-c)
1254 (if (eq (car new-str) ?⿰)
1259 ((eq (car structure) ?⿹)
1260 (setq enc (nth 1 structure))
1262 (cond ((characterp enc)
1263 (get-char-attribute enc 'ideographic-structure)
1266 (cdr (assq 'ideographic-structure enc))
1269 ((eq (car enc-str) ?⿰)
1270 (unless conversion-only
1271 (setq f-res (ids-find-chars-including-ids enc-str)))
1272 (setq new-str (list ?⿱
1276 (if (setq ret (ideographic-structure-find-chars new-str))
1278 (list (cons 'ideographic-structure new-str))))
1280 (list ?⿰ new-str-c (nth 2 enc-str))
1281 (setq a-res (ids-find-chars-including-ids new-str))
1286 (list ?⿰ new-str-c (nth 2 enc-str))
1290 ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
1291 (setq enc (nth 1 structure))
1293 (cond ((characterp enc)
1294 (get-char-attribute enc 'ideographic-structure)
1297 (cdr (assq 'ideographic-structure enc))
1300 ((eq (car enc-str) ?⿺)
1301 (unless conversion-only
1302 (setq f-res (ids-find-chars-including-ids enc-str)))
1303 (setq new-str (list ?⿱
1307 (if (setq ret (ideographic-structure-find-chars new-str))
1309 (list (cons 'ideographic-structure new-str))))
1311 (list ?⿺ new-str-c (nth 2 enc-str))
1312 (setq a-res (ids-find-chars-including-ids new-str))
1317 (list ?⿺ new-str-c (nth 2 enc-str))
1320 ((eq (car enc-str) ?⿱)
1321 (unless conversion-only
1322 (setq f-res (ids-find-chars-including-ids enc-str)))
1323 (setq new-str (list ?⿰
1327 (if (setq ret (ideographic-structure-find-chars new-str))
1329 (list (cons 'ideographic-structure new-str))))
1331 (list ?⿱ new-str-c (nth 2 enc-str))
1332 (setq a-res (ids-find-chars-including-ids new-str))
1337 (list ?⿱ new-str-c (nth 2 enc-str))
1342 ((eq (car structure) ?⿴)
1343 (setq enc (nth 1 structure))
1345 (cond ((characterp enc)
1346 (get-char-attribute enc 'ideographic-structure)
1349 (cdr (assq 'ideographic-structure enc))
1352 ((eq (car enc-str) ?⿱)
1354 ((and (characterp (nth 2 enc-str))
1355 (or (memq (char-ucs (nth 2 enc-str)) '(#x56D7 #x5F51 #x897F))
1356 (eq (char-feature (nth 2 enc-str) '=>big5-cdp)
1358 (unless conversion-only
1359 (setq f-res (ids-find-chars-including-ids enc-str)))
1360 (setq new-str (list ?⿴
1364 (if (setq ret (ideographic-structure-find-chars new-str))
1366 (list (cons 'ideographic-structure new-str))))
1368 (list ?⿱ (nth 1 enc-str) new-str-c)
1369 (setq a-res (ids-find-chars-including-ids new-str))
1374 (list ?⿱ (nth 1 enc-str) new-str-c)
1377 ((and (characterp (nth 2 enc-str))
1378 (eq (char-ucs (nth 2 enc-str)) #x51F5))
1379 (unless conversion-only
1380 (setq f-res (ids-find-chars-including-ids enc-str)))
1381 (setq new-str (list ?⿶
1385 (if (setq ret (ideographic-structure-find-chars new-str))
1387 (list (cons 'ideographic-structure new-str))))
1389 (list ?⿱ (nth 1 enc-str) new-str-c)
1390 (setq a-res (ids-find-chars-including-ids new-str))
1395 (list ?⿱ (nth 1 enc-str) new-str-c)
1398 ((and (characterp (nth 1 enc-str))
1399 (eq (char-feature (nth 1 enc-str) '=>ucs@component)
1401 (unless conversion-only
1402 (setq f-res (ids-find-chars-including-ids enc-str)))
1403 (setq new-str (list ?⿵
1407 (if (setq ret (ideographic-structure-find-chars new-str))
1409 (list (cons 'ideographic-structure new-str))))
1411 (list ?⿱ new-str-c (nth 2 enc-str))
1412 (setq a-res (ids-find-chars-including-ids new-str))
1417 (list ?⿱ new-str-c (nth 2 enc-str))
1421 (unless conversion-only
1422 (setq f-res (ids-find-chars-including-ids enc-str)))
1423 (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
1425 (if (setq ret (ideographic-structure-find-chars new-str))
1427 (list (cons 'ideographic-structure new-str))))
1429 (list ?⿱ (nth 1 enc-str) new-str-c)
1430 (setq a-res (ids-find-chars-including-ids new-str))
1435 (list ?⿱ (nth 1 enc-str) new-str-c)
1439 ((eq (car enc-str) ?⿳)
1441 ((and (characterp (nth 2 enc-str))
1442 (eq (char-ucs (nth 2 enc-str)) #x56D7))
1443 (unless conversion-only
1444 (setq f-res (ids-find-chars-including-ids enc-str)))
1445 (setq new-str (list ?⿴ (nth 2 enc-str) (nth 2 structure)))
1447 (if (setq ret (ideographic-structure-find-chars new-str))
1449 (list (cons 'ideographic-structure new-str))))
1450 (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
1452 (if (setq ret (ideographic-structure-find-chars new-str))
1454 (list (cons 'ideographic-structure new-str))))
1456 (list ?⿱ new-str-c (nth 3 enc-str))
1457 (setq a-res (ids-find-chars-including-ids new-str))
1462 (list ?⿱ new-str-c (nth 3 enc-str))
1465 ((and (characterp (nth 2 enc-str))
1466 (eq (char-ucs (nth 2 enc-str)) #x5196))
1467 (unless conversion-only
1468 (setq f-res (ids-find-chars-including-ids enc-str)))
1469 (setq new-str (list ?⿱ (nth 1 enc-str) (nth 2 enc-str)))
1471 (if (setq ret (ideographic-structure-find-chars new-str))
1473 (list (cons 'ideographic-structure new-str))))
1474 (setq new-str (list ?⿱ new-str-c (nth 2 structure)))
1476 (if (setq ret (ideographic-structure-find-chars new-str))
1478 (list (cons 'ideographic-structure new-str))))
1480 (list ?⿱ new-str-c (nth 3 enc-str))
1481 (setq a-res (ids-find-chars-including-ids new-str))
1486 (list ?⿱ new-str-c (nth 3 enc-str))
1489 ((and (characterp (nth 2 enc-str))
1490 (or (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
1492 (eq (encode-char (nth 2 enc-str) '=>gt-k)
1494 (eq (char-ucs (nth 2 enc-str)) #x2008A)))
1495 (unless conversion-only
1496 (setq f-res (ids-find-chars-including-ids enc-str)))
1497 (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
1499 (if (setq ret (ideographic-structure-find-chars new-str))
1501 (list (cons 'ideographic-structure new-str))))
1502 (setq new-str (list ?⿸ new-str-c (nth 3 enc-str)))
1504 (if (setq ret (ideographic-structure-find-chars new-str))
1506 (list (cons 'ideographic-structure new-str))))
1508 (list ?⿱ (nth 1 enc-str) new-str-c)
1509 (setq a-res (ids-find-chars-including-ids new-str))
1514 (list ?⿱ (nth 1 enc-str) new-str-c)
1518 (unless conversion-only
1519 (setq f-res (ids-find-chars-including-ids enc-str)))
1520 (setq new-str (list ?⿻ (nth 2 enc-str) (nth 2 structure)))
1522 (if (setq ret (ideographic-structure-find-chars new-str))
1524 (list (cons 'ideographic-structure new-str))))
1525 (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
1527 (if (setq ret (ideographic-structure-find-chars new-str))
1529 (list (cons 'ideographic-structure new-str))))
1531 (list ?⿱ new-str-c (nth 3 enc-str))
1532 (setq a-res (ids-find-chars-including-ids new-str))
1537 (list ?⿱ new-str-c (nth 3 enc-str))
1542 ((eq (car structure) ?⿶)
1543 (setq enc (nth 1 structure))
1545 (cond ((characterp enc)
1546 (get-char-attribute enc 'ideographic-structure)
1549 (cdr (assq 'ideographic-structure enc))
1552 ((eq (car enc-str) ?⿱)
1553 (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1555 (eq (car enc2-str) ?⿰))
1556 (unless conversion-only
1557 (setq f-res (ids-find-chars-including-ids enc-str)))
1558 (setq new-str (list ?⿲
1563 (if (setq ret (ideographic-structure-find-chars new-str))
1565 (list (cons 'ideographic-structure new-str))))
1567 (list ?⿱ new-str-c (nth 2 enc-str))
1568 (setq a-res (ids-find-chars-including-ids new-str))
1573 (list ?⿱ new-str-c (nth 2 enc-str))
1577 ((eq (car enc-str) ?⿳)
1578 (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1580 (eq (car enc2-str) ?⿰))
1581 (unless conversion-only
1582 (setq f-res (ids-find-chars-including-ids enc-str)))
1583 (setq new-str (list ?⿲
1588 (if (setq ret (ideographic-structure-find-chars new-str))
1590 (list (cons 'ideographic-structure new-str))))
1592 (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
1593 (setq a-res (ids-find-chars-including-ids new-str))
1598 (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
1602 ((eq (car enc-str) ?⿲)
1603 (unless conversion-only
1604 (setq f-res (ids-find-chars-including-ids enc-str)))
1605 (setq new-str (list ?⿱
1609 (if (setq ret (ideographic-structure-find-chars new-str))
1611 (list (cons 'ideographic-structure new-str))))
1613 (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1614 (setq a-res (ids-find-chars-including-ids new-str))
1619 (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1622 ((eq (car enc-str) ?⿴)
1623 (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1625 (eq (car enc2-str) ?⿰))
1626 (unless conversion-only
1627 (setq f-res (ids-find-chars-including-ids enc-str)))
1628 (setq new-str (list ?⿱
1632 (if (setq ret (ideographic-structure-find-chars new-str))
1634 (list (cons 'ideographic-structure new-str))))
1636 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1637 (setq a-res (ids-find-chars-including-ids new-str))
1642 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1647 ((eq (car structure) ?⿵)
1648 (setq enc (nth 1 structure))
1650 (cond ((characterp enc)
1651 (get-char-attribute enc 'ideographic-structure)
1654 (cdr (assq 'ideographic-structure enc))
1657 ((eq (car enc-str) ?⿱)
1658 (setq enc2-str (ideographic-character-get-structure (nth 2 enc-str)))
1660 (eq (car enc2-str) ?⿰))
1661 (unless conversion-only
1662 (setq f-res (ids-find-chars-including-ids enc-str)))
1663 (setq new-str (list ?⿲
1668 (if (setq ret (ideographic-structure-find-chars new-str))
1670 (list (cons 'ideographic-structure new-str))))
1672 (list ?⿱ (nth 1 enc-str) new-str-c)
1673 (setq a-res (ids-find-chars-including-ids new-str))
1678 (list ?⿱ (nth 1 enc-str) new-str-c)
1682 ((eq (car enc-str) ?⿳)
1683 (setq enc2-str (ideographic-character-get-structure (nth 3 enc-str)))
1685 (eq (car enc2-str) ?⿰))
1686 (unless conversion-only
1687 (setq f-res (ids-find-chars-including-ids enc-str)))
1688 (setq new-str (list ?⿲
1693 (if (setq ret (ideographic-structure-find-chars new-str))
1695 (list (cons 'ideographic-structure new-str))))
1697 (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
1698 (setq a-res (ids-find-chars-including-ids new-str))
1703 (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
1707 ((eq (car enc-str) ?⿲)
1708 (unless conversion-only
1709 (setq f-res (ids-find-chars-including-ids enc-str)))
1710 (setq new-str (list ?⿱
1714 (if (setq ret (ideographic-structure-find-chars new-str))
1716 (list (cons 'ideographic-structure new-str))))
1718 (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1719 (setq a-res (ids-find-chars-including-ids new-str))
1724 (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1727 ((eq (car enc-str) ?⿴)
1728 (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1730 (eq (car enc2-str) ?⿰))
1731 (unless conversion-only
1732 (setq f-res (ids-find-chars-including-ids enc-str)))
1733 (setq new-str (list ?⿱
1737 (if (setq ret (ideographic-structure-find-chars new-str))
1739 (list (cons 'ideographic-structure new-str))))
1741 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1742 (setq a-res (ids-find-chars-including-ids new-str))
1747 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1752 ((eq (car structure) ?⿷)
1753 (setq enc (nth 1 structure))
1755 (cond ((characterp enc)
1756 (get-char-attribute enc 'ideographic-structure)
1759 (cdr (assq 'ideographic-structure enc))
1762 ((eq (car enc-str) ?⿺)
1763 (unless conversion-only
1764 (setq f-res (ids-find-chars-including-ids enc-str)))
1765 (setq new-str (list ?⿱
1769 (if (setq ret (ideographic-structure-find-chars new-str))
1771 (list (cons 'ideographic-structure new-str))))
1773 (list ?⿺ (nth 1 enc-str) new-str-c)
1774 (setq a-res (ids-find-chars-including-ids new-str))
1779 (list ?⿺ (nth 1 enc-str) new-str-c)
1783 ((eq (car structure) ?⿻)
1784 (setq enc (nth 1 structure))
1786 (cond ((characterp enc)
1787 (get-char-attribute enc 'ideographic-structure)
1790 (cdr (assq 'ideographic-structure enc))
1793 ((eq (car enc-str) ?⿱)
1794 (unless conversion-only
1795 (setq f-res (ids-find-chars-including-ids enc-str)))
1797 (list ?⿳ (nth 1 enc-str) (nth 2 structure) (nth 2 enc-str))
1817 ;;; ids-find.el ends here