update.

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

diff --git a/lisp/utf-2000/ideograph-subr.el b/lisp/utf-2000/ideograph-subr.el
index 1ef2fcd..5146fac 100644 (file)
--- a/lisp/utf-2000/ideograph-subr.el
+++ b/lisp/utf-2000/ideograph-subr.el
@@ -1,7 +1,7 @@
 ;;; ideograph-subr.el --- basic lisp subroutines about Ideographs -*- coding: utf-8-er; -*-
 
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;;   2007, 2008, 2009, 2010 MORIOKA Tomohiko.
+;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2010
+;;   MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
@@ -25,6 +25,9 @@
 
 ;;; Code:
 
+(require 'chise-subr)
+
+
 ;;; @ radical code
 ;;;
 
@@ -66,6 +69,11 @@
               (throw 'tag ret))))))
    char ignore-sisters))
 
+
+;;; @@ radical
+;;;
+
+;;;###autoload
 (defun char-ideographic-radical (char &optional radical ignore-sisters)
   (let (ret)
     (or (if radical
@@ -105,6 +113,94 @@
            ret)))))
 
 
+;;; @@ strokes of non-radical parts
+;;;
+
+;;;###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)))
+
+(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 (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)))))
+
+
+;;; @@ total-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)))
+
+
 ;;; @ end
 ;;;