From: tomo <tomo>
Date: Wed, 24 Mar 2004 18:32:46 +0000 (+0000)
Subject: (expand-char-feature-name): New function.
X-Git-Tag: r21-4-14-chise-0_21-25-si-same^2~25
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b2796f83b94d04d36cb97efe94dcda51af55ea75;p=chise%2Fxemacs-chise.git

(expand-char-feature-name): New function.
(map-char-family): New function.
(get-char-feature-from-domains): New function.
(char-ideographic-radical): Add new optional argument
`ignore-sisters'; use `get-char-feature-from-domains'.
(char-ideographic-strokes-from-domains): Use
`get-char-feature-from-domains'.
(char-ideographic-strokes): Simplify code about domains.
(update-ideograph-radical-table): Check ancestors' radicals; prefer to
use `get-char-attribute' to get `ideographic-radical' rather than to
use `char-ideographic-radical'.
(char-representative-of-daikanwa): Add new optional arguments
`ignore-default' and `dont-inherit'; use `map-char-family'.
(char-daikanwa): Use `map-char-family'.
---

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index a815051..24a3be5 100644
--- a/lisp/utf-2000/ideograph-util.el
+++ b/lisp/utf-2000/ideograph-util.el
@@ -26,28 +26,111 @@
 
 (require 'char-db-util)
 
+;;;###autoload
+(defun expand-char-feature-name (feature domain)
+  (if domain
+      (intern (format "%s@%s" feature domain))
+    feature))
+
+(defun map-char-family (function char &optional ignore-sisters)
+  (let ((rest (list char))
+	ret checked)
+    (catch 'tag
+      (while rest
+	(unless (memq (car rest) checked)
+	  (if (setq ret (funcall function (car rest)))
+	      (throw 'tag ret))
+	  (setq checked (cons (car rest) checked)
+		rest (append rest
+			     (get-char-attribute (car rest) '->subsumptive)
+			     (get-char-attribute (car rest) '->denotational)
+			     (get-char-attribute (car rest) '->identical)))
+	  (unless ignore-sisters
+	    (setq rest (append rest
+			       (get-char-attribute (car rest) '<-subsumptive)
+			       (get-char-attribute (car rest) '<-denotational)))))
+	(setq rest (cdr rest))))))
+
+(defun get-char-feature-from-domains (char feature domains
+					   &optional tester arg
+					   ignore-sisters)
+  (map-char-family
+   (lambda (ch)
+     (let (ret)
+       (catch 'tag
+	 (dolist (domain domains)
+	   (if (and (or (null tester)
+			(equal (or (char-feature
+				    ch (expand-char-feature-name
+					tester domain))
+				   (char-feature ch tester))
+			       arg))
+		    (setq ret (or (char-feature
+				   ch (expand-char-feature-name
+				       feature domain))
+				  (char-feature ch feature))))
+	       (throw 'tag ret))))))
+   char ignore-sisters)
+  ;; (let ((rest (list char))
+  ;;       ret checked)
+  ;;   (catch 'tag
+  ;;     (while rest
+  ;;       (setq char (car rest))
+  ;;       (unless (memq char checked)
+  ;;         (dolist (domain domains)
+  ;;           (if (and (setq ret (char-feature
+  ;;                               char
+  ;;                               (expand-char-feature-name
+  ;;                                feature domain)))
+  ;;                    (or (null tester)
+  ;;                        (equal (or (char-feature
+  ;;                                    char
+  ;;                                    (expand-char-feature-name
+  ;;                                     tester domain))
+  ;;                                   (char-feature char tester))
+  ;;                               arg)))
+  ;;               (throw 'tag ret)))
+  ;;         (setq rest (append rest
+  ;;                            (get-char-attribute char '->subsumptive)
+  ;;                            (get-char-attribute char '->denotational)
+  ;;                            (get-char-attribute char '<-subsumptive)
+  ;;                            (get-char-attribute char '<-denotational))
+  ;;               checked (cons char checked)))
+  ;;       (setq rest (cdr rest)))))
+  )
+
+
 (defvar ideograph-radical-chars-vector
   (make-vector 215 nil))
 
-(defun char-ideographic-radical (char &optional radical)
+(defun char-ideographic-radical (char &optional radical ignore-sisters)
   (let (ret)
-    (or (catch 'tag
-	  (dolist (domain char-db-feature-domains)
-	    (if (and (setq ret (char-feature
-				char
-				(intern
-				 (format "%s@%s"
-					 'ideographic-radical domain))))
-		     (or (eq ret radical)
-			 (null radical)))
-		(throw 'tag ret))))
+    (or (if radical
+	    (get-char-feature-from-domains
+	     char 'ideographic-radical (cons nil char-db-feature-domains)
+	     'ideographic-radical radical ignore-sisters)
+	  (get-char-feature-from-domains
+	   char 'ideographic-radical (cons nil char-db-feature-domains)
+	   ignore-sisters))
+        ;; (catch 'tag
+        ;;   (dolist (domain char-db-feature-domains)
+        ;;     (if (and (setq ret (char-feature
+        ;;                         char
+        ;;                         (intern
+        ;;                          (format "%s@%s"
+        ;;                                  'ideographic-radical domain))))
+        ;;              (or (eq ret radical)
+        ;;                  (null radical)))
+        ;;         (throw 'tag ret))))
 	(catch 'tag
 	  (dolist (cell (get-char-attribute char 'ideographic-))
 	    (if (and (setq ret (plist-get cell :radical))
 		     (or (eq ret radical)
 			 (null radical)))
 		(throw 'tag ret))))
-	(char-feature char 'ideographic-radical)
+	(get-char-feature-from-domains
+	 char 'ideographic-radical (cons nil char-db-feature-domains))
+        ;; (char-feature char 'ideographic-radical)
 	(progn
 	  (setq ret
 		(or (get-char-attribute char 'daikanwa-radical)
@@ -87,24 +170,38 @@
 
 ;;;###autoload
 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
-  (let (ret)
-    (catch 'tag
-      (dolist (domain domains)
-	(if (and (setq ret (or (char-feature
-				char
-				(intern
-				 (format "%s@%s"
-					 'ideographic-radical domain)))
-			       (char-feature
-				char 'ideographic-radical)))
-		 (or (eq ret radical)
-		     (null radical))
-		 (setq ret (char-feature
-			    char
-			    (intern
-			     (format "%s@%s"
-				     'ideographic-strokes domain)))))
-	    (throw 'tag ret))))))
+  (if radical
+      (get-char-feature-from-domains char 'ideographic-strokes domains
+				     'ideographic-radical radical)
+    (get-char-feature-from-domains char 'ideographic-strokes domains))
+  ;; (let ((rest (list char))
+  ;;       ret checked)
+  ;;   (catch 'tag
+  ;;     (while rest
+  ;;       (setq char (car rest))
+  ;;       (unless (memq char checked)
+  ;;         (dolist (domain domains)
+  ;;           (if (and (setq ret (or (char-feature
+  ;;                                   char
+  ;;                                   (expand-char-feature-name
+  ;;                                    'ideographic-radical domain))
+  ;;                                  (char-feature
+  ;;                                   char 'ideographic-radical)))
+  ;;                    (or (eq ret radical)
+  ;;                        (null radical))
+  ;;                    (setq ret (or (char-feature
+  ;;                                   char
+  ;;                                   (expand-char-feature-name
+  ;;                                    'ideographic-strokes domain))
+  ;;                                  (char-feature
+  ;;                                   char 'ideographic-strokes))))
+  ;;               (throw 'tag ret)))
+  ;;         (setq rest (append rest
+  ;;                            (get-char-attribute char '->subsumptive)
+  ;;                            (get-char-attribute char '->denotational))
+  ;;               checked (cons char checked)))
+  ;;       (setq rest (cdr rest)))))
+  )
 
 ;;;###autoload
 (defun char-ideographic-strokes (char &optional radical preferred-domains)
@@ -116,11 +213,10 @@
 			 (null radical)))
 		(throw 'tag (plist-get cell :strokes)))))
 	(char-ideographic-strokes-from-domains
-	 char preferred-domains radical)
-	(get-char-attribute char 'ideographic-strokes)
-	(char-ideographic-strokes-from-domains
-	 char char-db-feature-domains radical)
-	(char-feature char 'ideographic-strokes)
+	 char (append preferred-domains
+		      (cons nil
+			    char-db-feature-domains))
+	 radical)
 	(get-char-attribute char 'daikanwa-strokes)
 	(let ((strokes
 	       (or (get-char-attribute char 'kangxi-strokes)
@@ -171,8 +267,9 @@
 			    (progn
 			      (setq dest nil)
 			      (dolist (pc ret)
-				(unless (get-char-attribute
-					 pc 'ideographic-radical)
+				(unless (eq (get-char-attribute
+					     pc 'ideographic-radical)
+					    radical)
 				  (setq dest (cons pc dest))))
 			      dest)
 			  (list chr))
@@ -180,7 +277,9 @@
 			(get-char-attribute chr '->denotational)))
 	   (when (and radical
 		      (or (eq radical
-			      (char-ideographic-radical char radical))
+			      (or (get-char-attribute
+				   char 'ideographic-radical)
+				  (char-ideographic-radical char radical)))
 			  (null (char-ideographic-radical char)))
 		      (or (null (setq script
 				      (get-char-attribute char 'script)))
@@ -247,7 +346,8 @@
 ;;         (t (< a b))))
 
 ;;;###autoload
-(defun char-representative-of-daikanwa (char &optional radical)
+(defun char-representative-of-daikanwa (char &optional radical
+					     ignore-default dont-inherit)
   (unless radical
     (setq radical ideographic-radical))
   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
@@ -255,7 +355,8 @@
       char
     (let ((m (char-feature char '=>daikanwa))
 	  m-m m-s pat
-	  scs sc ret)
+	  ;;scs sc ret
+	  )
       (or (and (integerp m)
 	       (or (decode-char '=daikanwa-rev2 m 'defined-only)
 		   (decode-char 'ideograph-daikanwa m)))
@@ -272,20 +373,33 @@
 				      (if (equal pat v)
 					  c))
 				    'morohashi-daikanwa))))
-	  (when (setq scs (get-char-attribute char '->subsumptive))
-	    (while (and scs
-			(setq sc (car scs))
-			(not
-			 (and
-			  (setq ret
-				(char-representative-of-daikanwa sc))
+	  (unless dont-inherit
+	    (map-char-family
+	     (lambda (sc)
+	       (let ((ret (char-representative-of-daikanwa sc nil t t)))
+		 (if (and ret
 			  (or (null radical)
 			      (eq (char-ideographic-radical ret radical)
-				  radical)
-			      (setq ret nil)))))
-	      (setq scs (cdr scs)))
-	    ret)
-	  char))))
+				  radical)))
+		     ret)))
+	     char))
+	  ;; (when (setq scs (append
+          ;;                  (get-char-attribute char '->subsumptive)
+          ;;                  (get-char-attribute char '->denotational)))
+          ;;   (while (and scs
+          ;;               (setq sc (car scs))
+          ;;               (not
+          ;;                (and
+          ;;                 (setq ret
+          ;;                       (char-representative-of-daikanwa sc nil t))
+          ;;                 (or (null radical)
+          ;;                     (eq (char-ideographic-radical ret radical)
+          ;;                         radical)
+          ;;                     (setq ret nil)))))
+          ;;     (setq scs (cdr scs)))
+          ;;   ret)
+	  (unless ignore-default
+	    char)))))
 
 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
   (catch 'tag
@@ -331,33 +445,30 @@
 
 ;;;###autoload
 (defun char-daikanwa (char &optional radical)
-  (or (encode-char char 'ideograph-daikanwa 'defined-only)
-      (encode-char char '=daikanwa-rev2 'defined-only)
-      (get-char-attribute char 'morohashi-daikanwa)
-      (let ((ret (char-feature char '=>daikanwa)))
-	(and ret
-	     (if (or (get-char-attribute char '<-subsumptive)
-		     (get-char-attribute char '<-denotational))
-		 (list ret 0)
-	       ret)))
-      (let ((scs (get-char-attribute char '->subsumptive))
-	    sc ret)
-	(unless radical
-	  (setq radical ideographic-radical))
-	(when scs
-	  (while (and scs
-		      (setq sc (car scs))
-		      (not
-		       (and
-			(setq ret
-			      (char-representative-of-daikanwa sc))
-			(or (null radical)
-			    (eq (char-ideographic-radical ret radical)
-				radical)
-			    (setq ret nil)))))
-	    (setq scs (cdr scs))))
-	(if ret
-	    (char-daikanwa ret)))))
+  (unless radical
+    (setq radical ideographic-radical))
+  (map-char-family
+   (lambda (sc)
+     (if (or (null radical)
+	     (eq (or (get-char-attribute sc 'ideographic-radical)
+		     (char-ideographic-radical sc radical t))
+		 radical))
+	 (let ((ret (or (encode-char sc 'ideograph-daikanwa 'defined-only)
+			(encode-char sc '=daikanwa-rev2 'defined-only))))
+	   (if ret
+	       (if (or (eq sc char)
+		       (and (null (get-char-attribute char '<-subsumptive))
+			    (null (get-char-attribute char '<-denotational))))
+		   ret
+		 (list ret 0))
+	     (or (get-char-attribute sc 'morohashi-daikanwa)
+		 (if (setq ret (char-feature sc '=>daikanwa))
+		     (cond ((consp ret) ret)
+			   ((or (get-char-attribute char '<-subsumptive)
+				(get-char-attribute char '<-denotational))
+			    (list ret 0))
+			   (t ret))))))))
+   char))
 
 ;;;###autoload
 (defun char-ucs (char)