X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=ids-find.el;h=eb404b356120a895f36e8ce2b53f9cdf86d1ddc4;hb=1128c5b94cdf0db731756375ea5878b373c0606d;hp=0e0e7be8f32c0287858a438c12e66a5d87b5a153;hpb=f7abebb51ae1a8f4e828f1816bdf2d33a4853752;p=chise%2Fids.git

diff --git a/ids-find.el b/ids-find.el
index 0e0e7be..eb404b3 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 MORIOKA Tomohiko
+;; Copyright (C) 2002,2003,2005,2006,2007,2017 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 Tomoyo-Tools.
+;; 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
@@ -42,8 +42,8 @@
 	     (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))
+	    ((setq ret (find-char cell))
+	     (ids-index-store-char product ret))
 	    ))))
 
 ;;;###autoload
@@ -74,8 +74,12 @@
       (when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
 			  (symbol-name feature))
 	(push feature dest)))
-    (cons '<-ideographic-component-forms
-	  dest)))
+    (list* '<-mistakable '->mistakable
+	   '<-formed '->formed
+	   '<-same '->same
+	   '<-original '->original
+	   '<-ancient '->ancient
+	   dest)))
 
 (defun to-component-features ()
   (let (dest)
@@ -83,26 +87,29 @@
       (when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
 			  (symbol-name feature))
 	(push feature dest)))
-    (cons '->ideographic-component-forms
-	  dest)))
+    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 (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 char feature))
+				  (get-char-attribute c feature))
 				(of-component-features))
 			  )))
       )
@@ -112,7 +119,7 @@
       (dolist (c dest)
 	(setq dest (union dest
                           (some (lambda (feature)
-				  (get-char-attribute char feature))
+				  (get-char-attribute c feature))
 				(of-component-features))
 			  )))
       )
@@ -146,35 +153,55 @@
 		(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 ideograph-find-products-with-variants (components &optional ignored-chars)
+  (if (stringp components)
+      (setq components (string-to-char-list components)))
+  (let (dest products)
+    (dolist (variant (char-component-variants (car components)))
       (setq products
 	    (union products
-		   (get-char-attribute variant 'ideographic-products))))
+		   (set-difference
+		    (get-char-attribute variant 'ideographic-products)
+		    ignored-chars))))
+    (setq dest products)
+    (while (and dest
+		(setq components (cdr components)))
+      (setq products nil)
+      (dolist (variant (char-component-variants (car components)))
+	(setq products
+	      (union products
+		     (set-difference
+		      (get-char-attribute variant 'ideographic-products)
+		      ignored-chars))))
+      (setq dest (intersection dest products)))
+    dest))
+
+(defun ideograph-find-products (components &optional ignored-chars)
+  (if (stringp components)
+      (setq components (string-to-char-list components)))
+  (let (dest products)
+    ;; (dolist (variant (char-component-variants (car components)))
+    ;;   (setq products
+    ;;         (union products
+    ;;                (get-char-attribute variant 'ideographic-products))))
+    ;; (setq dest products)
+    (setq dest (get-char-attribute (car components) 'ideographic-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 products (get-char-attribute (car components) '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)
@@ -184,26 +211,7 @@
 		 (m2 (char-ucs c2)))
 	     (or (and m1 m2
 		      (eq m1 m2))
-		 (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))))))))
+		 (memq c1 (char-component-variants c2)))))))
 
 (defun ideographic-structure-member-compare-components (component s-component)
   (let (ret)
@@ -275,12 +283,60 @@
 	  (or (ideographic-structure-to-ids v)
 	      v)))
 
