X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=ids-find.el;h=8ac5f3d72b70aaa42e1b0952dca231ae9c86a72a;hb=a4534d0f7936b67cc5bdd4d253f8115ec4d08886;hp=a4acb7187eb0665de4529852ac4e8b1b797e750f;hpb=65512485fdfd728da75c7a2131215210c6c57d3b;p=chise%2Fids.git

diff --git a/ids-find.el b/ids-find.el
index a4acb71..8ac5f3d 100644
--- a/ids-find.el
+++ b/ids-find.el
@@ -1,6 +1,7 @@
 ;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*-
 
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020 MORIOKA Tomohiko
+;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021, 2022
+;;   MORIOKA Tomohiko
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode
@@ -30,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)
@@ -42,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))
 	    ))))
@@ -59,6 +73,16 @@
      (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)
   (unless in-memory
     (save-char-attribute-table 'ideographic-products)))
 
@@ -571,6 +595,12 @@
 		     (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))
 	))
@@ -763,6 +793,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))
@@ -953,7 +986,28 @@ COMPONENT can be a character or char-spec."
 		  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))
@@ -1541,9 +1595,29 @@ COMPONENT can be a character or char-spec."
 		    new-str-c
 		    a-res
 		    (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
-		    630))
-	    )
-	  )))
+		    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))
@@ -1574,18 +1648,69 @@ COMPONENT can be a character or char-spec."
 		  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)
+			     (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 enc))
+			     (cdr (assq 'ideographic-structure@apparent/leftmost enc))
+			     (cdr (assq 'ideographic-structure@apparent/rightmost enc)))
 			 )))
         ;; (setq enc-str
         ;;       (mapcar (lambda (cell)
@@ -1623,11 +1748,17 @@ COMPONENT can be a character or char-spec."
 		    code))
 	    )
 	   ((and (characterp (nth 2 enc-str))
-		 (memq (char-ucs (nth 2 enc-str))
-		       '(#x4E00
-			 #x706C
-			 #x65E5 #x66F0 #x5FC3
-			 #x2123C #x58EC #x738B #x7389)))
+		 (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 ?â¿°