X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-subr.el;h=5146fac8a1556e1809dfbdf691ccb43e8336dd34;hb=6e19fc71f6c7c22ecc2b1230aed517ad7f756739;hp=1ef2fcdf6857f9f9305ac1fb5ab7a657c79381a9;hpb=298432ac3099f29d2c85b424baa93c4ae8223868;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/utf-2000/ideograph-subr.el b/lisp/utf-2000/ideograph-subr.el
index 1ef2fcd..5146fac 100644
--- 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
 ;;;