projects / chise / xemacs-chise.git- / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
update.
[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 44c5f04..b9b17a8 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 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.
@@ -32,6 +33,7 @@
       (intern (format "%s@%s" feature domain))
     feature))
 
       (intern (format "%s@%s" feature domain))
     feature))
 
+;;;###autoload
 (defun map-char-family (function char &optional ignore-sisters)
   (let ((rest (list char))
        ret checked)
 (defun map-char-family (function char &optional ignore-sisters)
   (let ((rest (list char))
        ret checked)
@@ -70,34 +72,7 @@
                                       feature domain))
                                  (char-feature ch feature))))
               (throw 'tag ret))))))
                                       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)))))
-  )
+   char ignore-sisters))
 
 
 (defvar ideograph-radical-chars-vector
 
 
 (defvar ideograph-radical-chars-vector
@@ -173,35 +148,7 @@
   (if radical
       (get-char-feature-from-domains char 'ideographic-strokes domains
                                     'ideographic-radical 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)))))
-  )
+    (get-char-feature-from-domains char 'ideographic-strokes domains)))
 
 ;;;###autoload
 (defun char-ideographic-strokes (char &optional radical preferred-domains)
 
 ;;;###autoload
 (defun char-ideographic-strokes (char &optional radical preferred-domains)
@@ -236,7 +183,7 @@
   (let (ret)
     (catch 'tag
       (dolist (domain domains)
   (let (ret)
     (catch 'tag
       (dolist (domain domains)
-       (if (setq ret (get-char-attribute
+       (if (setq ret (char-feature
                       char
                       (intern
                        (format "%s@%s"
                       char
                       (intern
                        (format "%s@%s"
@@ -246,19 +193,21 @@
 ;;;###autoload
 (defun char-total-strokes (char &optional preferred-domains)
   (or (char-total-strokes-from-domains char preferred-domains)
 ;;;###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-feature char 'total-strokes)
       (char-total-strokes-from-domains char char-db-feature-domains)))
 
 ;;;###autoload
 (defun update-ideograph-radical-table ()
   (interactive)
       (char-total-strokes-from-domains char char-db-feature-domains)))
 
 ;;;###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 +219,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
@@ -329,24 +282,31 @@
          (if (= (car a) (car b))
              (int-list< (cdr a)(cdr b))
            (< (car a) (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 +320,76 @@
 ;;         ((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 'ideograph-daikanwa 'defined-only)
+                     (encode-char char '=daikanwa-rev2 '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 'ideograph-daikanwa m-m))
+                   (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 'ideograph-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,8 +421,6 @@
              testers (cdr testers)
              defaulters (cdr defaulters))))))
 
              testers (cdr testers)
              defaulters (cdr defaulters))))))
 
-(defvar ideographic-radical nil)
-
 (defun char-daikanwa-strokes (char &optional radical)
   (unless radical
     (setq radical ideographic-radical))
 (defun char-daikanwa-strokes (char &optional radical)
   (unless radical
     (setq radical ideographic-radical))
@@ -459,7 +432,7 @@
   (char-ideographic-strokes char radical '(daikanwa)))
 
 ;;;###autoload
   (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)
   (unless radical
     (setq radical ideographic-radical))
   (if (or (null radical)
@@ -468,31 +441,39 @@
               radical))
       (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
                      (encode-char char '=daikanwa-rev2 'defined-only)
               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
+                     (get-char-attribute char 'morohashi-daikanwa))))
+        (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 8)
+                  (append ret '(8))))
            (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)))
                      (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))
-                   (when (setq ret (char-daikanwa sc radical checked))
-                     (throw 'tag
-                            (if (numberp ret)
-                                (list ret 0 i)
-                              (append ret (list i)))))
+                   (if (setq ret (char-daikanwa sc radical checked
+                                                (1- depth)))
+                       (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))
                    (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-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)
@@ -500,12 +481,18 @@
                    (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)))
                  (while rest
                    (setq sc (car rest))
                  (while rest
                    (setq sc (car rest))
-                   (if (setq ret (char-daikanwa sc radical checked))
-                       (throw 'tag ret))
+                   (when (setq ret (char-daikanwa sc radical checked depth))
+                     (throw 'tag
+                            (if (numberp ret)
+                                (list ret 0 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))))))))))
 
@@ -514,17 +501,29 @@
   (or (encode-char char '=ucs 'defined-only)
       (char-feature char '=>ucs)))
 
   (or (encode-char char '=ucs 'defined-only)
       (char-feature char '=>ucs)))
 
+;;;###autoload
 (defun char-id (char)
   (logand (char-int char) #x3FFFFFFF))
 
 (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