From: MORIOKA Tomohiko <tomo.git@chise.org>
Date: Fri, 4 Sep 2020 00:48:41 +0000 (+0900)
Subject: (ideographic-structure-compare-functional-and-apparent): New function.
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=c41b6ac1f036f0c43635823511419526f8bc8e56;p=chise%2Fids.git

(ideographic-structure-compare-functional-and-apparent): New function.
---

diff --git a/ids-find.el b/ids-find.el
index 6c90f55..076a701 100644
--- a/ids-find.el
+++ b/ids-find.el
@@ -1120,6 +1120,439 @@ COMPONENT can be a character or char-spec."
       (setq dest (cons cell dest)))
     (nreverse dest)))
 
+(defun ideographic-structure-compare-functional-and-apparent (structure
+							      &optional char)
+  (let (enc enc-str enc2-str new-str f-res a-res)
+    (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) ?â¿°)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 2 enc-str)
+			      (nth 2 structure)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?â¿°
+		      (nth 1 enc-str)
+		      (list (cons 'ideographic-structure new-str))))
+	  )
+	 ((and (eq (car enc-str) ?⿲)
+	       (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
+	       (eq (nth 2 enc-str) ?丨))
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 3 enc-str)
+			      (nth 2 structure)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?â¿°
+		      (decode-char '=big5-cdp #x8B7A)
+		      (list (cons 'ideographic-structure new-str))))
+	  )
+	 ((eq (car enc-str) ?⿱)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str
+		(list
+		 (cond
+		  ((characterp (nth 2 enc-str))
+		   (if (or (eq (encode-char (nth 2 enc-str) '=>ucs@component)
+			       #x20087)
+			   (eq (encode-char (nth 2 enc-str) '=>ucs@component)
+			       #x5382)
+			   (eq (encode-char (nth 2 enc-str) '=>ucs@component)
+			       #x4E06)
+			   (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 a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list
+		 ?⿱
+		 (nth 1 enc-str)
+		 (list
+		  (cons 'ideographic-structure
+			(or (functional-ideographic-structure-to-apparent-structure
+			     new-str)
+			    new-str)))))
+	  )
+	 ((eq (car enc-str) ?⿸)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 2 enc-str)
+			      (nth 2 structure)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?⿸ (nth 1 enc-str)
+		      (list (cons 'ideographic-structure new-str))))
+	  )))
+      )
+     ((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 f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 1 enc-str)
+			      (nth 2 structure)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?â¿°
+		      (list (cons 'ideographic-structure new-str))
+		      (nth 2 enc-str)))
+	  )))
+      )
+     ((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) ?⿺)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 2 structure)
+			      (nth 1 enc-str)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?⿺
+		      (list (cons 'ideographic-structure new-str))
+		      (nth 2 enc-str)))
+	  )
+	 ((eq (car enc-str) ?⿱)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?â¿°
+			      (nth 2 structure)
+			      (nth 1 enc-str)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?⿱
+		      (list (cons 'ideographic-structure new-str))
+		      (nth 2 enc-str)))
+	  ))
+	)
+      )
+     ((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)))
+	    (setq f-res (ids-find-chars-including-ids enc-str))
+	    (setq new-str (list ?â¿´
+				(nth 2 enc-str)
+				(nth 2 structure)))
+	    (setq a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿱
+			(nth 1 enc-str)
+			(list (cons 'ideographic-structure new-str))
+			))
+	    )
+	   ((and (characterp (nth 2 enc-str))
+		 (eq (char-ucs (nth 2 enc-str)) #x51F5))
+	    (setq f-res (ids-find-chars-including-ids enc-str))
+	    (setq new-str (list ?⿶
+				(nth 2 enc-str)
+				(nth 2 structure)))
+	    (setq a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿱
+			(nth 1 enc-str)
+			(list (cons 'ideographic-structure
+				    new-str))
+			))
+	    )	    
+	   ((and (characterp (nth 1 enc-str))
+		 (eq (char-feature (nth 1 enc-str) '=>ucs@component)
+		     #x300E6))
+	    (setq f-res (ids-find-chars-including-ids enc-str))
+	    (setq new-str (list ?⿵
+				(nth 1 enc-str)
+				(nth 2 structure)))
+	    (setq a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿱
+			(list (cons 'ideographic-structure new-str))
+			(nth 2 enc-str)))
+	    )
+	   (t
+	    (setq f-res (ids-find-chars-including-ids enc-str))
+	    (list enc
+		  f-res
+		  new-str
+		  nil
+		  (list ?⿳
+			(nth 1 enc-str)
+			(nth 2 structure)
+			(nth 2 enc-str)))
+	    ))
+	  ))
+	)
+      )
+     ((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) ?â¿°))
+	    (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 a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿱
+			(list (cons 'ideographic-structure new-str))
+			(nth 2 enc-str))))
+	  )
+	 ((eq (car enc-str) ?⿳)
+	  (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+	  (when (and enc2-str
+		     (eq (car enc2-str) ?â¿°))
+	    (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 a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿳
+			(list (cons 'ideographic-structure new-str))
+			(nth 2 enc-str)
+			(nth 3 enc-str))))
+	  )
+	 ((eq (car enc-str) ?⿲)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 2 structure)
+			      (nth 2 enc-str)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?⿲
+		      (nth 1 enc-str)
+		      (list (cons 'ideographic-structure new-str))
+		      (nth 3 enc-str)))
+	  )
+	 ((eq (car enc-str) ?â¿´)
+	  (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+	  (when (and enc2-str
+		     (eq (car enc2-str) ?â¿°))
+	    (setq f-res (ids-find-chars-including-ids enc-str))
+	    (setq new-str (list ?⿱
+				(nth 2 structure)
+				(nth 2 enc-str)))
+	    (setq a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿲
+			(nth 1 enc2-str)
+			(list (cons 'ideographic-structure new-str))
+			(nth 2 enc2-str))))
+	  )))
+      )
+     ((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 2 enc-str)))
+	  (when (and enc2-str
+		     (eq (car enc2-str) ?â¿°))
+	    (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 a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿱
+			(nth 1 enc-str)
+			(list (cons 'ideographic-structure new-str)))))
+	  )
+	 ((eq (car enc-str) ?⿳)
+	  (setq enc2-str (ideographic-character-get-structure (nth 3 enc-str)))
+	  (when (and enc2-str
+		     (eq (car enc2-str) ?â¿°))
+	    (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 a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿳
+			(nth 1 enc-str)
+			(nth 2 enc-str)
+			(list (cons 'ideographic-structure new-str)))))
+	  )
+	 ((eq (car enc-str) ?⿲)
+	  (setq f-res (ids-find-chars-including-ids enc-str))
+	  (setq new-str (list ?⿱
+			      (nth 2 enc-str)
+			      (nth 2 structure)))
+	  (setq a-res (ids-find-chars-including-ids new-str))
+	  (list enc
+		f-res
+		new-str
+		a-res
+		(list ?⿲
+		      (nth 1 enc-str)
+		      (list (cons 'ideographic-structure new-str))
+		      (nth 3 enc-str)))
+	  )
+	 ((eq (car enc-str) ?â¿´)
+	  (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
+	  (when (and enc2-str
+		     (eq (car enc2-str) ?â¿°))
+	    (setq f-res (ids-find-chars-including-ids enc-str))
+	    (setq new-str (list ?⿱
+				(nth 2 enc-str)
+				(nth 2 structure)))
+	    (setq a-res (ids-find-chars-including-ids new-str))
+	    (list enc
+		  f-res
+		  new-str
+		  a-res
+		  (list ?⿲
+			(nth 1 enc2-str)
+			(list (cons 'ideographic-structure new-str))
+			(nth 2 enc2-str))))
+	  )))
+      )
+     ((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 f-res (ids-find-chars-including-ids enc-str))
+	  (list enc
+		f-res
+		new-str
+		nil
+		(list ?⿳
+		      (nth 1 enc-str)
+		      (nth 2 structure)
+		      (nth 2 enc-str)))
+	  )))
+      ))
+    ))
+
 
 ;;; @ End.
 ;;;