;;; chise-subr.el --- basic lisp subroutines for XEmacs CHISE
;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
-;; 2010, 2011, 2012 MORIOKA Tomohiko.
+;; 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.
;; (unless (memq domain dest)
;; (push domain dest))))))
;; (sort dest #'string<))
- '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
+ '(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
;;;
(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)
)
((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
((< 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))
(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