Reformatted.

[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 b9b17a8..70f4171 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,
 ;;; ideograph-util.el --- Ideographic Character Database utility
 
 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,

-;;   2009 MORIOKA Tomohiko.
+;;   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.

@@ -25,176 +25,14 @@
 
 ;;; 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))
-
-;;;###autoload
-(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))
-

 
 (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)))
-
-;;;###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 (char-feature
-                      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)
-      (char-feature char 'total-strokes)
-      (char-total-strokes-from-domains char char-db-feature-domains)))

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

@@ -276,6 +114,7 @@
                   (cons char ret))))))
      'ideographic-)))
 
                   (cons char ret))))))
      'ideographic-)))
 

+

 (defun int-list< (a b)
   (if (numberp (car a))
       (if (numberp (car b))
 (defun int-list< (a b)
   (if (numberp (car a))
       (if (numberp (car b))

@@ -331,25 +170,35 @@
           (eq (or (get-char-attribute char 'ideographic-radical)
                   (char-ideographic-radical char radical t))
               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))))
+      (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 (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))))
+                     (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)
             (and (setq ret (get-char-attribute char '=>daikanwa))
                 (if (numberp ret)

-                    (or (decode-char '=daikanwa-rev2 ret 'defined-only)
-                        (decode-char 'ideograph-daikanwa ret))
+                    (or (decode-char '=daikanwa@rev2 ret 'defined-only)
+                        (decode-char '=daikanwa ret))

                   (map-char-attribute (lambda (c v)
                                         (if (equal ret v)
                                             char))
                   (map-char-attribute (lambda (c v)
                                         (if (equal ret v)
                                             char))

@@ -421,13 +270,20 @@
              testers (cdr testers)
              defaulters (cdr defaulters))))))
 
              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))
   (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)))
 
        (setq char drc)))
   (char-ideographic-strokes char radical '(daikanwa)))
 

@@ -437,11 +293,19 @@
     (setq radical ideographic-radical))
   (if (or (null radical)
           (eq (or (get-char-attribute char 'ideographic-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)
+      (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
+                     ;; (encode-char char '=daikanwa 'defined-only)

                      (get-char-attribute char 'morohashi-daikanwa))))
                      (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)
         (or (if ret
                (if depth
                    (if (integerp ret)

@@ -450,15 +314,18 @@
                  ret))
            (and (setq ret (get-char-attribute char '=>daikanwa))
                 (if (numberp ret)
                  ret))
            (and (setq ret (get-char-attribute char '=>daikanwa))
                 (if (numberp ret)

-                    (list ret 0 8)
-                  (append ret '(8))))
+                    (list ret -10)
+                  (append ret '(-10))))

            (unless (memq char checked)
              (unless depth
                (setq depth 0))
              (catch 'tag
                (let ((rest
            (unless (memq char checked)
              (unless depth
                (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))
                      (i 0)
                      sc lnum)
                  (setq checked (cons char checked))

@@ -481,8 +348,11 @@
                    (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))
                    (when (setq ret (char-daikanwa sc radical checked depth))
                  (while rest
                    (setq sc (car rest))
                    (when (setq ret (char-daikanwa sc radical checked depth))

@@ -496,15 +366,6 @@
                    (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)))
-
-;;;###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))
 (defun char-ideographic-strokes-diff (char &optional radical)
   (if (or (get-char-attribute char '<-subsumptive)
          (get-char-attribute char '<-denotational))

@@ -616,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)