-;;; ids-find.el --- search utility based on Ideographic-structures
+;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*-
-;; Copyright (C) 2002,2003,2005 MORIOKA Tomohiko
+;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021, 2022, 2023
+;; MORIOKA Tomohiko
;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode
-;; This file is a part of Tomoyo-Tools.
+;; This file is a part of CHISE-IDS.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;;; Code:
(defun ids-index-store-char (product component)
- (let ((ret (get-char-attribute ; char-feature
- component 'ideographic-products)))
+ (let ((ret (get-char-attribute component 'ideographic-products)))
(unless (memq product ret)
(put-char-attribute component 'ideographic-products
- (cons product ret)))
- ;; (when ret (setq ret (get-char-attribute ; char-feature
- ;; component 'ideographic-structure))
- ;; (ids-index-store-structure product ret))
+ (cons product ret))
+ (when (setq ret (char-feature component 'ideographic-structure))
+ (ids-index-store-structure product ret))
+ (when (setq ret (char-feature component 'ideographic-structure@apparent))
+ (ids-index-store-structure product ret))
+ (when (setq ret (char-feature component 'ideographic-structure@apparent/leftmost))
+ (ids-index-store-structure product ret))
+ (when (setq ret (char-feature component 'ideographic-structure@apparent/rightmost))
+ (ids-index-store-structure product ret))
+ )
))
(defun ids-index-store-structure (product structure)
(ids-index-store-char product cell))
((setq ret (assq 'ideographic-structure cell))
(ids-index-store-structure product (cdr ret)))
- ;; ((setq ret (find-char cell))
- ;; (ids-index-store-char product ret))
+ ((setq ret (assq 'ideographic-structure@apparent cell))
+ (ids-index-store-structure product (cdr ret)))
+ ((setq ret (assq 'ideographic-structure@apparent/leftmost cell))
+ (ids-index-store-structure product (cdr ret)))
+ ((setq ret (assq 'ideographic-structure@apparent/rightmost cell))
+ (ids-index-store-structure product (cdr ret)))
+ ((setq ret (find-char cell))
+ (ids-index-store-char product ret))
))))
;;;###autoload
-(defun ids-update-index ()
+(defun ids-update-index (&optional in-memory)
(interactive)
(map-char-attribute
(lambda (c v)
(ids-index-store-structure c v)
nil)
'ideographic-structure)
- (save-char-attribute-table 'ideographic-products))
+ (map-char-attribute
+ (lambda (c v)
+ (ids-index-store-structure c v)
+ nil)
+ 'ideographic-structure@apparent)
+ (map-char-attribute
+ (lambda (c v)
+ (ids-index-store-structure c v)
+ nil)
+ 'ideographic-structure@apparent/leftmost)
+ (map-char-attribute
+ (lambda (c v)
+ (ids-index-store-structure c v)
+ nil)
+ 'ideographic-structure@apparent/rightmost)
+ (let (products ucs)
+ (map-char-attribute
+ (lambda (c v)
+ (setq products (get-char-attribute c 'ideographic-products))
+ (dolist (comp (delq c (char-ucs-chars c)))
+ (dolist (p_c (get-char-attribute comp 'ideographic-products))
+ (unless (encode-char p_c '=ucs)
+ (if (setq ucs (char-ucs p_c))
+ (setq p_c (decode-char '=ucs ucs))))
+ (setq products (adjoin p_c products))))
+ (put-char-attribute c 'ideographic-products products)
+ nil)
+ '=>iwds-1)
+ (map-char-attribute
+ (lambda (c v)
+ (setq products (get-char-attribute c 'ideographic-products))
+ (dolist (comp (delq c (char-ucs-chars c)))
+ (dolist (p_c (get-char-attribute comp 'ideographic-products))
+ (unless (encode-char p_c '=ucs)
+ (if (setq ucs (char-ucs p_c))
+ (setq p_c (decode-char '=ucs ucs))))
+ (setq products (adjoin p_c products))))
+ (put-char-attribute c 'ideographic-products products)
+ nil)
+ '=>ucs@iwds-1)
+ (map-char-attribute
+ (lambda (c v)
+ (setq products (get-char-attribute c 'ideographic-products))
+ (dolist (comp (delq c (char-ucs-chars c)))
+ (put-char-attribute
+ comp 'ideographic-products
+ (union products
+ (get-char-attribute comp 'ideographic-products))))
+ )
+ '=>iwds-1)
+ (map-char-attribute
+ (lambda (c v)
+ (setq products (get-char-attribute c 'ideographic-products))
+ (dolist (comp (delq c (char-ucs-chars c)))
+ (put-char-attribute
+ comp 'ideographic-products
+ (union products
+ (get-char-attribute comp 'ideographic-products))))
+ )
+ '=>ucs@iwds-1)
+ )
+ (unless in-memory
+ (save-char-attribute-table 'ideographic-products)))
(mount-char-attribute-table 'ideographic-products)
(when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
(symbol-name feature))
(push feature dest)))
- (cons '<-ideographic-component-forms
- dest)))
+ (list* '<-mistakable '->mistakable
+ '<-formed '->formed
+ '<-same '->same
+ '<-original '->original
+ '<-ancient '->ancient
+ dest)))
(defun to-component-features ()
(let (dest)
(when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
(symbol-name feature))
(push feature dest)))
- (cons '->ideographic-component-forms
- dest)))
+ dest))
;;;###autoload
(defun char-component-variants (char)
(let ((dest (list char))
ret uchr)
+ (dolist (feature (to-component-features))
+ (if (setq ret (get-char-attribute char feature))
+ (dolist (c ret)
+ (setq dest (union dest (char-component-variants c))))))
(cond
- ((setq ret (some (lambda (feature)
- (get-char-attribute char feature))
- (to-component-features)))
- (dolist (c ret)
- (setq dest (union dest (char-component-variants c))))
- )
+ ;; ((setq ret (some (lambda (feature)
+ ;; (get-char-attribute char feature))
+ ;; (to-component-features)))
+ ;; (dolist (c ret)
+ ;; (setq dest (union dest (char-component-variants c))))
+ ;; )
((setq ret (get-char-attribute char '->ucs-unified))
(setq dest (cons char ret))
(dolist (c dest)
(setq dest (union dest
(some (lambda (feature)
- (get-char-attribute char feature))
+ (get-char-attribute c feature))
(of-component-features))
)))
)
(dolist (c dest)
(setq dest (union dest
(some (lambda (feature)
- (get-char-attribute char feature))
+ (get-char-attribute c feature))
(of-component-features))
)))
)
;;;###autoload
(defun ideographic-products-find (&rest components)
(if (stringp (car components))
- (setq components (car components)))
- (let ((len (length components))
- (i 1)
- dest products)
- (dolist (variant (char-component-variants (elt components 0)))
- (dolist (product (get-char-attribute variant 'ideographic-products))
- (unless (memq product products)
- (setq products (cons product products)))))
+ (setq components (string-to-char-list (car components))))
+ (let (dest products)
+ (dolist (variant (char-component-variants (car components)))
+ (setq products
+ (union products
+ (get-char-attribute variant 'ideographic-products))))
(setq dest products)
- (while (and
- (< i len)
- (progn
- (setq products nil)
- (dolist (variant (char-component-variants (elt components i)))
- (dolist (product (get-char-attribute
- variant 'ideographic-products))
- (unless (memq product products)
- (when (memq product dest)
- (setq products (cons product products))))))
- (setq dest products)))
- (setq i (1+ i)))
- products))
+ (while (and dest
+ (setq components (cdr components)))
+ (setq products nil)
+ (dolist (variant (char-component-variants (car components)))
+ (setq products
+ (union products
+ (get-char-attribute variant 'ideographic-products))))
+ (setq dest (intersection dest products)))
+ dest))
+
+(defun ideograph-find-products-with-variants (components &optional ignored-chars)
+ (if (stringp components)
+ (setq components (string-to-char-list components)))
+ (let (dest products)
+ (dolist (variant (char-component-variants (car components)))
+ (setq products
+ (union products
+ (set-difference
+ (get-char-attribute variant 'ideographic-products)
+ ignored-chars))))
+ (setq dest products)
+ (while (and dest
+ (setq components (cdr components)))
+ (setq products nil)
+ (dolist (variant (char-component-variants (car components)))
+ (setq products
+ (union products
+ (set-difference
+ (get-char-attribute variant 'ideographic-products)
+ ignored-chars))))
+ (setq dest (intersection dest products)))
+ dest))
+
+(defun ideograph-find-products (components &optional ignored-chars)
+ (if (stringp components)
+ (setq components (string-to-char-list components)))
+ (let (dest products)
+ ;; (dolist (variant (char-component-variants (car components)))
+ ;; (setq products
+ ;; (union products
+ ;; (get-char-attribute variant 'ideographic-products))))
+ ;; (setq dest products)
+ (setq dest (get-char-attribute (car components) 'ideographic-products))
+ (while (and dest
+ (setq components (cdr components)))
+ ;; (setq products nil)
+ ;; (dolist (variant (char-component-variants (car components)))
+ ;; (setq products
+ ;; (union products
+ ;; (get-char-attribute variant 'ideographic-products))))
+ (setq products (get-char-attribute (car components) 'ideographic-products))
+ (setq dest (intersection dest products)))
+ dest))
(defun ideographic-structure-char= (c1 c2)
(m2 (char-ucs c2)))
(or (and m1 m2
(eq m1 m2))
- (some (lambda (feature)
- (some (lambda (b2)
- (unless (characterp b2)
- (setq b2 (find-char b2)))
- (and b2
- (ideographic-structure-char= c1 b2)))
- (char-feature c2 feature)
- ;; (get-char-attribute
- ;; c2 '<-ideographic-component-forms)
- ))
- (of-component-features))
- (progn
- (setq m1 (car (get-char-attribute c1 '<-radical))
- m2 (car (get-char-attribute c2 '<-radical)))
- (unless (characterp m1)
- (setq m1 (find-char m1)))
- (unless (characterp m2)
- (setq m2 (find-char m2)))
- (when (or m1 m2)
- (ideographic-structure-char= m1 m2))))))))
+ (memq c1 (char-component-variants c2)))))))
(defun ideographic-structure-member-compare-components (component s-component)
(let (ret)
(or (ideographic-structure-to-ids v)
v)))
-(defun ids-insert-chars-including-components (components level)
- (let (is dis i)
- (dolist (c (ideographic-products-find components))
- (setq is (char-feature c 'ideographic-structure))
- ;; to avoid problems caused by wrong indexes
- (when (every (lambda (cc)
- (ideographic-structure-member cc is))
- components)
- ;;(ids-insert-chars-including-components (char-to-string c) (1+ level))
+(defun ids-insert-chars-including-components* (components
+ &optional level ignored-chars)
+ (unless level
+ (setq level 0))
+ (let (is i as bs)
+ (dolist (c (sort (copy-list (ideograph-find-products components
+ ignored-chars))
+ (lambda (a b)
+ (if (setq as (char-total-strokes a))
+ (if (setq bs (char-total-strokes b))
+ (if (= as bs)
+ (ideograph-char< a b)
+ (< as bs))
+ t)
+ (ideograph-char< a b)))))
+ (unless (memq c ignored-chars)
+ (setq is (char-feature c 'ideographic-structure))
(setq i 0)
(while (< i level)
(insert "\t")
(setq i (1+ i)))
(insert (ids-find-format-line c is))
- ;;(forward-line -1)
- (ids-insert-chars-including-components
- (char-to-string c) (1+ level))
- )
- )))
+ (setq ignored-chars
+ (ids-insert-chars-including-components*
+ (char-to-string c) (1+ level)
+ (cons c ignored-chars))))
+ )
+ )
+ ignored-chars)
+
+(defun ids-insert-chars-including-components (components
+ &optional level ignored-chars)
+ (unless level
+ (setq level 0))
+ (setq ignored-chars
+ (nreverse
+ (ids-insert-chars-including-components* components
+ level ignored-chars)))
+ (let (is i as bs)
+ (dolist (c ignored-chars)
+ (dolist (vc (char-component-variants c))
+ (unless (memq vc ignored-chars)
+ (when (setq is (get-char-attribute vc 'ideographic-structure))
+ (setq i 0)
+ (while (< i level)
+ (insert "\t")
+ (setq i (1+ i)))
+ (insert (ids-find-format-line vc is))
+ (setq ignored-chars
+ (ids-insert-chars-including-components*
+ (char-to-string vc) (1+ level)
+ (cons vc ignored-chars)))))))
+ (dolist (c (sort (copy-list (ideograph-find-products-with-variants
+ components ignored-chars))
+ (lambda (a b)
+ (if (setq as (char-total-strokes a))
+ (if (setq bs (char-total-strokes b))
+ (if (= as bs)
+ (ideograph-char< a b)
+ (< as bs))
+ t)
+ (ideograph-char< a b)))))
+ (unless (memq c ignored-chars)
+ (setq is (get-char-attribute c 'ideographic-structure))
+ (setq i 0)
+ (while (< i level)
+ (insert "\t")
+ (setq i (1+ i)))
+ (insert (ids-find-format-line c is))
+ (setq ignored-chars
+ (ids-insert-chars-including-components*
+ (char-to-string c) (1+ level)
+ (cons c ignored-chars))))
+ )
+ )
+ ignored-chars)
;;;###autoload
(defun ids-find-chars-including-components (components)
(with-current-buffer (get-buffer-create ids-find-result-buffer)
(setq buffer-read-only nil)
(erase-buffer)
- (ids-insert-chars-including-components components 0)
- ;; (let (is dis)
- ;; (dolist (c (ideographic-products-find components))
- ;; (setq is (char-feature c 'ideographic-structure))
- ;; ;; to avoid problems caused by wrong indexes
- ;; ;; (when (every (lambda (cc)
- ;; ;; (ideographic-structure-member cc is))
- ;; ;; components)
- ;; (dolist (dc (ideographic-products-find (char-to-string c)))
- ;; (setq dis (char-feature dc 'ideographic-structure))
- ;; ;; ;; to avoid problems caused by wrong indexes
- ;; ;; (when (every (lambda (dcc)
- ;; ;; (ideographic-structure-member dcc is))
- ;; ;; components)
- ;; (insert "\t")
- ;; (insert (ids-find-format-line dc dis))
- ;; (forward-line -1)
- ;; ;; )
- ;; )
- ;; (insert (ids-find-format-line c is))
- ;; (forward-line -1)
- ;; ;; )
- ;; )
- ;; )
+ (ids-insert-chars-including-components components 0 nil)
+ ;; (let ((ignored-chars
+ ;; (nreverse
+ ;; (ids-insert-chars-including-components components 0 nil
+ ;; #'ideograph-find-products)))
+ ;; rest)
+ ;; (setq rest ignored-chars)
+ ;; ;; (dolist (c rest)
+ ;; ;; (setq ignored-chars
+ ;; ;; (union ignored-chars
+ ;; ;; (ids-insert-chars-including-components
+ ;; ;; (list c) 0 ignored-chars
+ ;; ;; #'ideograph-find-products-with-variants))))
+ ;; (ids-insert-chars-including-components components 0 ignored-chars
+ ;; #'ideograph-find-products-with-variants))
(goto-char (point-min)))
(view-buffer ids-find-result-buffer))
-;; (defun ids-find-chars-including-components (components)
-;; "Search Ideographs whose structures have COMPONENTS."
-;; (interactive "sComponents : ")
-;; (with-current-buffer (get-buffer-create ids-find-result-buffer)
-;; (setq buffer-read-only nil)
-;; (erase-buffer)
-;; (map-char-attribute
-;; (lambda (c v)
-;; (when (every (lambda (p)
-;; (ideographic-structure-member p v))
-;; components)
-;; (insert (ids-find-format-line c v)))
-;; nil)
-;; 'ideographic-structure)
-;; (goto-char (point-min)))
-;; (view-buffer ids-find-result-buffer))
;;;###autoload
(define-obsolete-function-alias 'ideographic-structure-search-chars
(with-current-buffer (get-buffer-create ids-find-result-buffer)
(setq buffer-read-only nil)
(erase-buffer)
- (let (ucs jis)
- (map-char-attribute
- (lambda (c v)
- (when (ideographic-structure-repertoire-p v components)
- (insert (ids-find-format-line c v))))
- 'ideographic-structure))
+ (map-char-attribute
+ (lambda (c v)
+ (when (ideographic-structure-repertoire-p v components)
+ (insert (ids-find-format-line c v))))
+ 'ideographic-structure)
(goto-char (point-min)))
(view-buffer ids-find-result-buffer))
+(defun ideographic-structure-merge-components-alist (ca1 ca2)
+ (let ((dest-alist ca1)
+ ret)
+ (dolist (cell ca2)
+ (if (setq ret (assq (car cell) dest-alist))
+ (setcdr ret (+ (cdr ret)(cdr cell)))
+ (setq dest-alist (cons cell dest-alist))))
+ dest-alist))
+
+(defun ideographic-structure-to-components-alist (structure)
+ (apply #'ideographic-structure-to-components-alist* structure))
+
+(defun ideographic-structure-to-components-alist* (operator component1 component2
+ &optional component3
+ &rest opts)
+ (let (dest-alist ret)
+ (setq dest-alist
+ (cond ((characterp component1)
+ (unless (encode-char component1 'ascii)
+ (list (cons component1 1)))
+ )
+ ((setq ret (assq 'ideographic-structure component1))
+ (ideographic-structure-to-components-alist (cdr ret))
+ )
+ ((setq ret (find-char component1))
+ (list (cons ret 1))
+ )))
+ (setq dest-alist
+ (ideographic-structure-merge-components-alist
+ dest-alist
+ (cond ((characterp component2)
+ (unless (encode-char component2 'ascii)
+ (list (cons component2 1)))
+ )
+ ((setq ret (assq 'ideographic-structure component2))
+ (ideographic-structure-to-components-alist (cdr ret))
+ )
+ ((setq ret (find-char component2))
+ (list (cons ret 1))
+ ))))
+ (if (memq operator '(?\u2FF2 ?\u2FF3))
+ (ideographic-structure-merge-components-alist
+ dest-alist
+ (cond ((characterp component3)
+ (unless (encode-char component3 'ascii)
+ (list (cons component3 1)))
+ )
+ ((setq ret (assq 'ideographic-structure component3))
+ (ideographic-structure-to-components-alist (cdr ret))
+ )
+ ((setq ret (find-char component3))
+ (list (cons ret 1))
+ )))
+ dest-alist)))
+
+(defun ids-find-merge-variables (ve1 ve2)
+ (cond ((eq ve1 t)
+ ve2)
+ ((eq ve2 t)
+ ve1)
+ (t
+ (let ((dest-alist ve1)
+ (rest ve2)
+ cell ret)
+ (while (and rest
+ (setq cell (car rest))
+ (if (setq ret (assq (car cell) ve1))
+ (eq (cdr ret)(cdr cell))
+ (setq dest-alist (cons cell dest-alist))))
+ (setq rest (cdr rest)))
+ (if rest
+ nil
+ dest-alist)))))
+
+;;;###autoload
+(defun ideographic-structure-equal (structure1 structure2)
+ (let (dest-alist ret)
+ (and (setq dest-alist (ideographic-structure-character=
+ (car structure1)(car structure2)))
+ (setq ret (ideographic-structure-character=
+ (nth 1 structure1)(nth 1 structure2)))
+ (setq dest-alist (ids-find-merge-variables dest-alist ret))
+ (setq ret (ideographic-structure-character=
+ (nth 2 structure1)(nth 2 structure2)))
+ (setq dest-alist (ids-find-merge-variables dest-alist ret))
+ (if (memq (car structure1) '(?\u2FF2 ?\u2FF3))
+ (and (setq ret (ideographic-structure-character=
+ (nth 3 structure1)(nth 3 structure2)))
+ (setq dest-alist (ids-find-merge-variables dest-alist ret)))
+ dest-alist))))
+
+;;;###autoload
+(defun ideographic-structure-character= (c1 c2)
+ (let (ret ret2)
+ (cond ((characterp c1)
+ (cond ((encode-char c1 'ascii)
+ (list (cons c1 c2))
+ )
+ ((characterp c2)
+ (if (encode-char c2 'ascii)
+ (list (cons c2 c1))
+ (eq c1 c2))
+ )
+ ((setq ret2 (find-char c2))
+ (eq c1 ret2)
+ )
+ ((setq ret2 (assq 'ideographic-structure c2))
+ (and (setq ret (get-char-attribute c1 'ideographic-structure))
+ (ideographic-structure-equal ret (cdr ret2)))
+ ))
+ )
+ ((setq ret (assq 'ideographic-structure c1))
+ (cond ((characterp c2)
+ (if (encode-char c2 'ascii)
+ (list (cons c2 c1))
+ (and (setq ret2 (get-char-attribute c2 'ideographic-structure))
+ (ideographic-structure-equal (cdr ret) ret2)))
+ )
+ ((setq ret2 (find-char c2))
+ (and (setq ret2 (get-char-attribute ret2 'ideographic-structure))
+ (ideographic-structure-equal (cdr ret) ret2))
+ )
+ ((setq ret2 (assq 'ideographic-structure c2))
+ (ideographic-structure-equal (cdr ret)(cdr ret2))
+ ))
+ )
+ ((setq ret (find-char c1))
+ (cond ((characterp c2)
+ (if (encode-char c2 'ascii)
+ (list (cons c2 c1))
+ (eq ret c2))
+ )
+ ((setq ret2 (find-char c2))
+ (eq ret ret2)
+ )
+ ((setq ret2 (assq 'ideographic-structure c2))
+ (and (setq ret (get-char-attribute ret 'ideographic-structure))
+ (ideographic-structure-equal ret (cdr ret2))
+ )))))))
+
+;;;###autoload
+(defun ideographic-structure-find-chars (structure)
+ (let ((comp-alist (ideographic-structure-to-components-alist structure))
+ ret pl str)
+ (dolist (pc (caar
+ (sort (mapcar (lambda (cell)
+ (if (setq ret (get-char-attribute
+ (car cell) 'ideographic-products))
+ (cons ret (length ret))
+ (cons nil 0)))
+ comp-alist)
+ (lambda (a b)
+ (< (cdr a)(cdr b))))))
+ (when (or (and (setq str
+ (get-char-attribute pc 'ideographic-structure))
+ (ideographic-structure-equal str structure))
+ (and (setq str
+ (get-char-attribute pc 'ideographic-structure@apparent))
+ (ideographic-structure-equal str structure))
+ (and (setq str
+ (get-char-attribute pc 'ideographic-structure@apparent/leftmost))
+ (ideographic-structure-equal str structure))
+ (and (setq str
+ (get-char-attribute pc 'ideographic-structure@apparent/rightmost))
+ (ideographic-structure-equal str structure)))
+ (setq pl (cons pc pl))
+ ))
+ pl))
+
+;;;###autoload
+(defun ideographic-char-count-components (char component)
+ (let ((dest 0)
+ structure)
+ (cond ((eq char component)
+ 1)
+ ((setq structure (get-char-attribute char 'ideographic-structure))
+ (dolist (cell (ideographic-structure-to-components-alist structure))
+ (setq dest
+ (+ dest
+ (if (eq (car cell) char)
+ (cdr cell)
+ (* (ideographic-char-count-components (car cell) component)
+ (cdr cell))))))
+ dest)
+ (t
+ 0))))
+
+
+;;;###autoload
+(defun ideographic-character-get-structure (character)
+ "Return ideographic-structure of CHARACTER.
+CHARACTER can be a character or char-spec."
+ (mapcar (lambda (cell)
+ (or (and (listp cell)
+ (find-char cell))
+ cell))
+ (let (ret)
+ (cond ((characterp character)
+ (get-char-attribute character 'ideographic-structure)
+ )
+ ((setq ret (assq 'ideographic-structure character))
+ (cdr ret)
+ )
+ ((setq ret (find-char character))
+ (get-char-attribute ret 'ideographic-structure)
+ )))))
+
+;;;###autoload
+(defun ideographic-char-match-component (char component)
+ "Return non-nil if character CHAR has COMPONENT in ideographic-structure.
+COMPONENT can be a character or char-spec."
+ (or (ideographic-structure-character= char component)
+ (let ((str (ideographic-character-get-structure char)))
+ (and str
+ (or (ideographic-char-match-component (nth 1 str) component)
+ (ideographic-char-match-component (nth 2 str) component)
+ (if (memq (car str) '(?\u2FF2 ?\u2FF3))
+ (ideographic-char-match-component (nth 3 str) component)))))))
+
+(defun ideographic-structure-char< (a b)
+ (let ((sa (get-char-attribute a 'ideographic-structure))
+ (sb (get-char-attribute b 'ideographic-structure))
+ tsa tsb)
+ (cond (sa
+ (cond (sb
+ (setq tsa (char-total-strokes a)
+ tsb (char-total-strokes b))
+ (if tsa
+ (if tsb
+ (or (< tsa tsb)
+ (and (= tsa tsb)
+ (ideograph-char< a b)))
+ t)
+ (if tsb
+ nil
+ (ideograph-char< a b))))
+ (t
+ nil))
+ )
+ (t
+ (cond (sb
+ t)
+ (t
+ (setq tsa (char-total-strokes a)
+ tsb (char-total-strokes b))
+ (if tsa
+ (if tsb
+ (or (< tsa tsb)
+ (and (= tsa tsb)
+ (ideograph-char< a b)))
+ t)
+ (if tsb
+ nil
+ (ideograph-char< a b)))
+ ))
+ ))
+ ))
+
+(defun ideo-comp-tree-adjoin (tree char)
+ (let ((rest tree)
+ included ; other
+ dest cell finished)
+ (while (and (not finished)
+ rest)
+ (setq cell (pop rest))
+ (cond ((ideographic-structure-character= char (car cell))
+ (setq finished t
+ dest tree
+ rest nil)
+ )
+ ((ideographic-char-match-component char (car cell))
+ (setq dest
+ (cons (cons (car cell)
+ (ideo-comp-tree-adjoin (cdr cell) char))
+ dest))
+ (setq finished t)
+ )
+ ((ideographic-char-match-component (car cell) char)
+ (setq included (cons cell included))
+ )
+ ;; (included
+ ;; (setq other (cons cell other))
+ ;; )
+ (t
+ (setq dest (cons cell dest))
+ )))
+ (cond (finished
+ (nconc dest rest)
+ )
+ (included
+ (cons (cons char included)
+ (nconc dest rest))
+ )
+ (t
+ (cons (list char) tree)
+ ))))
+
+(defun ideographic-chars-to-is-a-tree (chars)
+ (let (tree)
+ (dolist (char (sort (copy-list chars) #'ideographic-structure-char<))
+ (setq tree (ideo-comp-tree-adjoin tree char)))
+ tree))
+
+(defun ids-find-chars-including-ids (structure)
+ (let (comp-alist comp-spec ret str rest)
+ (cond
+ ((characterp structure)
+ (setq rest (copy-list (get-char-attribute structure 'ideographic-products)))
+ )
+ ((setq ret (ideographic-structure-find-chars structure))
+ (dolist (pc ret)
+ (setq rest
+ (union
+ rest
+ (copy-list (get-char-attribute pc 'ideographic-products)))))
+ )
+ (t
+ (setq comp-alist (ideographic-structure-to-components-alist structure)
+ comp-spec (list (cons 'ideographic-structure structure)))
+ (dolist (pc (caar
+ (sort (mapcar (lambda (cell)
+ (if (setq ret (get-char-attribute
+ (car cell) 'ideographic-products))
+ (cons ret (length ret))
+ (cons nil 0)))
+ comp-alist)
+ (lambda (a b)
+ (< (cdr a)(cdr b))))))
+ (when (and (every (lambda (cell)
+ (>= (ideographic-char-count-components pc (car cell))
+ (cdr cell)))
+ comp-alist)
+ (or (ideographic-char-match-component pc comp-spec)
+ (and (setq str (get-char-attribute pc 'ideographic-structure))
+ (ideographic-char-match-component
+ (list
+ (cons
+ 'ideographic-structure
+ (functional-ideographic-structure-to-apparent-structure
+ str)))
+ comp-spec))))
+ (push pc rest)))
+ ))
+ (ideographic-chars-to-is-a-tree rest)))
+
+(defun functional-ideographic-structure-to-apparent-structure (structure)
+ (ideographic-structure-compare-functional-and-apparent
+ structure nil 'conversion-only))
+
+;;;###autoload
+(defun ideographic-structure-compact (structure)
+ (let ((rest structure)
+ cell
+ ret dest sub)
+ (while rest
+ (setq cell (pop rest))
+ (if (and (consp cell)
+ (setq ret (find-char cell)))
+ (setq cell ret))
+ (cond
+ ((and (consp cell)
+ (cond ((setq ret (assq 'ideographic-structure cell))
+ (setq sub (cdr ret))
+ )
+ ((atom (car cell))
+ (setq sub cell)
+ )))
+ (setq cell
+ (cond ((setq ret (ideographic-structure-find-chars sub))
+ (car ret)
+ )
+ ((setq ret (ideographic-structure-compact sub))
+ (list (cons 'ideographic-structure ret))
+ )
+ (t
+ (list (cons 'ideographic-structure sub))))
+ )
+ ))
+ (setq dest (cons cell dest)))
+ (nreverse dest)))
+
+(defun ideographic-structure-compare-functional-and-apparent (structure
+ &optional char
+ conversion-only)
+ (let (enc enc-str enc2-str enc3-str new-str new-str-c
+ f-res a-res ret code)
+ (cond
+ ((eq (car structure) ?⿸)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿰)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿰ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿰ (nth 1 enc-str) new-str-c)
+ 111))
+ )
+ ((and (eq (car enc-str) ?⿲)
+ (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
+ (eq (nth 2 enc-str) ?丨))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 3 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
+ 112))
+ )
+ ((eq (car enc-str) ?⿱)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str
+ (list
+ (cond
+ ((characterp (nth 2 enc-str))
+ (if (or (memq (encode-char (nth 2 enc-str) '=>ucs@component)
+ '(#x20087 #x5382 #x4E06))
+ (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
+ #x4E06)
+ (eq (encode-char (nth 2 enc-str) '=ucs-itaiji-001)
+ #x2E282)
+ (eq (encode-char (nth 2 enc-str) '=big5-cdp)
+ #x89CE)
+ (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
+ #x88E2)
+ (eq (encode-char (nth 2 enc-str) '=big5-cdp)
+ #x88AD)
+ (eq (or (encode-char (nth 2 enc-str) '=>big5-cdp)
+ (encode-char (nth 2 enc-str) '=big5-cdp-itaiji-001))
+ #x8766)
+ (eq (car (get-char-attribute (nth 2 enc-str)
+ 'ideographic-structure))
+ ?⿸))
+ ?⿸
+ ?⿰))
+ ((eq (car (cdr (assq 'ideographic-structure (nth 2 enc-str))))
+ ?⿸)
+ ?⿸)
+ (t
+ ?⿰))
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (if (eq (car new-str) ?⿸)
+ 121
+ 122)))
+ )
+ ((eq (car enc-str) ?⿸)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list (cond
+ ((characterp (nth 2 enc-str))
+ (if (memq (char-ucs (nth 2 enc-str))
+ '(#x5F73))
+ ?⿰
+ ?⿱)
+ )
+ (t
+ ?⿱))
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿸ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿸ (nth 1 enc-str) new-str-c)
+ (if (eq (car new-str) ?⿰)
+ 131
+ 132)))
+ )))
+ )
+ ((eq (car structure) ?⿹)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿰)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 1 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿰ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿰ new-str-c (nth 2 enc-str))
+ 210))
+ )
+ ((eq (car enc-str) ?⿱)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿰
+ (nth 2 structure)
+ (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ 220))
+ )
+ ))
+ )
+ ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿺)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 structure)
+ (nth 1 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿺ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿺ new-str-c (nth 2 enc-str))
+ 310))
+ )
+ ((eq (car enc-str) ?⿱)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿰
+ (nth 2 structure)
+ (nth 1 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ 320))
+ )
+ ((eq (car enc-str) ?⿰)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 structure)
+ (nth 1 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿰ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿰ new-str-c (nth 2 enc-str))
+ 330))
+ ))
+ )
+ )
+ ((eq (car structure) ?⿴)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿱)
+ (cond
+ ((and (characterp (nth 2 enc-str))
+ (or (memq (char-ucs (nth 2 enc-str)) '(#x56D7 #x5F51 #x897F))
+ (eq (char-feature (nth 2 enc-str) '=>big5-cdp)
+ #x87A5)))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿴
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ 411))
+ )
+ ((and (characterp (nth 2 enc-str))
+ (eq (char-ucs (nth 2 enc-str)) #x51F5))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿶
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ 412))
+ )
+ ((and (characterp (nth 1 enc-str))
+ (eq (char-feature (nth 1 enc-str) '=>ucs@component)
+ #x300E6))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿵
+ (nth 1 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ 413))
+ )
+ (t
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ 414))
+ ))
+ )
+ ((eq (car enc-str) ?⿳)
+ (cond
+ ((and (characterp (nth 2 enc-str))
+ (eq (char-ucs (nth 2 enc-str)) #x56D7))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿴ (nth 2 enc-str) (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 3 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 3 enc-str))
+ 415))
+ )
+ ((and (characterp (nth 2 enc-str))
+ (eq (char-ucs (nth 2 enc-str)) #x5196))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱ (nth 1 enc-str) (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (setq new-str (list ?⿱ new-str-c (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 3 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 3 enc-str))
+ 416))
+ )
+ ((and (characterp (nth 2 enc-str))
+ (or (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
+ #x89A6)
+ (eq (encode-char (nth 2 enc-str) '=>gt-k)
+ 146)
+ (eq (char-ucs (nth 2 enc-str)) #x2008A)))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (setq new-str (list ?⿸ new-str-c (nth 3 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ 417))
+ )
+ (t
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿻ (nth 2 enc-str) (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 3 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 3 enc-str))
+ 419))
+ ))
+ )
+ ((eq (car enc-str) ?⿰)
+ (cond
+ ((equal (nth 1 enc-str)(nth 2 enc-str))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿲
+ (nth 1 enc-str)
+ (nth 2 structure)
+ (nth 2 enc-str)))
+ (setq new-str-c
+ (list (cons 'ideographic-structure new-str)))
+ (if conversion-only
+ new-str
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ new-str
+ 421))
+ )
+ (t
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿰
+ (nth 2 structure)
+ (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿰ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿰ (nth 1 enc-str) new-str-c)
+ 422))
+ ))
+ ))
+ )
+ )
+ ((eq (car structure) ?⿶)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿱)
+ (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+ (when (and enc2-str
+ (eq (car enc2-str) ?⿰))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿲
+ (nth 1 enc2-str)
+ (nth 2 structure)
+ (nth 2 enc2-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ 511))
+ )
+ )
+ ((eq (car enc-str) ?⿳)
+ (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+ (when (and enc2-str
+ (eq (car enc2-str) ?⿰))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿲
+ (nth 1 enc2-str)
+ (nth 2 structure)
+ (nth 2 enc2-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
+ 512))
+ )
+ )
+ ((eq (car enc-str) ?⿲)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 structure)
+ (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
+ 520))
+ )
+ ((eq (car enc-str) ?⿴)
+ (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+ (when (and enc2-str
+ (eq (car enc2-str) ?⿰))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 structure)
+ (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
+ 530))
+ )
+ )))
+ )
+ ((eq (car structure) ?⿵)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿱)
+ (cond
+ ((and (characterp (nth 2 enc-str))
+ (memq (char-ucs (nth 2 enc-str))
+ '(#x9580 #x9B25)))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿵
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ 601))
+ )
+ ((and (setq enc2-str (ideographic-character-get-structure (nth 2 enc-str)))
+ (cond
+ ((eq (car enc2-str) ?⿰)
+ (setq code 611)
+ )
+ ((eq (car enc2-str) ?⿲)
+ (setq code 614)
+ )
+ ((and (eq (car enc2-str) ?⿱)
+ (setq enc3-str
+ (ideographic-character-get-structure (nth 2 enc2-str)))
+ (eq (car enc3-str) ?⿰))
+ (setq code 613)
+ )))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str
+ (cond ((eq code 611)
+ (list ?⿲
+ (nth 1 enc2-str)
+ (nth 2 structure)
+ (nth 2 enc2-str))
+ )
+ ((eq code 613)
+ (list ?⿲
+ (nth 1 enc3-str)
+ (nth 2 structure)
+ (nth 2 enc3-str))
+ )
+ ((eq code 614)
+ (list ?⿲
+ (nth 1 enc2-str)
+ (list (list 'ideographic-structure
+ ?⿱
+ (nth 2 enc2-str)
+ (nth 2 structure)))
+ (nth 3 enc2-str))
+ )))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure
+ (ideographic-structure-compact new-str)))))
+ (if conversion-only
+ (cond ((or (eq code 611)
+ (eq code 614))
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ )
+ ((eq code 613)
+ (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c)
+ ))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (cond ((or (eq code 611)
+ (eq code 614))
+ (list ?⿱ (nth 1 enc-str) new-str-c)
+ )
+ ((eq code 613)
+ (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c)
+ ))
+ code))
+ ))
+ )
+ ((eq (car enc-str) ?⿳)
+ (setq enc2-str (ideographic-character-get-structure (nth 3 enc-str)))
+ (when (and enc2-str
+ (eq (car enc2-str) ?⿰))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿲
+ (nth 1 enc2-str)
+ (nth 2 structure)
+ (nth 2 enc2-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
+ 612))
+ )
+ )
+ ((eq (car enc-str) ?⿲)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
+ 620))
+ )
+ ((eq (car enc-str) ?⿴)
+ (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+ (when (and enc2-str
+ (eq (car enc2-str) ?⿰))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
+ 630)))
+ )
+ ((eq (car enc-str) ?⿵)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿵ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿵ (nth 1 enc-str) new-str-c)
+ 640))
+ )
+ ))
+ )
+ ((eq (car structure) ?⿷)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿺)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿱
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿺ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿺ (nth 1 enc-str) new-str-c)
+ 710))
+ )
+ ((eq (car enc-str) ?⿸)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (cond
+ ((and (characterp (nth 2 enc-str))
+ (or (memq (char-ucs (nth 2 enc-str))
+ '(#x4EBA #x5165 #x513F #x51E0))
+ (memq (or (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
+ (encode-char (nth 2 enc-str) '=>ucs@component))
+ '(#x4EBA #x513F))))
+ (setq new-str (list ?⿺
+ (nth 2 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿸ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿸ (nth 1 enc-str) new-str-c)
+ 721))
+ )
+ (t
+ (setq new-str (list ?⿱
+ (nth 2 structure)
+ (nth 2 enc-str)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿸ (nth 1 enc-str) new-str-c)
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿸ (nth 1 enc-str) new-str-c)
+ 722))
+ ))
+ )
+ ))
+ )
+ ((eq (car structure) ?⿺)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (or (get-char-attribute enc 'ideographic-structure)
+ (get-char-attribute enc 'ideographic-structure@apparent)
+ (get-char-attribute enc 'ideographic-structure@apparent/leftmost)
+ (get-char-attribute enc 'ideographic-structure@apparent/rightmost))
+ )
+ ((consp enc)
+ (or (cdr (assq 'ideographic-structure enc))
+ (cdr (assq 'ideographic-structure@apparent enc))
+ (cdr (assq 'ideographic-structure@apparent/leftmost enc))
+ (cdr (assq 'ideographic-structure@apparent/rightmost enc)))
+ )))
+ ;; (setq enc-str
+ ;; (mapcar (lambda (cell)
+ ;; (or (and (listp cell)
+ ;; (find-char cell))
+ ;; cell))
+ ;; enc-str))
+ (cond
+ ((eq (car enc-str) ?⿱)
+ (cond
+ ((and (characterp (nth 1 enc-str))
+ (or (and (eq (char-ucs (nth 1 enc-str)) #x200CA)
+ (setq code 811))
+ (and (eq (char-feature (nth 1 enc-str) '=>iwds-1) 233)
+ (characterp (nth 2 structure))
+ (eq (char-ucs (nth 2 structure)) #x4E36)
+ (setq code 812))))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿺
+ (nth 1 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ code))
+ )
+ ((and (characterp (nth 2 enc-str))
+ (or (memq (char-ucs (nth 2 enc-str))
+ '(#x4E00
+ #x706C
+ #x65E5 #x66F0 #x5FC3
+ #x2123C #x58EC #x738B #x7389))
+ (memq (encode-char (nth 2 enc-str) '=>ucs@component)
+ '(#x2123C #x58EC))
+ (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
+ #x7389)
+ (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
+ #x8D71)))
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (setq new-str (list ?⿰
+ (nth 1 enc-str)
+ (nth 2 structure)))
+ (setq new-str-c
+ (if (setq ret (ideographic-structure-find-chars new-str))
+ (car ret)
+ (list (cons 'ideographic-structure new-str))))
+ (if conversion-only
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ (setq a-res (ids-find-chars-including-ids new-str))
+ (list enc
+ f-res
+ new-str-c
+ a-res
+ (list ?⿱ new-str-c (nth 2 enc-str))
+ 813))
+ )
+ ))))
+ )
+ ((eq (car structure) ?⿻)
+ (setq enc (nth 1 structure))
+ (when (setq enc-str
+ (cond ((characterp enc)
+ (get-char-attribute enc 'ideographic-structure)
+ )
+ ((consp enc)
+ (cdr (assq 'ideographic-structure enc))
+ )))
+ (cond
+ ((eq (car enc-str) ?⿱)
+ (unless conversion-only
+ (setq f-res (ids-find-chars-including-ids enc-str)))
+ (if conversion-only
+ (list ?⿳ (nth 1 enc-str) (nth 2 structure) (nth 2 enc-str))
+ (list enc
+ f-res
+ new-str
+ nil
+ (list ?⿳
+ (nth 1 enc-str)
+ (nth 2 structure)
+ (nth 2 enc-str))
+ 911))
+ )))
+ ))
+ ))
+
+
;;; @ End.
;;;
projects / chise / ids.git / blobdiff