X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=593e21ce76ad6b7e9078a459aeae8b5dd95b758e;hb=ed79ca47b430a917433a5f779c37c2f7c8ee11ba;hp=c43599003702a516344cdced4b976754d7462cd0;hpb=bb963ef59d8854a32dbce271350be1c4906939a4;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index c435990..593e21c 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 (get-char-attribute
-				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))))
-	(get-char-attribute 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,39 +170,53 @@
 
 ;;;###autoload
 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
-  (let (ret)
-    (catch 'tag
-      (dolist (domain domains)
-	(if (and (setq ret (or (get-char-attribute
-				char
-				(intern
-				 (format "%s@%s"
-					 'ideographic-radical domain)))
-			       (get-char-attribute
-				char 'ideographic-radical)))
-		 (or (eq ret radical)
-		     (null radical))
-		 (setq ret (get-char-attribute
-			    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)
   (let (ret)
-    (or (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)
-	(catch 'tag
+    (or (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 (plist-get cell :strokes)))))
+	(char-ideographic-strokes-from-domains
+	 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)
@@ -155,34 +252,62 @@
 ;;;###autoload
 (defun update-ideograph-radical-table ()
   (interactive)
-  (let (ret radical script)
-    (dolist (domain char-db-feature-domains)
+  (let (ret radical script dest)
+    (dolist (feature
+	     (cons 'ideographic-radical
+		   (mapcar
+		    (lambda (domain)
+		      (intern (format "%s@%s" 'ideographic-radical domain)))
+		    char-db-feature-domains)))
       (map-char-attribute
-       (lambda (char radical)
-	 (when (and radical
-		    (or (null (setq script (get-char-attribute char 'script)))
-			(memq 'Ideograph script)))
-	   (unless (memq char
-			 (setq ret
-			       (aref ideograph-radical-chars-vector radical)))
-	     (char-ideographic-strokes char)
-	     (aset ideograph-radical-chars-vector radical
-		   (cons char ret))))
+       (lambda (chr radical)
+	 (dolist (char (append
+			(if (setq ret
+				  (get-char-attribute chr '<-subsumptive))
+			    (progn
+			      (setq dest nil)
+			      (dolist (pc ret)
+				(unless (eq (get-char-attribute
+					     pc 'ideographic-radical)
+					    radical)
+				  (setq dest (cons pc dest))))
+			      dest)
+			  (list chr))
+			(let ((rest (append
+				     (get-char-attribute chr '<-identical)
+				     (get-char-attribute chr '->denotational)))
+			      pc)
+			  (setq dest nil)
+			  (while rest
+			    (setq pc (car rest))
+			    (if (memq pc dest)
+				(setq rest (cdr rest))
+			      (setq dest (cons pc dest))
+			      (setq rest
+				    (append (cdr rest)
+					    (get-char-attribute
+					     pc '<-identical)
+					    (get-char-attribute
+					     pc '->denotational)))))
+			  dest)))
+	   (when (and radical
+		      (or (eq 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)))
+			  (memq 'Ideograph script)))
+	     (unless (memq char
+			   (setq ret
+				 (aref ideograph-radical-chars-vector
+				       radical)))
+	       (char-ideographic-strokes char)
+	       (aset ideograph-radical-chars-vector radical
+		     (cons char ret)))))
 	 nil)
-       (intern (format "%s@%s" 'ideographic-radical domain))))
-    (map-char-attribute
-     (lambda (char radical)
-       (when (and radical
-		  (or (null (setq script (get-char-attribute char 'script)))
-		      (memq 'Ideograph script)))
-	 (unless (memq char
-		       (setq ret
-			     (aref ideograph-radical-chars-vector radical)))
-	   (char-ideographic-strokes char)
-	   (aset ideograph-radical-chars-vector radical
-		 (cons char ret))))
-       nil)
-     'ideographic-radical)
+       feature))
     (map-char-attribute
      (lambda (char data)
        (dolist (cell data)
@@ -236,15 +361,24 @@
 ;;         (t (< a b))))
 
 ;;;###autoload
-(defun char-representative-of-daikanwa (char)
+(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)
 	  (encode-char char '=daikanwa-rev2 'defined-only))
       char
-    (let ((m (get-char-attribute char 'morohashi-daikanwa))
-	  m-m m-s pat)
-      (or (when m
-	    (setq m-m (pop m))
-	    (setq m-s (pop m))
+    (let ((m (char-feature char '=>daikanwa))
+	  m-m m-s pat
+	  ;;scs sc ret
+	  )
+      (or (and (integerp m)
+	       (or (decode-char '=daikanwa-rev2 m 'defined-only)
+		   (decode-char 'ideograph-daikanwa m)))
+	  (when (or m
+		    (setq m (get-char-attribute char 'morohashi-daikanwa)))
+	    (setq m-m (car m))
+	    (setq m-s (nth 1 m))
 	    (if (= m-s 0)
 		(or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 		    (decode-char 'ideograph-daikanwa m-m))
@@ -254,7 +388,33 @@
 				      (if (equal pat v)
 					  c))
 				    'morohashi-daikanwa))))
-	  char))))
+	  (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)))
+		     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
@@ -291,22 +451,71 @@
 (defun char-daikanwa-strokes (char &optional radical)
   (unless radical
     (setq radical ideographic-radical))
-  (let ((drc (char-representative-of-daikanwa char)))
-    (if (= (char-ideographic-radical drc radical)
-	   (char-ideographic-radical char radical))
+  (let ((drc (char-representative-of-daikanwa char radical))
+	(r (char-ideographic-radical char radical)))
+    (if (or (null r)
+	    (= (char-ideographic-radical drc radical) r))
 	(setq char drc)))
   (char-ideographic-strokes char radical '(daikanwa)))
 
 ;;;###autoload
-(defun char-daikanwa (char)
-  (or (encode-char char 'ideograph-daikanwa 'defined-only)
-      (encode-char char '=daikanwa-rev2 'defined-only)
-      (get-char-attribute char 'morohashi-daikanwa)))
+(defun char-daikanwa (char &optional radical checked)
+  (unless radical
+    (setq radical ideographic-radical))
+  (if (or (null radical)
+          (eq (or (get-char-attribute char 'ideographic-radical)
+                  (char-ideographic-radical char radical t))
+              radical))
+      (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
+                     (encode-char char '=daikanwa-rev2 'defined-only)
+                     (get-char-attribute char 'morohashi-daikanwa))))
+        (or ret
+	    (and (setq ret (get-char-attribute char '=>daikanwa))
+		 (if (numberp ret)
+		     (list ret 0)
+		   (append ret '(0))))
+	    (unless (memq char checked)
+	      (catch 'tag
+		(let ((rest
+		       (append (get-char-attribute char '->subsumptive)
+			       (get-char-attribute char '->denotational)))
+		      (i 0)
+		      sc)
+		  (setq checked (cons char checked))
+		  (while rest
+		    (setq sc (car rest))
+		    (if (setq ret (char-daikanwa sc radical checked))
+			(throw 'tag ret))
+		    (setq checked (cons sc checked)
+			  rest (cdr rest)
+			  i (1+ i)))
+		  (setq rest (get-char-attribute char '->identical))
+		  (while rest
+		    (setq sc (car rest))
+		    (when (setq ret (char-daikanwa sc radical checked))
+		      (throw 'tag
+			     (if (numberp ret)
+				 (list ret 0)
+			       (append ret (list i)))))
+		    (setq checked (cons sc checked)
+			  rest (cdr rest)))
+		  (setq rest
+			(append (get-char-attribute char '<-subsumptive)
+				(get-char-attribute char '<-denotational)))
+		  (while rest
+		    (setq sc (car rest))
+		    (when (setq ret (char-daikanwa sc radical checked))
+		      (throw 'tag
+			     (if (numberp ret)
+				 (list ret 0 i)
+			       (append ret (list i)))))
+		    (setq checked (cons sc checked)
+			  rest (cdr rest))))))))))
 
 ;;;###autoload
 (defun char-ucs (char)
   (or (encode-char char '=ucs 'defined-only)
-      (get-char-attribute char '=>ucs)))
+      (char-feature char '=>ucs)))
 
 (defun char-id (char)
   (logand (char-int char) #x3FFFFFFF))
@@ -325,27 +534,35 @@
 	 (sort (copy-list (aref ideograph-radical-chars-vector radical))
 	       (lambda (a b)
 		 (ideograph-char< a b radical))))
-	attributes ccss)
+	attributes ; ccss
+	)
     (dolist (name (char-attribute-list))
       (unless (memq name char-db-ignored-attributes)
-	(if (find-charset name)
-	    (push name ccss)
-	  (push name attributes))))
+        ;; (if (find-charset name)
+        ;;     (push name ccss)
+	(push name attributes)
+	;; )
+	))
     (setq attributes (sort attributes #'char-attribute-name<)
-	  ccss (sort ccss #'char-attribute-name<))
+	  ;; ccss (sort ccss #'char-attribute-name<)
+	  )
     (aset ideograph-radical-chars-vector radical chars)
     (dolist (char chars)
-      (when (or (not (some (lambda (atr)
-			     (get-char-attribute char atr))
-			   char-db-ignored-attributes))
-		(some (lambda (ccs)
-			(encode-char char ccs 'defined-only))
-		      ccss))
-	(insert-char-data char nil attributes ccss)))))
+      (when ;;(or
+	  (not (some (lambda (atr)
+		       (get-char-attribute char atr))
+		     char-db-ignored-attributes))
+	;; (some (lambda (ccs)
+	;;         (encode-char char ccs 'defined-only))
+	;;       ccss)
+	;;)
+	(insert-char-data char nil attributes ;ccss
+			  )))))
 
 (defun write-ideograph-radical-char-data (radical file)
   (if (file-directory-p file)
-      (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
+      (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
+				'name)))
 	(if (string-match "KANGXI RADICAL " name)
 	    (setq name (capitalize (substring name (match-end 0)))))
 	(setq name (mapconcat (lambda (char)
@@ -357,11 +574,11 @@
 	       (format "Ideograph-R%03d-%s.el" radical name)
 	       file))))
   (with-temp-buffer
-    (insert ";; -*- coding: utf-8-mcs -*-\n")
+    (insert (format ";; -*- coding: %s -*-\n"
+		    char-db-file-coding-system))
     (insert-ideograph-radical-char-data radical)
-    (let ((coding-system-for-write 'utf-8-mcs))
-      (write-region (point-min)(point-max) file)
-      )))
+    (let ((coding-system-for-write char-db-file-coding-system))
+      (write-region (point-min)(point-max) file))))
 
 (defun ideographic-structure= (char1 char2)
   (if (char-ref-p char1)
@@ -404,26 +621,35 @@
 			'ideographic-structure)))
 
 ;;;###autoload
-(defun total-strokes-string< (string1 string2 &optional preferred-domains)
+(defun chise-string< (string1 string2 accessors)
   (let ((len1 (length string1))
 	(len2 (length string2))
 	len
 	(i 0)
 	c1 c2
-	s1 s2)
+	rest func
+	v1 v2)
     (setq len (min len1 len2))
     (catch 'tag
       (while (< i len)
 	(setq c1 (aref string1 i)
 	      c2 (aref string2 i))
-	(setq s1 (or (char-total-strokes c1 preferred-domains)
-		     0)
-	      s2 (or (char-total-strokes c2 preferred-domains)
-		     0))
-	(cond ((< s1 s2)
-	       (throw 'tag t))
-	      ((> s1 s2)
-	       (throw 'tag nil)))
+	(setq rest accessors)
+	(while (and rest
+		    (setq func (car rest))
+		    (setq v1 (funcall func c1)
+			  v2 (funcall func c2))
+		    (eq v1 v2))
+	  (setq rest (cdr rest)))
+	(if v1
+	    (if v2
+		(cond ((< v1 v2)
+		       (throw 'tag t))
+		      ((> v1 v2)
+		       (throw 'tag nil)))
+	      (throw 'tag nil))
+	  (if v2
+	      (throw 'tag t)))
 	(setq i (1+ i)))
       (< len1 len2))))