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) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
   4 ;;   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 (defvar char-db-feature-domains
  29   '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
  30         jis-x0212 jis-x0213 cdp shinjigen misc unknown))
  31
  32
  33 ;;; @ feature name
  34 ;;;
  35
  36 ;;;###autoload
  37 (defun expand-char-feature-name (feature domain)
  38   (if domain
  39       (intern (format "%s@%s" feature domain))
  40     feature))
  41
  42 ;;;###autoload
  43 (defun char-attribute-name< (ka kb)
  44   "Return t if symbol KA is less than KB in feature-name sorting order."
  45   (cond
  46    ((eq '->denotational kb)
  47     t)
  48    ((eq '->subsumptive kb)
  49     (not (eq '->denotational ka)))
  50    ((eq '->denotational ka)
  51     nil)
  52    ((eq '->subsumptive ka)
  53     nil)
  54    ((and (symbolp ka)
  55          (string-match "^->" (symbol-name ka)))
  56     (cond ((and (symbolp kb)
  57                 (string-match "^->" (symbol-name kb)))
  58            (string< (symbol-name ka)
  59                     (symbol-name kb))
  60            ))
  61     )
  62    ((and (symbolp kb)
  63          (string-match "^->" (symbol-name kb)))
  64     t)
  65    ((and (symbolp ka)
  66          (string-match "^<-" (symbol-name ka)))
  67     (cond ((symbolp kb)
  68            (cond ((string-match "^<-" (symbol-name kb))
  69                   (string< (symbol-name ka)
  70                            (symbol-name kb))
  71                   )
  72                  ;; ((string-match "^->" (symbol-name kb))
  73                  ;;  t)
  74                  )))
  75     )
  76    ((and (symbolp kb)
  77          (string-match "^<-" (symbol-name kb)))
  78     t
  79     ;; (not (string-match "^->" (symbol-name ka)))
  80     )
  81    ((find-charset ka)
  82     (if (find-charset kb)
  83         (let (a-ir b-ir)
  84           (if (setq a-ir (charset-property ka 'iso-ir))
  85               (if (setq b-ir (charset-property kb 'iso-ir))
  86                   (cond
  87                    ((= a-ir b-ir)
  88                     (< (charset-id ka)(charset-id kb))
  89                     )
  90                    ((= a-ir 177)
  91                     t)
  92                    ((= b-ir 177)
  93                     nil)
  94                    ((< a-ir
  95                        b-ir)
  96                     ))
  97                 t)
  98             (if (charset-property kb 'iso-ir)
  99                 nil
 100               (< (charset-id ka)(charset-id kb)))))
 101       nil)
 102     )
 103    ((find-charset kb))
 104    ((symbolp ka)
 105     (cond ((symbolp kb)
 106            (string< (symbol-name ka)
 107                     (symbol-name kb)))
 108           (t)))
 109    ((symbolp kb)
 110     nil)))
 111
 112
 113 ;;; @ char feature
 114 ;;;
 115
 116 ;;;###autoload
 117 (defun char-ucs (char)
 118   "Return code-point of UCS."
 119   (or (encode-char char '=ucs 'defined-only)
 120       (char-feature char '=>ucs)))
 121
 122 ;;;###autoload
 123 (defun char-id (char)
 124   (logand (char-int char) #x3FFFFFFF))
 125
 126
 127 ;;; @ char hierarchy
 128 ;;;
 129
 130 ;;;###autoload
 131 (defun map-char-family (function char &optional ignore-sisters)
 132   (let ((rest (list char))
 133         ret checked)
 134     (catch 'tag
 135       (while rest
 136         (unless (memq (car rest) checked)
 137           (if (setq ret (funcall function (car rest)))
 138               (throw 'tag ret))
 139           (setq checked (cons (car rest) checked)
 140                 rest (append rest
 141                              (get-char-attribute (car rest) '->subsumptive)
 142                              (get-char-attribute (car rest) '->denotational)
 143                              (get-char-attribute (car rest) '->identical)))
 144           (unless ignore-sisters
 145             (setq rest (append rest
 146                                (get-char-attribute (car rest) '<-subsumptive)
 147                                (get-char-attribute (car rest) '<-denotational)))))
 148         (setq rest (cdr rest))))))
 149
 150
 151 ;;; @ string
 152 ;;;
 153
 154 ;;;###autoload
 155 (defun chise-string< (string1 string2 accessors)
 156   (let ((len1 (length string1))
 157         (len2 (length string2))
 158         len
 159         (i 0)
 160         c1 c2
 161         rest func
 162         v1 v2)
 163     (setq len (min len1 len2))
 164     (catch 'tag
 165       (while (< i len)
 166         (setq c1 (aref string1 i)
 167               c2 (aref string2 i))
 168         (setq rest accessors)
 169         (while (and rest
 170                     (setq func (car rest))
 171                     (setq v1 (funcall func c1)
 172                           v2 (funcall func c2))
 173                     (eq v1 v2))
 174           (setq rest (cdr rest)))
 175         (if v1
 176             (if v2
 177                 (cond ((< v1 v2)
 178                        (throw 'tag t))
 179                       ((> v1 v2)
 180                        (throw 'tag nil)))
 181               (throw 'tag nil))
 182           (if v2
 183               (throw 'tag t)))
 184         (setq i (1+ i)))
 185       (< len1 len2))))
 186
 187
 188 ;;; @ end
 189 ;;;
 190
 191 (provide 'chise-subr)
 192
 193 ;;; chise-subr.el ends here