X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=5cd7fda25534c22d5c3b801e731a30cc2df5777e;hb=628db25f3a8ff20863ab1a9f0c92504a7c11e2f4;hp=53d8a0cd69120ed76431b4c46ec21fb314a723c5;hpb=f5b3c1875b5ba76f1b9bbaccf738645009a59813;p=chise%2Fxemacs-chise.git

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index 53d8a0c..5cd7fda 100644
--- a/lisp/utf-2000/ideograph-util.el
+++ b/lisp/utf-2000/ideograph-util.el
@@ -86,106 +86,20 @@
 ;;;###autoload
 (defun update-ideograph-radical-table ()
   (interactive)
-  (let ((i #x3400)
-	j
-	char radical
-	(charsets '(japanese-jisx0208-1978
-		    japanese-jisx0208
-		    japanese-jisx0208-1990
-		    japanese-jisx0212
-		    japanese-jisx0213-1
-		    japanese-jisx0213-2
-		    chinese-cns11643-1
-		    chinese-cns11643-2
-		    chinese-cns11643-3
-		    chinese-cns11643-4
-		    chinese-cns11643-5
-		    chinese-cns11643-6
-		    chinese-cns11643-7
-		    korean-ksc5601
-		    chinese-gb2312
-		    chinese-isoir165
-		    chinese-big5-1
-		    chinese-big5-2))
-	ret script)
-    (while (<= i #x9FFF)
-      (setq char (decode-char 'ucs i))
-      (when (and (or (null (setq script (get-char-attribute char 'script)))
-		     (memq 'Ideograph script))
-		 (setq radical (char-ideographic-radical char)))
-	(or (get-char-attribute char 'ucs)
-	    (put-char-attribute char 'ucs i))
-	(char-ideographic-strokes char)
-	(if (not (memq char
+  (let (ret script)
+    (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))))
-	    (aset ideograph-radical-chars-vector radical
-		  (cons char ret))))
-      (setq i (1+ i)))
-    (setq i #x100000)
-    (while (<= i #x10FFFF)
-      (setq char (decode-char 'ucs i))
-      (when (and (or (null (setq script (get-char-attribute char 'script)))
-		     (memq 'Ideograph script))
-		 (setq radical (char-ideographic-radical char)))
-	(if (not (memq char
-		       (setq ret
-			     (aref ideograph-radical-chars-vector radical))))
-	    (aset ideograph-radical-chars-vector radical
-		  (cons char ret))))
-      (setq i (1+ i)))
-    (setq i 1)
-    (while (<= i 66773)
-      (setq char (decode-char 'ideograph-gt i))
-      (if (and (setq radical (char-ideographic-radical char))
-	       (not
-		(memq char
-		      (setq ret
-			    (aref ideograph-radical-chars-vector radical)))))
-	  (aset ideograph-radical-chars-vector radical
-		(cons char ret)))
-      (setq i (1+ i)))
-    (setq i 0)
-    (while (< i 50101)
-      (setq char (decode-char 'ideograph-daikanwa i))
-      (if (and (setq radical (char-ideographic-radical char))
-	       (not
-		(memq char
-		      (setq ret
-			    (aref ideograph-radical-chars-vector radical)))))
-	  (aset ideograph-radical-chars-vector radical
-		(cons char ret)))
-      (setq i (1+ i)))
-    (setq i 0)
-    (while (< i (* 94 60 22))
-      (setq char (decode-char 'mojikyo i))
-      (if (and (setq radical (char-ideographic-radical char))
-	       (not
-		(memq char
-		      (setq ret
-			    (aref ideograph-radical-chars-vector radical)))))
-	  (aset ideograph-radical-chars-vector radical
-		(cons char ret)))
-      (setq i (1+ i)))
-    (while charsets
-      (setq i 33)
-      (while (< i 127)
-	(setq j 33)
-	(while (< j 127)
-	  (setq char (make-char (car charsets) i j))
-	  (if (and (or (null (setq script (get-char-attribute char 'script)))
-		       (memq 'Ideograph script))
-		   (setq radical (char-ideographic-radical char))
-		   (not (memq char
-			      (setq ret
-				    (aref ideograph-radical-chars-vector
-					  radical)))))
-	      (aset ideograph-radical-chars-vector radical
-		    (cons char ret)))
-	  (setq j (1+ j)))
-	(setq i (1+ i)))
-      (setq charsets (cdr charsets)))
-    ))
+			     (aref ideograph-radical-chars-vector radical)))
+	   (char-ideographic-strokes char)
+	   (aset ideograph-radical-chars-vector radical
+		 (cons char ret))))
+       nil)
+     'ideographic-radical)))
 
 (defun int-list< (a b)
   (if (numberp (car a))
@@ -197,6 +111,10 @@
     (numberp (car b))))
 
 (defun morohashi-daikanwa< (a b)
+  (if (integerp a)
+      (setq a (list a)))
+  (if (integerp b)
+      (setq b (list b)))
   (cond ((eq (car a) 'ho)
 	 (if (eq (car b) 'ho)
 	     (int-list< (cdr a)(cdr b))
@@ -210,59 +128,51 @@
 	     t
 	   (int-list< a b)))))
 
+(defun char-representative-of-daikanwa (char)
+  (if (get-char-attribute char 'ideograph-daikanwa)
+      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))
+	    (if (= m-s 0)
+		(decode-char 'ideograph-daikanwa m-m)
+	      (when m
+		(setq pat (list m-m m-s))
+		(map-char-attribute (lambda (c v)
+				      (if (equal pat v)
+					  c))
+				    'morohashi-daikanwa))))
+	  char))))
+
 (defun ideograph-char< (a b)
-  (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
-	(b-m-m (get-char-attribute b 'ideograph-daikanwa))
-	a-m-r b-m-r
-	a-s b-s
-	a-u b-u m ret)
-    (if a-m-m
-	(setq a-s (char-ideographic-strokes a))
-      (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
-      (if a-m-r
-	  (progn
-	    (setq a-m-m (car a-m-r)
-		  a-m-r (cdr a-m-r))
-	    (if (= (car a-m-r) 0)
-		(progn
-		  (setq ret (decode-char 'ideograph-daikanwa a-m-m))
-		  (if (= (get-char-attribute ret 'ideographic-radical)
-			 (get-char-attribute a 'ideographic-radical))
-		      (setq a-s (char-ideographic-strokes ret))
-		    (setq a-s (char-ideographic-strokes a))))
-	      (if (setq m (get-char-attribute a '->mojikyo))
-		  (setq a-s (char-ideographic-strokes
-			     (decode-char 'mojikyo m)))
-		(setq a-s (char-ideographic-strokes a)))))
-	(setq a-s (char-ideographic-strokes a))))
-    (if b-m-m
-	(setq b-s (char-ideographic-strokes b))
-      (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
-      (if b-m-r
-	  (progn
-	    (setq b-m-m (car b-m-r)
-		  b-m-r (cdr b-m-r))
-	    (if (= (car b-m-r) 0)
-		(progn
-		  (setq ret (decode-char 'ideograph-daikanwa b-m-m))
-		  (if (= (get-char-attribute ret 'ideographic-radical)
-			 (get-char-attribute b 'ideographic-radical))
-		      (setq b-s (char-ideographic-strokes ret))
-		    (setq b-s (char-ideographic-strokes b))))
-	      (if (setq m (get-char-attribute b '->mojikyo))
-		  (setq b-s (char-ideographic-strokes
-			     (decode-char 'mojikyo m)))
-		(setq b-s (char-ideographic-strokes b)))))
-	(setq b-s (char-ideographic-strokes b))))
+  (let (a-m b-m a-s b-s a-u b-u ret)
+    (setq ret (char-representative-of-daikanwa a))
+    (setq a-s (char-ideographic-strokes
+	       (if (= (get-char-attribute ret 'ideographic-radical)
+		      (get-char-attribute a 'ideographic-radical))
+		   ret
+		 a)))
+    (setq ret (char-representative-of-daikanwa b))
+    (setq b-s (char-ideographic-strokes
+	       (if (= (get-char-attribute ret 'ideographic-radical)
+		      (get-char-attribute b 'ideographic-radical))
+		   ret
+		 b)))
     (if a-s
 	(if b-s
 	    (if (= a-s b-s)
-		(if a-m-m
-		    (if b-m-m
-			(morohashi-daikanwa< (cons a-m-m a-m-r)
-					     (cons b-m-m b-m-r))
+		(if (setq a-m (or (get-char-attribute a 'ideograph-daikanwa)
+				  (get-char-attribute a 'morohashi-daikanwa)))
+		    (if (setq b-m
+			      (or (get-char-attribute b 'ideograph-daikanwa)
+				  (get-char-attribute b 'morohashi-daikanwa)))
+			(morohashi-daikanwa< a-m b-m)
 		      t)
-		  (if b-m-m
+		  (if (setq b-m
+			    (or (get-char-attribute b 'ideograph-daikanwa)
+				(get-char-attribute b 'morohashi-daikanwa)))
 		      nil
 		    (setq a-u (get-char-attribute a 'ucs)
 			  b-u (get-char-attribute b 'ucs))