(expand-char-feature-name): New function.

(map-char-family): New function.
(get-char-feature-from-domains): New function.
(char-ideographic-radical): Add new optional argument
`ignore-sisters'; use `get-char-feature-from-domains'.
(char-ideographic-strokes-from-domains): Use
`get-char-feature-from-domains'.
(char-ideographic-strokes): Simplify code about domains.
(update-ideograph-radical-table): Check ancestors' radicals; prefer to
use `get-char-attribute' to get `ideographic-radical' rather than to
use `char-ideographic-radical'.
(char-representative-of-daikanwa): Add new optional arguments
`ignore-default' and `dont-inherit'; use `map-char-family'.
(char-daikanwa): Use `map-char-family'.

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index a815051..24a3be5 100644 (file)
--- 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 (char-feature
-                               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))))
-       (char-feature 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,24 +170,38 @@
 
 ;;;###autoload
 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
-  (let (ret)
-    (catch 'tag
-      (dolist (domain domains)
-       (if (and (setq ret (or (char-feature
-                               char
-                               (intern
-                                (format "%s@%s"
-                                        'ideographic-radical domain)))
-                              (char-feature
-                               char 'ideographic-radical)))
-                (or (eq ret radical)
-                    (null radical))
-                (setq ret (char-feature
-                           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)
@@ -116,11 +213,10 @@
                         (null radical)))
                (throw 'tag (plist-get cell :strokes)))))
        (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)
-       (char-feature char 'ideographic-strokes)
+        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)
@@ -171,8 +267,9 @@
                            (progn
                              (setq dest nil)
                              (dolist (pc ret)
-                               (unless (get-char-attribute
-                                        pc 'ideographic-radical)
+                               (unless (eq (get-char-attribute
+                                            pc 'ideographic-radical)
+                                           radical)
                                  (setq dest (cons pc dest))))
                              dest)
                          (list chr))
@@ -180,7 +277,9 @@
                        (get-char-attribute chr '->denotational)))
           (when (and radical
                      (or (eq radical
-                             (char-ideographic-radical char 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)))
@@ -247,7 +346,8 @@
 ;;         (t (< a b))))
 
 ;;;###autoload
-(defun char-representative-of-daikanwa (char &optional radical)
+(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)
@@ -255,7 +355,8 @@
       char
     (let ((m (char-feature char '=>daikanwa))
          m-m m-s pat
-         scs sc ret)
+         ;;scs sc ret
+         )
       (or (and (integerp m)
               (or (decode-char '=daikanwa-rev2 m 'defined-only)
                   (decode-char 'ideograph-daikanwa m)))
@@ -272,20 +373,33 @@
                                      (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))
+         (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)
-                             (setq ret nil)))))
-             (setq scs (cdr scs)))
-           ret)
-         char))))
+                                 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
@@ -331,33 +445,30 @@
 
 ;;;###autoload
 (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)
-      (let ((ret (char-feature char '=>daikanwa)))
-       (and ret
-            (if (or (get-char-attribute char '<-subsumptive)
-                    (get-char-attribute char '<-denotational))
-                (list ret 0)
-              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)))))
+  (unless radical
+    (setq radical ideographic-radical))
+  (map-char-family
+   (lambda (sc)
+     (if (or (null radical)
+            (eq (or (get-char-attribute sc 'ideographic-radical)
+                    (char-ideographic-radical sc radical t))
+                radical))
+        (let ((ret (or (encode-char sc 'ideograph-daikanwa 'defined-only)
+                       (encode-char sc '=daikanwa-rev2 'defined-only))))
+          (if ret
+              (if (or (eq sc char)
+                      (and (null (get-char-attribute char '<-subsumptive))
+                           (null (get-char-attribute char '<-denotational))))
+                  ret
+                (list ret 0))
+            (or (get-char-attribute sc 'morohashi-daikanwa)
+                (if (setq ret (char-feature sc '=>daikanwa))
+                    (cond ((consp ret) ret)
+                          ((or (get-char-attribute char '<-subsumptive)
+                               (get-char-attribute char '<-denotational))
+                           (list ret 0))
+                          (t ret))))))))
+   char))
 
 ;;;###autoload
 (defun char-ucs (char)