From 55ee61ee14a187c93676a448fa396c6956d32b08 Mon Sep 17 00:00:00 2001
From: tomo <tomo>
Date: Tue, 2 Mar 2004 10:08:22 +0000
Subject: [PATCH] (update-ideograph-radical-table): Fix problems about
 `->subsumptive' and `<-subsumptive'.
 (char-representative-of-daikanwa): Add new optional
 argument `radical'; support `->subsumptive'.
 (char-daikanwa-strokes): Specify radical for
 `char-representative-of-daikanwa'. (char-daikanwa): Add new
 optional argument `radical'; support `->subsumptive'.

---
 lisp/utf-2000/ideograph-util.el |   73 +++++++++++++++++++++++++++++++--------
 1 file changed, 59 insertions(+), 14 deletions(-)

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index 9f384db..a815051 100644
--- a/lisp/utf-2000/ideograph-util.el
+++ b/lisp/utf-2000/ideograph-util.el
@@ -156,7 +156,7 @@
 ;;;###autoload
 (defun update-ideograph-radical-table ()
   (interactive)
-  (let (ret radical script)
+  (let (ret radical script dest)
     (dolist (feature
 	     (cons 'ideographic-radical
 		   (mapcar
@@ -165,13 +165,23 @@
 		    char-db-feature-domains)))
       (map-char-attribute
        (lambda (chr radical)
-	 (dolist (char (cons chr
-			     (append
-			      (get-char-attribute chr '<-identical)
-			      (get-char-attribute chr '->denotational))))
+	 (dolist (char (append
+			(if (setq ret
+				  (get-char-attribute chr '<-subsumptive))
+			    (progn
+			      (setq dest nil)
+			      (dolist (pc ret)
+				(unless (get-char-attribute
+					 pc 'ideographic-radical)
+				  (setq dest (cons pc dest))))
+			      dest)
+			  (list chr))
+			(get-char-attribute chr '<-identical)
+			(get-char-attribute chr '->denotational)))
 	   (when (and radical
-		      (eq radical
-			  (char-ideographic-radical char radical))
+		      (or (eq radical
+			      (char-ideographic-radical char radical))
+			  (null (char-ideographic-radical char)))
 		      (or (null (setq script
 				      (get-char-attribute char 'script)))
 			  (memq 'Ideograph script)))
@@ -237,12 +247,15 @@
 ;;         (t (< a b))))
 
 ;;;###autoload
-(defun char-representative-of-daikanwa (char)
+(defun char-representative-of-daikanwa (char &optional radical)
+  (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 (char-feature char '=>daikanwa))
-	  m-m m-s pat)
+	  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)))
@@ -259,6 +272,19 @@
 				      (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))
+			  (or (null radical)
+			      (eq (char-ideographic-radical ret radical)
+				  radical)
+			      (setq ret nil)))))
+	      (setq scs (cdr scs)))
+	    ret)
 	  char))))
 
 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
@@ -296,14 +322,15 @@
 (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)
+(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)
@@ -312,7 +339,25 @@
 	     (if (or (get-char-attribute char '<-subsumptive)
 		     (get-char-attribute char '<-denotational))
 		 (list ret 0)
-	       ret)))))
+	       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)))))
 
 ;;;###autoload
 (defun char-ucs (char)
-- 
1.7.10.4