Use `=+>ucs@ks' instead of `=>ucs@ks'.

[chise/xemacs-chise.git.1] / lisp / utf-2000 / chise-subr.el

diff --git a/lisp/utf-2000/chise-subr.el b/lisp/utf-2000/chise-subr.el
index 030c6d6..79484cd 100644 (file)
--- 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 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
@@ -25,8 +25,23 @@
 
 ;;; Code:
 
+(defvar char-db-feature-domains
+  '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
+       jis-x0212 jis-x0213 cdp shinjigen misc unknown))
+
+
+;;; @ 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
    ((eq '->denotational kb)
     t)
@@ -95,6 +110,120 @@
     nil)))
 
 
+;;; @ char feature
+;;;
+
+;;;###autoload
+(defun char-ucs (char)
+  "Return code-point of UCS."
+  (or (encode-char char '=ucs 'defined-only)
+      (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
 ;;;