X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=b9b17a8873e1ce64b0042fdb2e84d313bd9e6ed6;hb=4f173c8c2e477113ac4b02255c9dbb4f8d0ecbea;hp=662715ea0520b1ee15f2c0688e9d106dc9541e1e;hpb=a4abf52420fd3cd48df025b24bfdcd93c8bd7fde;p=chise%2Fxemacs-chise.git-

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
index 662715e..b9b17a8 100644
--- 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.
@@ -32,6 +33,7 @@
       (intern (format "%s@%s" feature domain))
     feature))
 
+;;;###autoload
 (defun map-char-family (function char &optional ignore-sisters)
   (let ((rest (list char))
 	ret checked)
@@ -280,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)))))
 
@@ -423,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)
@@ -433,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)
@@ -456,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)
@@ -468,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))))))))))
 
@@ -481,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