X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchise-subr.el;h=a9dce30d816b2e853e6f0888a3b5063b4b628737;hb=e44a80304a399b79902c9d5811906251a1d8d057;hp=79484cd8d23c586f3f02e2b44d3257651c327a9d;hpb=cd5c1737479f857ff257ccc6dcd3b55ff3946074;p=chise%2Fxemacs-chise.git-

diff --git a/lisp/utf-2000/chise-subr.el b/lisp/utf-2000/chise-subr.el
index 79484cd..a9dce30 100644
--- a/lisp/utf-2000/chise-subr.el
+++ b/lisp/utf-2000/chise-subr.el
@@ -1,7 +1,7 @@
 ;;; chise-subr.el --- basic lisp subroutines for XEmacs CHISE
 
 ;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
-;;   2010, 2011 MORIOKA Tomohiko.
+;;   2010, 2011, 2012 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
@@ -26,8 +26,28 @@
 ;;; Code:
 
 (defvar char-db-feature-domains
+  ;; (let (dest str len ret domain)
+  ;;   (dolist (fn (char-attribute-list))
+  ;;     (setq str (symbol-name fn))
+  ;;     (when (string-match "^ideographic-radical@\\([^*]+\\)$" str)
+  ;;       (setq domain (substring str (match-beginning 1)))
+  ;;       (when (> (setq len (length domain)) 0)
+  ;;         (setq ret (read-from-string domain))
+  ;;         (when (= (cdr ret) len)
+  ;;           (setq domain (car ret))
+  ;;           (unless (memq domain dest)
+  ;;             (push domain dest))))))
+  ;;   (sort dest #'string<))
   '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
-	jis-x0212 jis-x0213 cdp shinjigen misc unknown))
+	jis-x0212 jis-x0213 cdp shinjigen
+	r030 r140 misc unknown))
+
+(defconst charset-id-=adobe-japan1-0 (charset-id '=adobe-japan1-0))
+(defconst charset-id-=adobe-japan1-6 (charset-id '=adobe-japan1-6))
+(defconst charset-id-=>>>adobe-japan1-0 (charset-id '=>>>adobe-japan1-0))
+(defconst charset-id-=>>>adobe-japan1-6 (charset-id '=>>>adobe-japan1-6))
+(defconst charset-id-=>>adobe-japan1-0 (charset-id '=>>adobe-japan1-0))
+(defconst charset-id-=>>adobe-japan1-6 (charset-id '=>>adobe-japan1-6))
 
 
 ;;; @ feature name
@@ -43,6 +63,17 @@
 (defun char-attribute-name< (ka kb)
   "Return t if symbol KA is less than KB in feature-name sorting order."
   (cond
+   ((and (symbolp ka)
+	 (eq (aref (symbol-name ka) 0) ?*))
+    (cond ((and (symbolp kb)
+		(eq (aref (symbol-name kb) 0) ?*))
+	   (string< (symbol-name ka)
+		    (symbol-name kb))
+	   ))
+    )
+   ((and (symbolp kb)
+	 (eq (aref (symbol-name kb) 0) ?*))
+    t)
    ((eq '->denotational kb)
     t)
    ((eq '->subsumptive kb)
@@ -80,7 +111,7 @@
     )
    ((find-charset ka)
     (if (find-charset kb)
-	(let (a-ir b-ir)
+	(let (a-ir b-ir a-id b-id)
 	  (if (setq a-ir (charset-property ka 'iso-ir))
 	      (if (setq b-ir (charset-property kb 'iso-ir))
 		  (cond
@@ -94,10 +125,64 @@
 		   ((< a-ir
 		       b-ir)
 		    ))
-		t)
-	    (if (charset-property kb 'iso-ir)
-		nil
-	      (< (charset-id ka)(charset-id kb)))))
+		(cond
+		 ((= a-ir 177)
+		  t)
+		 ((and (setq b-id (charset-id kb))
+		       (or (and (<= charset-id-=adobe-japan1-0 b-id)
+				(<= b-id charset-id-=adobe-japan1-6))
+			   (and (<= charset-id-=>>>adobe-japan1-0 b-id)
+				(<= b-id charset-id-=>>>adobe-japan1-6))
+			   (and (<= charset-id-=>>adobe-japan1-0 b-id)
+				(<= b-id charset-id-=>>adobe-japan1-6))
+			   ))
+		  nil)
+		 (t)))
+	    (if (setq b-ir (charset-property kb 'iso-ir))
+		(cond
+		 ((= b-ir 177)
+		  nil)
+		 ((and (setq a-id (charset-id ka))
+		       (or (and (<= charset-id-=adobe-japan1-0 a-id)
+				(<= a-id charset-id-=adobe-japan1-6))
+			   (and (<= charset-id-=>>>adobe-japan1-0 a-id)
+				(<= a-id charset-id-=>>>adobe-japan1-6))
+			   (and (<= charset-id-=>>adobe-japan1-0 a-id)
+				(<= a-id charset-id-=>>adobe-japan1-6))
+			   ))
+		  t)
+		 (t nil))
+	      (cond
+	       ((and (setq a-id (charset-id ka))
+		     (or (and (<= charset-id-=adobe-japan1-0 a-id)
+			      (<= a-id charset-id-=adobe-japan1-6))
+			 (and (<= charset-id-=>>>adobe-japan1-0 a-id)
+			      (<= a-id charset-id-=>>>adobe-japan1-6))
+			 (and (<= charset-id-=>>adobe-japan1-0 a-id)
+			      (<= a-id charset-id-=>>adobe-japan1-6))
+			 ))
+		(if (and (setq b-id (charset-id kb))
+			 (or (and (<= charset-id-=adobe-japan1-0 b-id)
+				  (<= b-id charset-id-=adobe-japan1-6))
+			     (and (<= charset-id-=>>>adobe-japan1-0 b-id)
+				  (<= b-id charset-id-=>>>adobe-japan1-6))
+			     (and (<= charset-id-=>>adobe-japan1-0 b-id)
+				  (<= b-id charset-id-=>>adobe-japan1-6))
+			     ))
+		    (< a-id b-id)
+		  t))
+	       ((and (setq b-id (charset-id kb))
+		     (or (and (<= charset-id-=adobe-japan1-0 b-id)
+			      (<= b-id charset-id-=adobe-japan1-6))
+			 (and (<= charset-id-=>>>adobe-japan1-0 b-id)
+			      (<= b-id charset-id-=>>>adobe-japan1-6))
+			 (and (<= charset-id-=>>adobe-japan1-0 b-id)
+			      (<= b-id charset-id-=>>adobe-japan1-6))
+			 ))
+		nil)
+	       (t
+		(< (charset-id ka)(charset-id kb))
+		)))))
       nil)
     )
    ((find-charset kb))