+(defun ids-index-store-char (product component)
+ (let ((ret (get-char-attribute component 'ideographic-products)))
+ (unless (memq product ret)
+ (put-char-attribute component 'ideographic-products
+ (cons product ret))
+ (when (setq ret (char-feature component 'ideographic-structure))
+ (ids-index-store-structure product ret)))
+ ))
+
+(defun ids-index-store-structure (product structure)
+ (let (ret)
+ (dolist (cell (cdr structure))
+ (if (char-ref-p cell)
+ (setq cell (plist-get cell :char)))
+ (cond ((characterp cell)
+ (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))
+ ))))
+
+;;;###autoload
+(defun ids-update-index ()
+ (interactive)
+ (map-char-attribute
+ (lambda (c v)
+ (ids-index-store-structure c v)
+ nil)
+ 'ideographic-structure)
+ (save-char-attribute-table 'ideographic-products))
+
+
+(mount-char-attribute-table 'ideographic-products)
+
+;;;###autoload
+(defun ids-find-all-products (char)
+ (let (dest)
+ (dolist (cell (char-feature char 'ideographic-products))
+ (unless (memq cell dest)
+ (setq dest (cons cell dest)))
+ (setq dest (union dest (ids-find-all-products cell))))
+ dest))
+
+(defun of-component-features ()
+ (let (dest)
+ (dolist (feature (char-attribute-list))
+ (when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
+ (symbol-name feature))
+ (push feature dest)))
+ (cons '<-ideographic-component-forms
+ dest)))
+
+(defun to-component-features ()
+ (let (dest)
+ (dolist (feature (char-attribute-list))
+ (when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
+ (symbol-name feature))
+ (push feature dest)))
+ (cons '->ideographic-component-forms
+ 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 (get-char-attribute char '->ucs-unified))
+ (setq dest (cons char ret))
+ (dolist (c dest)
+ (setq dest (union dest
+ (some (lambda (feature)
+ (get-char-attribute c feature))
+ (of-component-features))
+ )))
+ )
+ ((and (setq ret (get-char-attribute char '=>ucs))
+ (setq uchr (decode-char '=ucs ret)))
+ (setq dest (cons uchr (char-variants uchr)))
+ (dolist (c dest)
+ (setq dest (union dest
+ (some (lambda (feature)
+ (get-char-attribute c feature))
+ (of-component-features))
+ )))
+ )
+ (t
+ (map-char-family
+ (lambda (c)
+ (unless (memq c dest)
+ (setq dest (cons c dest)))
+ (setq dest
+ (union dest
+ (some (lambda (feature)
+ (char-feature c feature))
+ (of-component-features))
+ ))
+ nil)
+ char)
+ ))
+ dest))
+
+;;;###autoload
+(defun ideographic-products-find (&rest components)
+ (if (stringp (car components))
+ (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 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 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)))
+;; (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))
+
+
+(defun ideographic-structure-char= (c1 c2)
+ (or (eq c1 c2)
+ (and c1 c2
+ (let ((m1 (char-ucs c1))
+ (m2 (char-ucs c2)))
+ (or (and m1 m2
+ (eq m1 m2))
+ (memq c1 (char-component-variants c2))
+ ;; (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))
+ ;; )
+ )))))
+
+(defun ideographic-structure-member-compare-components (component s-component)