X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=blobdiff_plain;f=ids-find.el;h=eeafbf902e414f7ef7284a9361506b08019d9ac8;hb=c0fc2d6c9dacce8207ab01400b99a3b2efd66406;hp=eb404b356120a895f36e8ce2b53f9cdf86d1ddc4;hpb=e0de0c5d3ed092bbc1581ec9c52e7c5dedfe4921;p=chise%2Fids.git

diff --git a/ids-find.el b/ids-find.el
index eb404b3..eeafbf9 100644
--- a/ids-find.el
+++ b/ids-find.el
@@ -1,11 +1,11 @@
 ;;; ids-find.el --- search utility based on Ideographic-structures
 
-;; Copyright (C) 2002,2003,2005,2006,2007,2017 MORIOKA Tomohiko
+;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020 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 CHISE IDS.
+;; 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
@@ -54,6 +54,11 @@
      (ids-index-store-structure c v)
      nil)
    'ideographic-structure)
+  (map-char-attribute
+   (lambda (c v)
+     (ids-index-store-structure c v)
+     nil)
+   'ideographic-structure@apparent)
   (save-char-attribute-table 'ideographic-products))
 
 
@@ -407,6 +412,205 @@
   (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)
+  (apply #'ideographic-structure-find-chars* structure))
+
+(defun ideographic-structure-find-chars* (operator component1 component2
+						   &optional component3)
+  (let ((comp-alist (ideographic-structure-to-components-alist*
+		     operator component1 component2 component3))
+	c1 c2 c3
+	ret pl str
+	var-alist)
+    (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 (setq str (get-char-attribute pc 'ideographic-structure))
+		 (setq var-alist
+		       (ideographic-structure-character= (car str) operator))
+		 (setq c1 (nth 1 str))
+		 (setq ret (ideographic-structure-character= c1 component1))
+		 (setq var-alist (ids-find-merge-variables var-alist ret))
+		 (setq c2 (nth 2 str))
+		 (setq ret (ideographic-structure-character= c2 component2))
+		 (setq var-alist (ids-find-merge-variables var-alist ret))
+		 (cond ((memq (car str) '(?\u2FF2 ?\u2FF3))
+			(setq c3 (nth 3 str))
+			(and (setq ret (ideographic-structure-character=
+					c3 component3))
+			     (ids-find-merge-variables var-alist ret))
+			)
+		       (t var-alist)))
+	(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))))
+
+
 ;;; @ End.
 ;;;