X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fids.git;a=blobdiff_plain;f=ids-find.el;h=a4acb7187eb0665de4529852ac4e8b1b797e750f;hp=0ef26a5a45cadfcb00c5379d0a41814041f9c16f;hb=HEAD;hpb=994bca837303d1238f0b9ebe712804696d22e398

diff --git a/ids-find.el b/ids-find.el
index 0ef26a5..b0afbdd 100644
--- a/ids-find.el
+++ b/ids-find.el
@@ -1,6 +1,6 @@
 ;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*-
 
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021
+;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021, 2022, 2023
 ;;   MORIOKA Tomohiko
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
@@ -31,7 +31,14 @@
       (put-char-attribute component 'ideographic-products
 			  (cons product ret))
       (when (setq ret (char-feature component 'ideographic-structure))
-	(ids-index-store-structure product ret)))
+	(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)
@@ -43,6 +50,12 @@
 	     (ids-index-store-char product cell))
 	    ((setq ret (assq 'ideographic-structure cell))
 	     (ids-index-store-structure product (cdr 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))
 	    ))))
@@ -65,6 +78,57 @@
      (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)))
 
@@ -580,6 +644,9 @@
 		     (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))
 	))
@@ -772,6 +839,9 @@ COMPONENT can be a character or char-spec."
 	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))
@@ -1679,12 +1749,14 @@ COMPONENT can be a character or char-spec."
 		  (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/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/leftmost enc))
+			     (cdr (assq 'ideographic-structure@apparent/rightmost enc)))
 			 )))
         ;; (setq enc-str
         ;;       (mapcar (lambda (cell)
@@ -1730,7 +1802,9 @@ COMPONENT can be a character or char-spec."
 		     (memq (encode-char (nth 2 enc-str) '=>ucs@component)
 			   '(#x2123C #x58EC))
 		     (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
-			 #x7389)))
+			 #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 ?â¿°