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, 2011, 2012 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   ;; (let (dest str len ret domain)
  30   ;;   (dolist (fn (char-attribute-list))
  31   ;;     (setq str (symbol-name fn))
  32   ;;     (when (string-match "^ideographic-radical@\\([^*]+\\)$" str)
  33   ;;       (setq domain (substring str (match-beginning 1)))
  34   ;;       (when (> (setq len (length domain)) 0)
  35   ;;         (setq ret (read-from-string domain))
  36   ;;         (when (= (cdr ret) len)
  37   ;;           (setq domain (car ret))
  38   ;;           (unless (memq domain dest)
  39   ;;             (push domain dest))))))
  40   ;;   (sort dest #'string<))
  41   '(ucs ucs/compat daikanwa cns gt jis jis/alt jis/a jis/b
  42         jis-x0212 jis-x0213 cdp shinjigen
  43         r030 r140 misc unknown))
  44
  45 (defconst charset-id-=adobe-japan1-0 (charset-id '=adobe-japan1-0))
  46 (defconst charset-id-=adobe-japan1-6 (charset-id '=adobe-japan1-6))
  47 (defconst charset-id-=>>>adobe-japan1-0 (charset-id '=>>>adobe-japan1-0))
  48 (defconst charset-id-=>>>adobe-japan1-6 (charset-id '=>>>adobe-japan1-6))
  49 (defconst charset-id-=>>adobe-japan1-0 (charset-id '=>>adobe-japan1-0))
  50 (defconst charset-id-=>>adobe-japan1-6 (charset-id '=>>adobe-japan1-6))
  51
  52
  53 ;;; @ feature name
  54 ;;;
  55
  56 ;;;###autoload
  57 (defun expand-char-feature-name (feature domain)
  58   (if domain
  59       (intern (format "%s@%s" feature domain))
  60     feature))
  61
  62 ;;;###autoload
  63 (defun char-attribute-name< (ka kb)
  64   "Return t if symbol KA is less than KB in feature-name sorting order."
  65   (cond
  66    ((eq '->denotational kb)
  67     t)
  68    ((eq '->subsumptive kb)
  69     (not (eq '->denotational ka)))
  70    ((eq '->denotational ka)
  71     nil)
  72    ((eq '->subsumptive ka)
  73     nil)
  74    ((and (symbolp ka)
  75          (string-match "^->" (symbol-name ka)))
  76     (cond ((and (symbolp kb)
  77                 (string-match "^->" (symbol-name kb)))
  78            (string< (symbol-name ka)
  79                     (symbol-name kb))
  80            ))
  81     )
  82    ((and (symbolp kb)
  83          (string-match "^->" (symbol-name kb)))
  84     t)
  85    ((and (symbolp ka)
  86          (string-match "^<-" (symbol-name ka)))
  87     (cond ((symbolp kb)
  88            (cond ((string-match "^<-" (symbol-name kb))
  89                   (string< (symbol-name ka)
  90                            (symbol-name kb))
  91                   )
  92                  ;; ((string-match "^->" (symbol-name kb))
  93                  ;;  t)
  94                  )))
  95     )
  96    ((and (symbolp kb)
  97          (string-match "^<-" (symbol-name kb)))
  98     t
  99     ;; (not (string-match "^->" (symbol-name ka)))
 100     )
 101    ((find-charset ka)
 102     (if (find-charset kb)
 103         (let (a-ir b-ir a-id b-id)
 104           (if (setq a-ir (charset-property ka 'iso-ir))
 105               (if (setq b-ir (charset-property kb 'iso-ir))
 106                   (cond
 107                    ((= a-ir b-ir)
 108                     (< (charset-id ka)(charset-id kb))
 109                     )
 110                    ((= a-ir 177)
 111                     t)
 112                    ((= b-ir 177)
 113                     nil)
 114                    ((< a-ir
 115                        b-ir)
 116                     ))
 117                 (cond
 118                  ((= a-ir 177)
 119                   t)
 120                  ((and (setq b-id (charset-id kb))
 121                        (or (and (<= charset-id-=adobe-japan1-0 b-id)
 122                                 (<= b-id charset-id-=adobe-japan1-6))
 123                            (and (<= charset-id-=>>>adobe-japan1-0 b-id)
 124                                 (<= b-id charset-id-=>>>adobe-japan1-6))
 125                            (and (<= charset-id-=>>adobe-japan1-0 b-id)
 126                                 (<= b-id charset-id-=>>adobe-japan1-6))
 127                            ))
 128                   nil)
 129                  (t)))
 130             (if (setq b-ir (charset-property kb 'iso-ir))
 131                 (cond
 132                  ((= b-ir 177)
 133                   nil)
 134                  ((and (setq a-id (charset-id ka))
 135                        (or (and (<= charset-id-=adobe-japan1-0 a-id)
 136                                 (<= a-id charset-id-=adobe-japan1-6))
 137                            (and (<= charset-id-=>>>adobe-japan1-0 a-id)
 138                                 (<= a-id charset-id-=>>>adobe-japan1-6))
 139                            (and (<= charset-id-=>>adobe-japan1-0 a-id)
 140                                 (<= a-id charset-id-=>>adobe-japan1-6))
 141                            ))
 142                   t)
 143                  (t nil))
 144               (cond
 145                ((and (setq a-id (charset-id ka))
 146                      (or (and (<= charset-id-=adobe-japan1-0 a-id)
 147                               (<= a-id charset-id-=adobe-japan1-6))
 148                          (and (<= charset-id-=>>>adobe-japan1-0 a-id)
 149                               (<= a-id charset-id-=>>>adobe-japan1-6))
 150                          (and (<= charset-id-=>>adobe-japan1-0 a-id)
 151                               (<= a-id charset-id-=>>adobe-japan1-6))
 152                          ))
 153                 (if (and (setq b-id (charset-id kb))
 154                          (or (and (<= charset-id-=adobe-japan1-0 b-id)
 155                                   (<= b-id charset-id-=adobe-japan1-6))
 156                              (and (<= charset-id-=>>>adobe-japan1-0 b-id)
 157                                   (<= b-id charset-id-=>>>adobe-japan1-6))
 158                              (and (<= charset-id-=>>adobe-japan1-0 b-id)
 159                                   (<= b-id charset-id-=>>adobe-japan1-6))
 160                              ))
 161                     (< a-id b-id)
 162                   t))
 163                ((and (setq b-id (charset-id kb))
 164                      (or (and (<= charset-id-=adobe-japan1-0 b-id)
 165                               (<= b-id charset-id-=adobe-japan1-6))
 166                          (and (<= charset-id-=>>>adobe-japan1-0 b-id)
 167                               (<= b-id charset-id-=>>>adobe-japan1-6))
 168                          (and (<= charset-id-=>>adobe-japan1-0 b-id)
 169                               (<= b-id charset-id-=>>adobe-japan1-6))
 170                          ))
 171                 nil)
 172                (t
 173                 (< (charset-id ka)(charset-id kb))
 174                 )))))
 175       nil)
 176     )
 177    ((find-charset kb))
 178    ((symbolp ka)
 179     (cond ((symbolp kb)
 180            (string< (symbol-name ka)
 181                     (symbol-name kb)))
 182           (t)))
 183    ((symbolp kb)
 184     nil)))
 185
 186
 187 ;;; @ char feature
 188 ;;;
 189
 190 ;;;###autoload
 191 (defun char-ucs (char)
 192   "Return code-point of UCS."
 193   (or (encode-char char '=ucs 'defined-only)
 194       (char-feature char '=>ucs)))
 195
 196 ;;;###autoload
 197 (defun char-id (char)
 198   (logand (char-int char) #x3FFFFFFF))
 199
 200
 201 ;;; @ char hierarchy
 202 ;;;
 203
 204 ;;;###autoload
 205 (defun map-char-family (function char &optional ignore-sisters)
 206   (let ((rest (list char))
 207         ret checked)
 208     (catch 'tag
 209       (while rest
 210         (unless (memq (car rest) checked)
 211           (if (setq ret (funcall function (car rest)))
 212               (throw 'tag ret))
 213           (setq checked (cons (car rest) checked)
 214                 rest (append rest
 215                              (get-char-attribute (car rest) '->subsumptive)
 216                              (get-char-attribute (car rest) '->denotational)
 217                              (get-char-attribute (car rest) '->identical)))
 218           (unless ignore-sisters
 219             (setq rest (append rest
 220                                (get-char-attribute (car rest) '<-subsumptive)
 221                                (get-char-attribute (car rest) '<-denotational)))))
 222         (setq rest (cdr rest))))))
 223
 224
 225 ;;;###autoload
 226 (defun define-char-before (char-spec next-char)
 227   "Define CHAR-SPEC and insert it before NEXT-CHAR."
 228   (let (mother sisters rest)
 229     (when (and (or (characterp next-char)
 230                    (setq next-char (find-char next-char)))
 231                (setq mother (get-char-attribute next-char '<-subsumptive))
 232                (setq mother (car mother))
 233                (setq sisters (get-char-attribute mother '->subsumptive)))
 234       (if (eq (car sisters) next-char)
 235           (setq sisters (cons (define-char char-spec) sisters))
 236         (setq rest sisters)
 237         (while (and (cdr rest)
 238                     (not (eq (nth 1 rest) next-char)))
 239           (setq rest (cdr rest)))
 240         (if (null rest)
 241             (setq sisters (cons (define-char char-spec) sisters))
 242           (setcdr rest (cons (define-char char-spec) (cdr rest)))))
 243       (put-char-attribute mother '->subsumptive sisters))))
 244
 245 ;;;###autoload
 246 (defun define-char-after (prev-char char-spec)
 247   "Define CHAR-SPEC and insert it after PREV-CHAR."
 248   (let (mother sisters rest)
 249     (when (and (or (characterp prev-char)
 250                    (setq prev-char (find-char prev-char)))
 251                (setq mother (get-char-attribute prev-char '<-subsumptive))
 252                (setq mother (car mother))
 253                (setq sisters (get-char-attribute mother '->subsumptive)))
 254       (setq rest sisters)
 255       (while (and rest
 256                   (not (eq (car rest) prev-char)))
 257         (setq rest (cdr rest)))
 258       (if (null rest)
 259           (setq sisters (cons (define-char char-spec) sisters))
 260         (setcdr rest (cons (define-char char-spec) (cdr rest))))
 261       (put-char-attribute mother '->subsumptive sisters))))
 262
 263
 264 ;;; @ string
 265 ;;;
 266
 267 ;;;###autoload
 268 (defun chise-string< (string1 string2 accessors)
 269   (let ((len1 (length string1))
 270         (len2 (length string2))
 271         len
 272         (i 0)
 273         c1 c2
 274         rest func
 275         v1 v2)
 276     (setq len (min len1 len2))
 277     (catch 'tag
 278       (while (< i len)
 279         (setq c1 (aref string1 i)
 280               c2 (aref string2 i))
 281         (setq rest accessors)
 282         (while (and rest
 283                     (setq func (car rest))
 284                     (setq v1 (funcall func c1)
 285                           v2 (funcall func c2))
 286                     (eq v1 v2))
 287           (setq rest (cdr rest)))
 288         (if v1
 289             (if v2
 290                 (cond ((< v1 v2)
 291                        (throw 'tag t))
 292                       ((> v1 v2)
 293                        (throw 'tag nil)))
 294               (throw 'tag nil))
 295           (if v2
 296               (throw 'tag t)))
 297         (setq i (1+ i)))
 298       (< len1 len2))))
 299
 300
 301 ;;; @ end
 302 ;;;
 303
 304 (provide 'chise-subr)
 305
 306 ;;; chise-subr.el ends here