git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/chise-subr.el

   1 ;;; chise-subr.el --- basic lisp subroutines for XEmacs CHISE
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009, 2010 MORIOKA Tomohiko.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
   8
   9 ;; This file is part of XEmacs CHISE.
  10
  11 ;; XEmacs CHISE is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs CHISE; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 ;;; @ feature name
  29 ;;;
  30
  31 ;;;###autoload
  32 (defun expand-char-feature-name (feature domain)
  33   (if domain
  34       (intern (format "%s@%s" feature domain))
  35     feature))
  36
  37 ;;;###autoload
  38 (defun char-attribute-name< (ka kb)
  39   (cond
  40    ((eq '->denotational kb)
  41     t)
  42    ((eq '->subsumptive kb)
  43     (not (eq '->denotational ka)))
  44    ((eq '->denotational ka)
  45     nil)
  46    ((eq '->subsumptive ka)
  47     nil)
  48    ((and (symbolp ka)
  49          (string-match "^->" (symbol-name ka)))
  50     (cond ((and (symbolp kb)
  51                 (string-match "^->" (symbol-name kb)))
  52            (string< (symbol-name ka)
  53                     (symbol-name kb))
  54            ))
  55     )
  56    ((and (symbolp kb)
  57          (string-match "^->" (symbol-name kb)))
  58     t)
  59    ((and (symbolp ka)
  60          (string-match "^<-" (symbol-name ka)))
  61     (cond ((symbolp kb)
  62            (cond ((string-match "^<-" (symbol-name kb))
  63                   (string< (symbol-name ka)
  64                            (symbol-name kb))
  65                   )
  66                  ;; ((string-match "^->" (symbol-name kb))
  67                  ;;  t)
  68                  )))
  69     )
  70    ((and (symbolp kb)
  71          (string-match "^<-" (symbol-name kb)))
  72     t
  73     ;; (not (string-match "^->" (symbol-name ka)))
  74     )
  75    ((find-charset ka)
  76     (if (find-charset kb)
  77         (let (a-ir b-ir)
  78           (if (setq a-ir (charset-property ka 'iso-ir))
  79               (if (setq b-ir (charset-property kb 'iso-ir))
  80                   (cond
  81                    ((= a-ir b-ir)
  82                     (< (charset-id ka)(charset-id kb))
  83                     )
  84                    ((= a-ir 177)
  85                     t)
  86                    ((= b-ir 177)
  87                     nil)
  88                    ((< a-ir
  89                        b-ir)
  90                     ))
  91                 t)
  92             (if (charset-property kb 'iso-ir)
  93                 nil
  94               (< (charset-id ka)(charset-id kb)))))
  95       nil)
  96     )
  97    ((find-charset kb))
  98    ((symbolp ka)
  99     (cond ((symbolp kb)
 100            (string< (symbol-name ka)
 101                     (symbol-name kb)))
 102           (t)))
 103    ((symbolp kb)
 104     nil)))
 105
 106
 107 ;;; @ char feature
 108 ;;;
 109
 110 ;;;###autoload
 111 (defun char-ucs (char)
 112   (or (encode-char char '=ucs 'defined-only)
 113       (char-feature char '=>ucs)))
 114
 115 ;;;###autoload
 116 (defun char-id (char)
 117   (logand (char-int char) #x3FFFFFFF))
 118
 119
 120 ;;; @ char hierarchy
 121 ;;;
 122
 123 ;;;###autoload
 124 (defun map-char-family (function char &optional ignore-sisters)
 125   (let ((rest (list char))
 126         ret checked)
 127     (catch 'tag
 128       (while rest
 129         (unless (memq (car rest) checked)
 130           (if (setq ret (funcall function (car rest)))
 131               (throw 'tag ret))
 132           (setq checked (cons (car rest) checked)
 133                 rest (append rest
 134                              (get-char-attribute (car rest) '->subsumptive)
 135                              (get-char-attribute (car rest) '->denotational)
 136                              (get-char-attribute (car rest) '->identical)))
 137           (unless ignore-sisters
 138             (setq rest (append rest
 139                                (get-char-attribute (car rest) '<-subsumptive)
 140                                (get-char-attribute (car rest) '<-denotational)))))
 141         (setq rest (cdr rest))))))
 142
 143
 144 ;;; @ string
 145 ;;;
 146
 147 ;;;###autoload
 148 (defun chise-string< (string1 string2 accessors)
 149   (let ((len1 (length string1))
 150         (len2 (length string2))
 151         len
 152         (i 0)
 153         c1 c2
 154         rest func
 155         v1 v2)
 156     (setq len (min len1 len2))
 157     (catch 'tag
 158       (while (< i len)
 159         (setq c1 (aref string1 i)
 160               c2 (aref string2 i))
 161         (setq rest accessors)
 162         (while (and rest
 163                     (setq func (car rest))
 164                     (setq v1 (funcall func c1)
 165                           v2 (funcall func c2))
 166                     (eq v1 v2))
 167           (setq rest (cdr rest)))
 168         (if v1
 169             (if v2
 170                 (cond ((< v1 v2)
 171                        (throw 'tag t))
 172                       ((> v1 v2)
 173                        (throw 'tag nil)))
 174               (throw 'tag nil))
 175           (if v2
 176               (throw 'tag t)))
 177         (setq i (1+ i)))
 178       (< len1 len2))))
 179
 180
 181 ;;; @ end
 182 ;;;
 183
 184 (provide 'chise-subr)
 185
 186 ;;; chise-subr.el ends here