+(defun ids-insert-chars-including-components* (components
+					       &optional level ignored-chars)
+  (unless level
+    (setq level 0))
+  (let (is i as bs)
+    (dolist (c (sort (copy-tree (ideograph-find-products components
+							 ignored-chars))
+		     (lambda (a b)
+		       (if (setq as (char-total-strokes a))
+			   (if (setq bs (char-total-strokes b))
+			       (if (= as bs)
+				   (ideograph-char< a b)
+				 (< as bs))
+			     t)
+			 (ideograph-char< a b)))))
+      (unless (memq c ignored-chars)
+	(setq is (char-feature c 'ideographic-structure))
+	(setq i 0)
+	(while (< i level)
+	  (insert "\t")
+	  (setq i (1+ i)))
+	(insert (ids-find-format-line c is))
+	(setq ignored-chars
+	      (ids-insert-chars-including-components*
+	       (char-to-string c) (1+ level)
+	       (cons c ignored-chars))))
+      )
+    )
+  ignored-chars)
+
 (defun ids-insert-chars-including-components (components
 					      &optional level ignored-chars)
   (unless level
     (setq level 0))
-  (let (is dis i as bs)
-    (dolist (c (sort (ideographic-products-find components)
+  (setq ignored-chars
+	(nreverse
+	 (ids-insert-chars-including-components* components
+						 level ignored-chars)))
+  (let (is i as bs)
+    (dolist (c ignored-chars)
+      (dolist (vc (char-component-variants c))
+	(unless (memq vc ignored-chars)
+	  (when (setq is (get-char-attribute vc 'ideographic-structure))
+	    (setq i 0)
+	    (while (< i level)
+	      (insert "\t")
+	      (setq i (1+ i)))
+	    (insert (ids-find-format-line vc is))
+	    (setq ignored-chars
+		  (ids-insert-chars-including-components*
+		   (char-to-string vc) (1+ level)
+		   (cons vc ignored-chars)))))))
+    (dolist (c (sort (copy-tree (ideograph-find-products-with-variants
+				 components ignored-chars))
 		     (lambda (a b)
 		       (if (setq as (char-total-strokes a))
 			   (if (setq bs (char-total-strokes b))
@@ -290,31 +346,19 @@
 			     t)
 			 (ideograph-char< a b)))))
       (unless (memq c ignored-chars)
-	(setq is (char-feature c 'ideographic-structure))
+	(setq is (get-char-attribute c 'ideographic-structure))
 	(setq i 0)
 	(while (< i level)
 	  (insert "\t")
 	  (setq i (1+ i)))
 	(insert (ids-find-format-line c is))
 	(setq ignored-chars
-	      (ids-insert-chars-including-components
+	      (ids-insert-chars-including-components*
 	       (char-to-string c) (1+ level)
 	       (cons c ignored-chars))))
-      ))
+      )
+    )
   ignored-chars)
-;; (defun ids-insert-chars-including-components (components level)
-;;   (let (is dis i)
-;;     (dolist (c (ideographic-products-find components))
-;;       (setq is (char-feature c 'ideographic-structure))
-;;       (setq i 0)
-;;       (while (< i level)
-;;         (insert "\t")
-;;         (setq i (1+ i)))
-;;       (insert (ids-find-format-line c is))
-;;       ;;(forward-line -1)
-;;       (ids-insert-chars-including-components
-;;        (char-to-string c) (1+ level))
-;;       )))
 
 ;;;###autoload
 (defun ids-find-chars-including-components (components)
@@ -323,48 +367,23 @@
   (with-current-buffer (get-buffer-create ids-find-result-buffer)
     (setq buffer-read-only nil)
     (erase-buffer)
-    (ids-insert-chars-including-components components 0)
-    ;; (let (is dis)
-    ;;   (dolist (c (ideographic-products-find components))
-    ;;     (setq is (char-feature c 'ideographic-structure))
-    ;;     ;; to avoid problems caused by wrong indexes
-    ;;     ;; (when (every (lambda (cc)
-    ;;     ;;                (ideographic-structure-member cc is))
-    ;;     ;;              components)
-    ;;     (dolist (dc (ideographic-products-find (char-to-string c)))
-    ;;       (setq dis (char-feature dc 'ideographic-structure))
-    ;;     ;;     ;; to avoid problems caused by wrong indexes
-    ;;     ;;     (when (every (lambda (dcc)
-    ;;     ;;                    (ideographic-structure-member dcc is))
-    ;;     ;;                  components)
-    ;;       (insert "\t")
-    ;;       (insert (ids-find-format-line dc dis))
-    ;;       (forward-line -1)
-    ;;     ;;       )
-    ;;       )
-    ;;     (insert (ids-find-format-line c is))
-    ;;     (forward-line -1)
-    ;;     ;;   )
-    ;;     )
-    ;;   )
+    (ids-insert-chars-including-components components 0 nil)
+    ;; (let ((ignored-chars
+    ;;        (nreverse
+    ;;         (ids-insert-chars-including-components components 0 nil
+    ;;                                                #'ideograph-find-products)))
+    ;;       rest)
+    ;;   (setq rest ignored-chars)
+    ;;   ;; (dolist (c rest)
+    ;;   ;;   (setq ignored-chars
+    ;;   ;;         (union ignored-chars
+    ;;   ;;                (ids-insert-chars-including-components
+    ;;   ;;                 (list c) 0 ignored-chars
+    ;;   ;;                 #'ideograph-find-products-with-variants))))
+    ;;   (ids-insert-chars-including-components components 0 ignored-chars
+    ;;                                          #'ideograph-find-products-with-variants))
     (goto-char (point-min)))
   (view-buffer ids-find-result-buffer))
-;; (defun ids-find-chars-including-components (components)
-;;   "Search Ideographs whose structures have COMPONENTS."
-;;   (interactive "sComponents : ")
-;;   (with-current-buffer (get-buffer-create ids-find-result-buffer)
-;;     (setq buffer-read-only nil)
-;;     (erase-buffer)
-;;     (map-char-attribute
-;;      (lambda (c v)
-;;        (when (every (lambda (p)
-;;                       (ideographic-structure-member p v))
-;;                     components)
-;;          (insert (ids-find-format-line c v)))
-;;        nil)
-;;      'ideographic-structure)
-;;     (goto-char (point-min)))
-;;   (view-buffer ids-find-result-buffer))
 
 ;;;###autoload
 (define-obsolete-function-alias 'ideographic-structure-search-chars
@@ -379,12 +398,11 @@
   (with-current-buffer (get-buffer-create ids-find-result-buffer)
     (setq buffer-read-only nil)
     (erase-buffer)
-    (let (ucs jis)
-      (map-char-attribute
-       (lambda (c v)
-	 (when (ideographic-structure-repertoire-p v components)
-	   (insert (ids-find-format-line c v))))
-       'ideographic-structure))
+    (map-char-attribute
+     (lambda (c v)
+       (when (ideographic-structure-repertoire-p v components)
+	 (insert (ids-find-format-line c v))))
+     'ideographic-structure)
     (goto-char (point-min)))
   (view-buffer ids-find-result-buffer))