From: tomo <tomo>
Date: Mon, 31 May 2010 14:40:10 +0000 (+0000)
Subject: (get-char-feature-from-domains): New function [moved from
X-Git-Tag: chise-base-0_25^20~15
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=298432ac3099f29d2c85b424baa93c4ae8223868;p=chise%2Fxemacs-chise.git-

(get-char-feature-from-domains): New function [moved from
ideograph-util.el].
(char-ideographic-radical): Ditto.
---

diff --git a/lisp/utf-2000/ideograph-subr.el b/lisp/utf-2000/ideograph-subr.el
index c49794a..1ef2fcd 100644
--- a/lisp/utf-2000/ideograph-subr.el
+++ b/lisp/utf-2000/ideograph-subr.el
@@ -25,7 +25,7 @@
 
 ;;; Code:
 
-;;; @ radical
+;;; @ radical code
 ;;;
 
 (defconst ideographic-radicals
@@ -42,6 +42,69 @@
   (aref ideographic-radicals number))
 
 
+;;; @ char feature
+;;;
+
+(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))
+
+(defun char-ideographic-radical (char &optional radical ignore-sisters)
+  (let (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))))
+	(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)
+		    (get-char-attribute char 'kangxi-radical)
+		    (get-char-attribute char 'japanese-radical)
+		    (get-char-attribute char 'korean-radical)))
+	  (when ret
+	    (put-char-attribute char 'ideographic-radical ret)
+	    ret)))))
+
+
 ;;; @ end
 ;;;