Merge branch 'master' into single-inheritance.

[chise/xemacs-chise.git-] / lisp / utf-2000 / ideograph-util.el

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index 8c59833..6106cbc 100644 (file)
--- a/lisp/utf-2000/ideograph-util.el
+++ b/lisp/utf-2000/ideograph-util.el
@@ -1,7 +1,7 @@
 ;;; ideograph-util.el --- Ideographic Character Database utility
 
 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;;   2009, 2010, 2012 MORIOKA Tomohiko.
+;;   2009, 2010, 2012, 2014, 2015, 2016 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
@@ -53,6 +53,7 @@
                                  (get-char-attribute chr '<-subsumptive))
                            (progn
                              (setq dest nil)
+                             (setq ret (list ret))
                              (dolist (pc ret)
                                (unless (eq (get-char-attribute
                                             pc 'ideographic-radical)
@@ -60,7 +61,7 @@
                                  (if (setq rret
                                            (get-char-attribute
                                             pc '<-subsumptive))
-                                     (setq ret (append ret rret))
+                                     (setq ret (append ret (list rret)))
                                    (setq dest (cons pc dest)))))
                              dest)
                          (list chr))
@@ -227,16 +228,29 @@
                      (throw 'tag ret))
                    (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-representative-of-daikanwa
-                                    sc radical t checked))
-                     (throw 'tag ret))
-                   (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-representative-of-daikanwa
+                  ;;                    sc radical t checked))
+                  ;;     (throw 'tag ret))
+                  ;;   (setq checked (cons sc checked)
+                  ;;         rest (cdr rest)))
+                 (when (setq sc (get-char-attribute char '<-subsumptive))
+                   (if (setq ret (char-representative-of-daikanwa
+                                  sc radical t checked))
+                       (throw 'tag ret)
+                     (setq checked (cons sc checked))
+                     nil))
+                 (when (setq sc (get-char-attribute char '<-denotational))
+                   (if (setq ret (char-representative-of-daikanwa
+                                  sc radical t checked))
+                       (throw 'tag ret)
+                     (setq checked (cons sc checked))
+                     nil))
+                 )))
            (unless ignore-default
              char)))))
 
@@ -270,6 +284,12 @@
              testers (cdr testers)
              defaulters (cdr defaulters))))))
 
+(defun char-daikanwa-radical (char &optional radical ignore-sisters)
+  (or (and (encode-char char '=daikanwa@rev2 'defined-only)
+          (or (get-char-attribute char 'ideographic-radical@daikanwa)
+              (get-char-attribute char 'ideographic-radical)))
+      (char-ideographic-radical char radical ignore-sisters)))
+
 (defun char-daikanwa-strokes (char &optional radical)
   (unless radical
     (setq radical ideographic-radical))
@@ -287,7 +307,7 @@
     (setq radical ideographic-radical))
   (if (or (null radical)
           (eq (or (get-char-attribute char 'ideographic-radical)
-                  (char-ideographic-radical char radical t))
+                  (char-daikanwa-radical char radical t))
               radical))
       (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
                      ;; (encode-char char '=daikanwa 'defined-only)
@@ -315,8 +335,11 @@
                (setq depth 0))
              (catch 'tag
                (let ((rest
-                      (append (get-char-attribute char '->subsumptive)
-                              (get-char-attribute char '->denotational)))
+                      (append
+                       (get-char-attribute char '->subsumptive)
+                       (get-char-attribute char '->denotational)
+                       (get-char-attribute char '->denotational@component)
+                       ))
                      (i 0)
                      sc lnum)
                  (setq checked (cons char checked))
@@ -339,8 +362,15 @@
                    (setq checked (cons sc checked)
                          rest (cdr rest)))
                  (setq rest
-                       (append (get-char-attribute char '<-subsumptive)
-                               (get-char-attribute char '<-denotational)))
+                       (append
+                        (if (setq ret (get-char-attribute
+                                       char '<-subsumptive))
+                            (list ret))
+                        (if (setq ret (get-char-attribute
+                                       char '<-denotational))
+                            (list ret))
+                        (get-char-attribute char '<-denotational@component)
+                        ))
                  (while rest
                    (setq sc (car rest))
                    (when (setq ret (char-daikanwa sc radical checked depth))