X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchise-subr.el;h=c6e968c31bb4de6f02f4d91706e753c67a6292b3;hb=894ed4bd4f1585da110c79b7552b2bc222f47f7c;hp=030c6d6aa50d69aebedc63e32afa9a3ecab36039;hpb=e6760664a726ba310f6a1b7a5ea9196e201a5151;p=chise%2Fxemacs-chise.git.1

diff --git a/lisp/utf-2000/chise-subr.el b/lisp/utf-2000/chise-subr.el
index 030c6d6..c6e968c 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) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-;;   2007, 2008, 2009, 2010 MORIOKA Tomohiko.
+;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
+;;   2010, 2011, 2012, 2013, 2014, 2015 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
@@ -25,9 +25,68 @@
 
 ;;; 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/a jis/b
+	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))
+(defconst charset-id-=>>adobe-japan1-0 (charset-id '=>>adobe-japan1-0))
+(defconst charset-id-=>>adobe-japan1-6 (charset-id '=>>adobe-japan1-6))
+
+(defun charset-id-adobe-japan1-p (id)
+  (or (and (<= charset-id-=adobe-japan1-0 id)
+	   (<= id charset-id-=adobe-japan1-6))
+      (and (<= charset-id-==adobe-japan1-0 id)
+	   (<= id charset-id-==adobe-japan1-6))
+      ;; (and (<= charset-id-=>>>adobe-japan1-0 id)
+      ;;      (<= id charset-id-=>>>adobe-japan1-6))
+      (and (<= charset-id-=>>adobe-japan1-0 id)
+	   (<= id charset-id-=>>adobe-japan1-6))
+      ))
+
+
+;;; @ feature name
+;;;
+
+;;;###autoload
+(defun expand-char-feature-name (feature domain)
+  (if domain
+      (intern (format "%s@%s" feature domain))
+    feature))
+
 ;;;###autoload
 (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)
@@ -65,7 +124,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
@@ -79,10 +138,66 @@
 		   ((< a-ir
 		       b-ir)
 		    ))
+		(cond
+		 ((= a-ir 177)
+		  t)
+		 ((eq kb '=mj)
+		  nil)
+		 ((eq kb '==mj)
+		  nil)
+		 ((eq kb '=>>mj)
+		  nil)
+		 ((and (setq b-id (charset-id kb))
+		       (charset-id-adobe-japan1-p b-id))
+		  nil)
+		 (t)))
+	    (if (setq b-ir (charset-property kb 'iso-ir))
+		(cond
+		 ((= b-ir 177)
+		  nil)
+		 ((eq ka '=mj)
+		  t)
+		 ((eq ka '==mj)
+		  t)
+		 ((eq ka '=>>mj)
+		  t)
+		 ((and (setq a-id (charset-id ka))
+		       (charset-id-adobe-japan1-p a-id))
+		  t)
+		 (t nil))
+	      (cond
+	       ((eq ka '=mj)
+		t)
+	       ((eq ka '==mj)
+		t)
+	       ((eq ka '=>>mj)
 		t)
-	    (if (charset-property kb 'iso-ir)
-		nil
-	      (< (charset-id ka)(charset-id kb)))))
+	       ((and (setq a-id (charset-id ka))
+		     (charset-id-adobe-japan1-p a-id))
+		(cond
+		 ((eq kb '=mj)
+		  nil)
+		 ((eq kb '==mj)
+		  nil)
+		 ((eq kb '=>>mj)
+		  nil)
+		 ((and (setq b-id (charset-id kb))
+		       (charset-id-adobe-japan1-p b-id))
+		  (< a-id b-id))
+		 (t))
+		)
+	       ((eq kb '=mj)
+		nil)
+	       ((eq kb '==mj)
+		nil)
+	       ((eq kb '=>>mj)
+		nil)
+	       ((and (setq b-id (charset-id kb))
+		     (charset-id-adobe-japan1-p b-id))
+		nil)
+	       (t
+		(< (charset-id ka)(charset-id kb))
+		)))))
       nil)
     )
    ((find-charset kb))
@@ -95,6 +210,121 @@
     nil)))
 
 
+;;; @ char feature
+;;;
+
+;;;###autoload
+(defun char-ucs (char)
+  "Return code-point of UCS."
+  (or (encode-char char '=ucs 'defined-only)
+      (char-feature char '=ucs)
+      (char-feature char '=>ucs)))
+
+;;;###autoload
+(defun char-id (char)
+  (logand (char-int char) #x3FFFFFFF))
+
+
+;;; @ char hierarchy
+;;;
+
+;;;###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))))))
+
+
+;;;###autoload
+(defun define-char-before (char-spec next-char)
+  "Define CHAR-SPEC and insert it before NEXT-CHAR." 
+  (let (mother sisters rest)
+    (when (and (or (characterp next-char)
+		   (setq next-char (find-char next-char)))
+	       (setq mother (get-char-attribute next-char '<-subsumptive))
+	       (setq mother (car mother))
+	       (setq sisters (get-char-attribute mother '->subsumptive)))
+      (if (eq (car sisters) next-char)
+	  (setq sisters (cons (define-char char-spec) sisters))
+	(setq rest sisters)
+	(while (and (cdr rest)
+		    (not (eq (nth 1 rest) next-char)))
+	  (setq rest (cdr rest)))
+	(if (null rest)
+	    (setq sisters (cons (define-char char-spec) sisters))
+	  (setcdr rest (cons (define-char char-spec) (cdr rest)))))
+      (put-char-attribute mother '->subsumptive sisters))))
+
+;;;###autoload
+(defun define-char-after (prev-char char-spec)
+  "Define CHAR-SPEC and insert it after PREV-CHAR." 
+  (let (mother sisters rest)
+    (when (and (or (characterp prev-char)
+		   (setq prev-char (find-char prev-char)))
+	       (setq mother (get-char-attribute prev-char '<-subsumptive))
+	       (setq mother (car mother))
+	       (setq sisters (get-char-attribute mother '->subsumptive)))
+      (setq rest sisters)
+      (while (and rest
+		  (not (eq (car rest) prev-char)))
+	(setq rest (cdr rest)))
+      (if (null rest)
+	  (setq sisters (cons (define-char char-spec) sisters))
+	(setcdr rest (cons (define-char char-spec) (cdr rest))))
+      (put-char-attribute mother '->subsumptive sisters))))
+
+
+;;; @ string
+;;;
+
+;;;###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))))
+
+
 ;;; @ end
 ;;;