Sync up with r21-4-22-chise-0_24-jis-x0213-rep-diffs.

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

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index 55add29..bfbfa34 100644 (file)
--- a/lisp/utf-2000/ideograph-util.el
+++ b/lisp/utf-2000/ideograph-util.el
@@ -1,6 +1,7 @@
 ;;; ideograph-util.el --- Ideographic Character Database utility
 
-;; Copyright (C) 1999,2000,2001,2002,2003,2004,2005 MORIOKA Tomohiko.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
+;;   2009 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
@@ -281,24 +282,31 @@
          (if (= (car a) (car b))
              (int-list< (cdr a)(cdr b))
            (< (car a) (car b)))
-       nil)
-    (numberp (car b))))
+       (if (= (car a) 0)
+           nil
+         (< (car a) 0)))
+    (if (numberp (car b))
+       (if (= (car b) 0)
+           t
+         (< 0 (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))
+  (cond ((eq (car-safe a) 'ho)
+        (if (eq (car-safe b) 'ho)
+            (int-list< (cdr-safe a)(cdr-safe b))
           nil))
-       ((numberp (car a))
+       ((or (integerp a)
+            (integerp (car a)))
         (if (eq (car b) 'ho)
             t
           (int-list< a b)))
        (t
-        (if (eq (car b) 'ho)
+        (if (eq (car-safe b) 'ho)
             t
           (int-list< a b)))))
 
@@ -424,7 +432,7 @@
   (char-ideographic-strokes char radical '(daikanwa)))
 
 ;;;###autoload
-(defun char-daikanwa (char &optional radical checked)
+(defun char-daikanwa (char &optional radical checked depth)
   (unless radical
     (setq radical ideographic-radical))
   (if (or (null radical)
@@ -434,22 +442,30 @@
       (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
                      (encode-char char '=daikanwa-rev2 'defined-only)
                      (get-char-attribute char 'morohashi-daikanwa))))
-        (or ret
+        (or (if ret
+               (if depth
+                   (if (integerp ret)
+                       (list ret depth)
+                     (append ret (list depth)))
+                 ret))
            (and (setq ret (get-char-attribute char '=>daikanwa))
                 (if (numberp ret)
-                    (list ret 0)
-                  (append ret '(0))))
+                    (list ret 0 8)
+                  (append ret '(8))))
            (unless (memq char checked)
+             (unless depth
+               (setq depth 0))
              (catch 'tag
                (let ((rest
                       (append (get-char-attribute char '->subsumptive)
                               (get-char-attribute char '->denotational)))
                      (i 0)
-                     sc)
+                     sc lnum)
                  (setq checked (cons char checked))
                  (while rest
                    (setq sc (car rest))
-                   (if (setq ret (char-daikanwa sc radical checked))
+                   (if (setq ret (char-daikanwa sc radical checked
+                                                (1- depth)))
                        (throw 'tag ret))
                    (setq checked (cons sc checked)
                          rest (cdr rest)
@@ -457,7 +473,7 @@
                  (setq rest (get-char-attribute char '->identical))
                  (while rest
                    (setq sc (car rest))
-                   (when (setq ret (char-daikanwa sc radical checked))
+                   (when (setq ret (char-daikanwa sc radical checked depth))
                      (throw 'tag
                             (if (numberp ret)
                                 (list ret 0)
@@ -469,11 +485,14 @@
                                (get-char-attribute char '<-denotational)))
                  (while rest
                    (setq sc (car rest))
-                   (when (setq ret (char-daikanwa sc radical checked))
+                   (when (setq ret (char-daikanwa sc radical checked depth))
                      (throw 'tag
                             (if (numberp ret)
                                 (list ret 0 i)
-                              (append ret (list i)))))
+                              (if (>= (setq lnum (car (last ret))) 0)
+                                  (append ret (list i))
+                                (nconc (butlast ret)
+                                       (list 0 (- lnum) i))))))
                    (setq checked (cons sc checked)
                          rest (cdr rest))))))))))
 
@@ -482,17 +501,29 @@
   (or (encode-char char '=ucs 'defined-only)
       (char-feature char '=>ucs)))
 
+;;;###autoload
 (defun char-id (char)
   (logand (char-int char) #x3FFFFFFF))
 
+(defun char-ideographic-strokes-diff (char &optional radical)
+  (if (or (get-char-attribute char '<-subsumptive)
+         (get-char-attribute char '<-denotational))
+      (let (s ds)
+       (when (and (setq s (char-ideographic-strokes char radical))
+                  (setq ds (char-daikanwa-strokes char radical)))
+         (abs (- s ds))))
+    0))
+
+;;;###autoload
 (defun ideograph-char< (a b &optional radical)
   (let ((ideographic-radical (or radical
                                 ideographic-radical)))
     (char-attributes-poly<
      a b
-     '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
-     '(< morohashi-daikanwa< < <)
-     '(> > > >))))
+     '(char-daikanwa-strokes char-daikanwa char-ucs
+                            char-ideographic-strokes-diff char-id)
+     '(< morohashi-daikanwa< < < <)
+     '(> > > > >))))
 
 (defun insert-ideograph-radical-char-data (radical)
   (let ((chars