From 369a9c2670a253577328eb8188c54cba96ca43f2 Mon Sep 17 00:00:00 2001
From: tomo <tomo>
Date: Wed, 26 Jun 2002 02:58:24 +0000
Subject: [PATCH] (char-attributes-poly<): New function.
 (char-daikanwa-strokes): Likewise. (char-daikanwa):
 Likewise. (char-ucs): Likewise. (char-id): Likewise.
 (ideograph-char<): New implementation [use
 `char-attributes-poly<'].
 (insert-ideograph-radical-char-data): Refer
 `char-db-ignored-attributes'.

---
 lisp/utf-2000/ideograph-util.el |  141 ++++++++++++++++++++++-----------------
 1 file changed, 79 insertions(+), 62 deletions(-)

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index 097d33f..5e80f57 100644
--- a/lisp/utf-2000/ideograph-util.el
+++ b/lisp/utf-2000/ideograph-util.el
@@ -1,6 +1,6 @@
 ;;; ideograph-util.el --- Ideographic Character Database utility
 
-;; Copyright (C) 1999,2000,2001 MORIOKA Tomohiko.
+;; Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
@@ -128,6 +128,16 @@
 	     t
 	   (int-list< a b)))))
 
+;; (defun nil=-int< (a b)
+;;   (cond ((null a) nil)
+;;         ((null b) nil)
+;;         (t (< a b))))
+
+;; (defun nil>-int< (a b)
+;;   (cond ((null a) nil)
+;;         ((null b) t)
+;;         (t (< a b))))
+
 (defun char-representative-of-daikanwa (char)
   (if (get-char-attribute char 'ideograph-daikanwa)
       char
@@ -146,76 +156,83 @@
 				    'morohashi-daikanwa))))
 	  char))))
 
+(defun char-attributes-poly< (c1 c2 accessors testers defaulters)
+  (catch 'tag
+    (let (a1 a2 accessor tester dm)
+      (while (and accessors testers)
+	(setq accessor (car accessors)
+	      tester (car testers)
+	      dm (car defaulters))
+	(when (and accessor tester)
+	  (setq a1 (funcall accessor c1)
+		a2 (funcall accessor c2))
+	  (cond ((null a1)
+		 (if a2
+		     (cond ((eq dm '<)
+			    (throw 'tag t))
+			   ((eq dm '>)
+			    (throw 'tag nil)))))
+		((null a2)
+		 (cond ((eq dm '<)
+			(throw 'tag nil))
+		       ((eq dm '>)
+			(throw 'tag t))))
+		(t
+		 (cond ((funcall tester a1 a2)
+			(throw 'tag t))
+		       ((funcall tester a2 a1)
+			(throw 'tag nil))))))
+	(setq accessors (cdr accessors)
+	      testers (cdr testers)
+	      defaulters (cdr defaulters))))))
+
+(defun char-daikanwa-strokes (char)
+  (let ((drc (char-representative-of-daikanwa char)))
+    (char-ideographic-strokes
+     (if (= (get-char-attribute drc 'ideographic-radical)
+	    (get-char-attribute char 'ideographic-radical))
+	 drc
+       char))))
+
+;;;###autoload
+(defun char-daikanwa (char)
+  (or (get-char-attribute char 'ideograph-daikanwa)
+      (get-char-attribute char 'morohashi-daikanwa)))
+
+;;;###autoload
+(defun char-ucs (char)
+  (or (get-char-attribute char 'ucs)
+      (get-char-attribute char '=>ucs)
+      (get-char-attribute char '->ucs)))
+
+(defun char-id (char)
+  (logand (char-int char) #x3FFFFFFF))
+
 (defun ideograph-char< (a 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 (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 (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))
-		    (if a-u
-			(if b-u
-			    (< a-u b-u)
-			  (setq b-u (or (get-char-attribute b '=>ucs)
-					(get-char-attribute b '->ucs)))
-			  (if b-u
-			      (<= a-u b-u)
-			    t))
-		      (setq a-u (or (get-char-attribute a '=>ucs)
-				    (get-char-attribute a '->ucs)))
-		      (if a-u
-			  (if b-u
-			      (< a-u b-u)
-			    (setq b-u (or (get-char-attribute b '=>ucs)
-					  (get-char-attribute b '->ucs)))
-			    (if b-u
-				(< a-u b-u)
-			      t))
-			(if (or b-u (or (get-char-attribute b '=>ucs)
-					(get-char-attribute b '->ucs)))
-			    nil
-			  (< (char-int a)(char-int b)))))))
-	      (< a-s b-s))
-	  t))))
+  (char-attributes-poly<
+   a b
+   '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
+   '(< morohashi-daikanwa< < <)
+   '(> > > >)))
 
 (defun insert-ideograph-radical-char-data (radical)
   (let ((chars
 	 (sort (copy-list (aref ideograph-radical-chars-vector radical))
 	       (function ideograph-char<)))
-	attributes ccs)
+	attributes ccss)
     (dolist (name (char-attribute-list))
-      (if (find-charset name)
-	  (push name ccs)
-	(push name attributes)))
+      (unless (memq name char-db-ignored-attributes)
+	(if (find-charset name)
+	    (push name ccss)
+	  (push name attributes))))
     (setq attributes (sort attributes #'char-attribute-name<)
-	  ccs (sort ccs #'char-attribute-name<))
+	  ccss (sort ccss #'char-attribute-name<))
     (aset ideograph-radical-chars-vector radical chars)
-    (while chars
-      (insert-char-data (car chars) nil attributes ccs)
-      (setq chars (cdr chars)))))
+    (dolist (char chars)
+      (when (some (lambda (ccs)
+		    (encode-char char ccs))
+		  ccss)
+	(insert-char-data char nil attributes ccss)))))
 
 (defun write-ideograph-radical-char-data (radical file)
   (if (file-directory-p file)
-- 
1.7.10.4