(g2-UU+5B73): Add `=decomposition@hanyo-denshi'.

[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 2fc4402..70f4171 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
 
 ;;; ideograph-util.el --- Ideographic Character Database utility
 

-;; Copyright (C) 1999,2000,2001,2002,2003,2004 MORIOKA Tomohiko.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
+;;   2009, 2010, 2012, 2014, 2015 MORIOKA Tomohiko.

 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.

@@ -24,241 +25,27 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

+(require 'chise-subr)
+(require 'ideograph-subr)

 (require 'char-db-util)
 
 (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))
 
 
 (defvar ideograph-radical-chars-vector
   (make-vector 215 nil))
 

-(defun char-ideographic-radical (char &optional radical ignore-sisters)
-  (let (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))))
-       (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)
-                   (get-char-attribute char 'kangxi-radical)
-                   (get-char-attribute char 'japanese-radical)
-                   (get-char-attribute char 'korean-radical)))
-         (when ret
-           (put-char-attribute char 'ideographic-radical ret)
-           ret)))))
-
-(defvar ideograph-radical-strokes-vector
-  ;;0  1  2  3  4  5  6  7  8  9
-  [nil 1  1  1  1  1  1  2  2  2
-    2  2  2  2  2  2  2  2  2  2
-    2  2  2  2  2  2  2  2  2  2
-    3  3  3  3  3  3  3  3  3  3
-    3  3  3  3  3  3  3  3  3  3
-    3  3  3  3  3  3  3  3  3  3
-    3  4  4  4  3  4  4  4  4  4
-    4  4  4  4  4  4  4  4  4  4
-    4  4  4  4  4  3  4  4  4  4
-    4  4  4  4  3  5  4  5  5  5
-    ;; 100
-    5  5  5  5  5  5  5  5  5  5
-    5  5  5  5  5  5  5  5  6  6
-    6  6  6  6  6  6  6  6  6  6
-    4  6  6  6  6  6  6  6  6  6
-    4  6  6  6  6  6  6  7  7  7
-    7  7  7  7  7  7  7  7  7  7
-    7  7  4  3  7  7  7  8  7  8
-    3  8  8  8  8  8  9  9  9  9
-    9  9  9  9  8  9  9 10 10 10
-   10 10 10 10 10 11 11 11 11 11
-   ;; 200
-   11 12 12 12 12 13 13 13 13 14
-   14 15 16 16 17])
-
-;;;###autoload
-(defun char-ideographic-strokes-from-domains (char domains &optional radical)
-  (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)
-  (let (ret)
-    (or (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 (plist-get cell :strokes)))))
-       (char-ideographic-strokes-from-domains
-        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)
-                  (get-char-attribute char 'japanese-strokes)
-                  (get-char-attribute char 'korean-strokes)
-                  (let ((r (char-ideographic-radical char))
-                        (ts (get-char-attribute char 'total-strokes)))
-                    (if (and r ts)
-                        (- ts (aref ideograph-radical-strokes-vector r))))
-                  )))
-         (when strokes
-           (put-char-attribute char 'ideographic-strokes strokes)
-           strokes)))))
-
-;;;###autoload
-(defun char-total-strokes-from-domains (char domains)
-  (let (ret)
-    (catch 'tag
-      (dolist (domain domains)
-       (if (setq ret (get-char-attribute
-                      char
-                      (intern
-                       (format "%s@%s"
-                               'total-strokes domain))))
-           (throw 'tag ret))))))
-
-;;;###autoload
-(defun char-total-strokes (char &optional preferred-domains)
-  (or (char-total-strokes-from-domains char preferred-domains)
-      (get-char-attribute char 'total-strokes)
-      (char-total-strokes-from-domains char char-db-feature-domains)))

 
 ;;;###autoload
 (defun update-ideograph-radical-table ()
   (interactive)
 
 ;;;###autoload
 (defun update-ideograph-radical-table ()
   (interactive)

-  (let (ret radical script dest)
+  (let (ret rret radical script dest)

     (dolist (feature
             (cons 'ideographic-radical
     (dolist (feature
             (cons 'ideographic-radical

-                  (mapcar
-                   (lambda (domain)
-                     (intern (format "%s@%s" 'ideographic-radical domain)))
-                   char-db-feature-domains)))
+                  (progn
+                    (dolist (feature (char-attribute-list))
+                      (if (string-match "^ideographic-radical@[^@*]+$"
+                                        (symbol-name feature))
+                          (setq dest (cons feature dest))))
+                    dest)))

       (map-char-attribute
        (lambda (chr radical)
         (dolist (char (append
       (map-char-attribute
        (lambda (chr radical)
         (dolist (char (append

@@ -270,7 +57,11 @@
                                (unless (eq (get-char-attribute
                                             pc 'ideographic-radical)
                                            radical)
                                (unless (eq (get-char-attribute
                                             pc 'ideographic-radical)
                                            radical)

-                                 (setq dest (cons pc dest))))
+                                 (if (setq rret
+                                           (get-char-attribute
+                                            pc '<-subsumptive))
+                                     (setq ret (append ret rret))
+                                   (setq dest (cons pc dest)))))

                              dest)
                          (list chr))
                        (let ((rest (append
                              dest)
                          (list chr))
                        (let ((rest (append

@@ -323,30 +114,38 @@
                   (cons char ret))))))
      'ideographic-)))
 
                   (cons char ret))))))
      'ideographic-)))
 

+

 (defun int-list< (a b)
   (if (numberp (car a))
       (if (numberp (car b))
          (if (= (car a) (car b))
              (int-list< (cdr a)(cdr b))
            (< (car a) (car b)))
 (defun int-list< (a b)
   (if (numberp (car a))
       (if (numberp (car b))
          (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)))
 
 (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))
           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)
             t
           (int-list< a b)))
        (t

-        (if (eq (car b) 'ho)
+        (if (eq (car-safe b) 'ho)

             t
           (int-list< a b)))))
 
             t
           (int-list< a b)))))
 

@@ -360,61 +159,86 @@
 ;;         ((null b) t)
 ;;         (t (< a b))))
 
 ;;         ((null b) t)
 ;;         (t (< a b))))
 

+(defvar ideographic-radical nil)
+

 ;;;###autoload
 (defun char-representative-of-daikanwa (char &optional radical
 ;;;###autoload
 (defun char-representative-of-daikanwa (char &optional radical

-                                            ignore-default dont-inherit)
+                                            ignore-default checked)

   (unless radical
     (setq radical ideographic-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
-         ;;scs sc ret
-         )
-      (or (and (integerp m)
-              (or (decode-char '=daikanwa-rev2 m 'defined-only)
-                  (decode-char 'ideograph-daikanwa m)))
-         (when (or m
-                   (setq m (get-char-attribute char 'morohashi-daikanwa)))
-           (setq m-m (car m))
-           (setq m-s (nth 1 m))
-           (if (= m-s 0)
-               (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
-                   (decode-char 'ideograph-daikanwa m-m))
-             (when m
-               (setq pat (list m-m m-s))
-               (map-char-attribute (lambda (c v)
-                                     (if (equal pat v)
-                                         c))
-                                   'morohashi-daikanwa))))
-         (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)))
-                    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)))))
+  (if (or (null radical)
+          (eq (or (get-char-attribute char 'ideographic-radical)
+                  (char-ideographic-radical char radical t))
+              radical))
+      (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
+                    (encode-char char '=daikanwa/+p 'defined-only)
+                     (encode-char char '=daikanwa/+2p 'defined-only)
+                     (encode-char char '=daikanwa/ho 'defined-only)
+                     )))
+       (or (and ret char)
+           (if (setq ret (get-char-attribute char 'morohashi-daikanwa))
+               (let ((m-m (car ret))
+                     (m-s (nth 1 ret))
+                     pat)
+                 (if (= m-s 0)
+                     (or (decode-char '=daikanwa@rev2 m-m 'defined-only)
+                         (decode-char '=daikanwa m-m))
+                   (or (cond ((eq m-m 'ho)
+                              (decode-char '=daikanwa/ho m-s))
+                             ((eq m-s 1)
+                              (decode-char '=daikanwa/+p m-m))
+                             ((eq m-s 2)
+                              (decode-char '=daikanwa/+2p m-m)))
+                       (progn
+                         (setq pat (list m-m m-s))
+                         (map-char-attribute (lambda (c v)
+                                               (if (equal pat v)
+                                                   c))
+                                             'morohashi-daikanwa))))))
+            (and (setq ret (get-char-attribute char '=>daikanwa))
+                (if (numberp ret)
+                    (or (decode-char '=daikanwa@rev2 ret 'defined-only)
+                        (decode-char '=daikanwa ret))
+                  (map-char-attribute (lambda (c v)
+                                        (if (equal ret v)
+                                            char))
+                                      'morohashi-daikanwa)))
+           (unless (memq char checked)
+             (catch 'tag
+               (let ((rest
+                      (append (get-char-attribute char '->subsumptive)
+                              (get-char-attribute char '->denotational)))
+                     (i 0)
+                     sc)
+                 (setq checked (cons char checked))
+                 (while rest
+                   (setq sc (car rest))
+                   (if (setq ret (char-representative-of-daikanwa
+                                  sc radical t checked))
+                       (throw 'tag ret))
+                   (setq checked (cons sc checked)
+                         rest (cdr rest)
+                         i (1+ i)))
+                 (setq rest (get-char-attribute char '->identical))
+                 (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))))))
+           (unless ignore-default
+             char)))))

 
 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
   (catch 'tag
 
 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
   (catch 'tag

@@ -446,42 +270,69 @@
              testers (cdr testers)
              defaulters (cdr defaulters))))))
 
              testers (cdr testers)
              defaulters (cdr defaulters))))))
 

-(defvar ideographic-radical nil)
+(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))
   (let ((drc (char-representative-of-daikanwa char radical))
        (r (char-ideographic-radical char radical)))
 
 (defun char-daikanwa-strokes (char &optional radical)
   (unless radical
     (setq radical ideographic-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))
+    (if (and drc
+            (or (null r)
+                (= (char-ideographic-radical drc radical) r)))

        (setq char drc)))
   (char-ideographic-strokes char radical '(daikanwa)))
 
 ;;;###autoload
        (setq char drc)))
   (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)
           (eq (or (get-char-attribute char 'ideographic-radical)
   (unless radical
     (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))
               radical))

-      (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
-                     (encode-char char '=daikanwa-rev2 'defined-only)
-                     (get-char-attribute char 'morohashi-daikanwa)
-                     (get-char-attribute char '=>daikanwa))))
-        (or ret
+      (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
+                     ;; (encode-char char '=daikanwa 'defined-only)
+                     (get-char-attribute char 'morohashi-daikanwa))))
+       (unless ret
+         (cond
+          ((setq ret (encode-char char '=daikanwa/+p 'defined-only))
+           (setq ret (list ret 1)))
+          ((setq ret (encode-char char '=daikanwa/+2p 'defined-only))
+           (setq ret (list ret 2)))
+          ((setq ret (encode-char char '=daikanwa/ho 'defined-only))
+           (setq ret (list 'ho 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 -10)
+                  (append ret '(-10))))

            (unless (memq char checked)
            (unless (memq char checked)

+             (unless depth
+               (setq depth 0))

              (catch 'tag
                (let ((rest
              (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)
                      (i 0)

-                     sc)
+                     sc lnum)

                  (setq checked (cons char checked))
                  (while rest
                    (setq sc (car rest))
                  (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)
                        (throw 'tag ret))
                    (setq checked (cons sc checked)
                          rest (cdr rest)

@@ -489,7 +340,7 @@
                  (setq rest (get-char-attribute char '->identical))
                  (while rest
                    (setq sc (car rest))
                  (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)
                      (throw 'tag
                             (if (numberp ret)
                                 (list ret 0)

@@ -497,34 +348,43 @@
                    (setq checked (cons sc checked)
                          rest (cdr rest)))
                  (setq rest
                    (setq checked (cons sc checked)
                          rest (cdr rest)))
                  (setq 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)
+                        ))

                  (while rest
                    (setq sc (car rest))
                  (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)
                      (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))))))))))
 
                    (setq checked (cons sc checked)
                          rest (cdr rest))))))))))
 

-;;;###autoload
-(defun char-ucs (char)
-  (or (encode-char char '=ucs 'defined-only)
-      (char-feature char '=>ucs)))
-
-(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
 (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
 
 (defun insert-ideograph-radical-char-data (radical)
   (let ((chars

@@ -617,39 +477,6 @@
                              char)))
                        'ideographic-structure)))
 
                              char)))
                        'ideographic-structure)))
 

-;;;###autoload
-(defun chise-string< (string1 string2 accessors)
-  (let ((len1 (length string1))
-       (len2 (length string2))
-       len
-       (i 0)
-       c1 c2
-       rest func
-       v1 v2)
-    (setq len (min len1 len2))
-    (catch 'tag
-      (while (< i len)
-       (setq c1 (aref string1 i)
-             c2 (aref string2 i))
-       (setq rest accessors)
-       (while (and rest
-                   (setq func (car rest))
-                   (setq v1 (funcall func c1)
-                         v2 (funcall func c2))
-                   (eq v1 v2))
-         (setq rest (cdr rest)))
-       (if v1
-           (if v2
-               (cond ((< v1 v2)
-                      (throw 'tag t))
-                     ((> v1 v2)
-                      (throw 'tag nil)))
-             (throw 'tag nil))
-         (if v2
-             (throw 'tag t)))
-       (setq i (1+ i)))
-      (< len1 len2))))
-

 
 (provide 'ideograph-util)
 
 
 (provide 'ideograph-util)