X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchise-subr.el;h=a9dce30d816b2e853e6f0888a3b5063b4b628737;hb=240e7fff35533d451306a48c6e782e5bddd8f763;hp=61011205db6aeba20c42e607b55e4336a7ad237f;hpb=3ab225ec16f5b5ce5a2eccd23d10e6543c215a6d;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/utf-2000/chise-subr.el b/lisp/utf-2000/chise-subr.el index 6101120..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 MORIOKA Tomohiko. +;; 2010, 2011, 2012 MORIOKA Tomohiko. ;; Author: MORIOKA Tomohiko ;; 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)) @@ -148,6 +233,45 @@ (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 ;;;