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, 2013, 2014, 2015, 2020, 2021, 2022, 2023 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/a jis/b
  42         jis-x0212 jis-x0213 cdp shinjigen mj
  43         r001 r007 r030 r053 r055 r074 r130 r140 r159 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 (defconst charset-id-=>>adobe-japan1-0 (charset-id '=>>adobe-japan1-0))
  52 (defconst charset-id-=>>adobe-japan1-6 (charset-id '=>>adobe-japan1-6))
  53
  54 (defun charset-id-adobe-japan1-p (id)
  55   (or (and (<= charset-id-=adobe-japan1-0 id)
  56            (<= id charset-id-=adobe-japan1-6))
  57       (and (<= charset-id-==adobe-japan1-0 id)
  58            (<= id charset-id-==adobe-japan1-6))
  59       ;; (and (<= charset-id-=>>>adobe-japan1-0 id)
  60       ;;      (<= id charset-id-=>>>adobe-japan1-6))
  61       (and (<= charset-id-=>>adobe-japan1-0 id)
  62            (<= id charset-id-=>>adobe-japan1-6))
  63       ))
  64
  65
  66 ;;; @ feature name
  67 ;;;
  68
  69 ;;;###autoload
  70 (defun expand-char-feature-name (feature domain)
  71   (if domain
  72       (intern (format "%s@%s" feature domain))
  73     feature))
  74
  75 ;;;###autoload
  76 (defun char-attribute-name< (ka kb)
  77   "Return t if symbol KA is less than KB in feature-name sorting order."
  78   (cond
  79    ((and (symbolp ka)
  80          (eq (aref (symbol-name ka) 0) ?*))
  81     (cond ((and (symbolp kb)
  82                 (eq (aref (symbol-name kb) 0) ?*))
  83            (string< (symbol-name ka)
  84                     (symbol-name kb))
  85            ))
  86     )
  87    ((and (symbolp kb)
  88          (eq (aref (symbol-name kb) 0) ?*))
  89     t)
  90    ((eq '->denotational kb)
  91     t)
  92    ((eq '->subsumptive kb)
  93     (not (eq '->denotational ka)))
  94    ((eq '->denotational ka)
  95     nil)
  96    ((eq '->subsumptive ka)
  97     nil)
  98    ((and (symbolp ka)
  99          (string-match "^->" (symbol-name ka)))
 100     (cond ((and (symbolp kb)
 101                 (string-match "^->" (symbol-name kb)))
 102            (string< (symbol-name ka)
 103                     (symbol-name kb))
 104            ))
 105     )
 106    ((and (symbolp kb)
 107          (string-match "^->" (symbol-name kb)))
 108     t)
 109    ((and (symbolp ka)
 110          (string-match "^<-" (symbol-name ka)))
 111     (cond ((symbolp kb)
 112            (cond ((string-match "^<-" (symbol-name kb))
 113                   (string< (symbol-name ka)
 114                            (symbol-name kb))
 115                   )
 116                  ;; ((string-match "^->" (symbol-name kb))
 117                  ;;  t)
 118                  )))
 119     )
 120    ((and (symbolp kb)
 121          (string-match "^<-" (symbol-name kb)))
 122     t
 123     ;; (not (string-match "^->" (symbol-name ka)))
 124     )
 125    ((find-charset ka)
 126     (if (find-charset kb)
 127         (let (a-ir b-ir a-id b-id)
 128           (if (setq a-ir (charset-property ka 'iso-ir))
 129               (if (setq b-ir (charset-property kb 'iso-ir))
 130                   (cond
 131                    ((= a-ir b-ir)
 132                     (< (charset-id ka)(charset-id kb))
 133                     )
 134                    ((= a-ir 177)
 135                     t)
 136                    ((= b-ir 177)
 137                     nil)
 138                    ((< a-ir
 139                        b-ir)
 140                     ))
 141                 (cond
 142                  ((= a-ir 177)
 143                   t)
 144                  ((eq kb '=mj)
 145                   nil)
 146                  ((eq kb '==mj)
 147                   nil)
 148                  ((eq kb '=>>mj)
 149                   nil)
 150                  ((and (setq b-id (charset-id kb))
 151                        (charset-id-adobe-japan1-p b-id))
 152                   nil)
 153                  (t)))
 154             (if (setq b-ir (charset-property kb 'iso-ir))
 155                 (cond
 156                  ((= b-ir 177)
 157                   nil)
 158                  ((eq ka '=mj)
 159                   t)
 160                  ((eq ka '==mj)
 161                   t)
 162                  ((eq ka '=>>mj)
 163                   t)
 164                  ((and (setq a-id (charset-id ka))
 165                        (charset-id-adobe-japan1-p a-id))
 166                   t)
 167                  (t nil))
 168               (cond
 169                ((eq ka '=mj)
 170                 (not (eq kb '=mj))
 171                 )
 172                ((eq ka '==mj)
 173                 (not (or (eq kb '=mj)
 174                          (eq kb '=>>mj)
 175                          (eq kb '==mj)))
 176                 )
 177                ((eq ka '=>>mj)
 178                 (not (or (eq kb '=mj)
 179                          (eq kb '=>>mj)))
 180                 )
 181                ((and (setq a-id (charset-id ka))
 182                      (charset-id-adobe-japan1-p a-id))
 183                 (cond
 184                  ((eq kb '=mj)
 185                   nil)
 186                  ((eq kb '==mj)
 187                   nil)
 188                  ((eq kb '=>>mj)
 189                   nil)
 190                  ((and (setq b-id (charset-id kb))
 191                        (charset-id-adobe-japan1-p b-id))
 192                   (< a-id b-id))
 193                  (t))
 194                 )
 195                ((eq kb '=mj)
 196                 nil)
 197                ((eq kb '==mj)
 198                 (or (eq ka '=mj)
 199                     (eq ka '=>>mj)
 200                     (eq ka '==mj))
 201                 )
 202                ((eq kb '=>>mj)
 203                 (or (eq ka '=mj)
 204                     (eq ka '=>>mj))
 205                 )
 206                ((and (setq b-id (charset-id kb))
 207                      (charset-id-adobe-japan1-p b-id))
 208                 nil)
 209                (t
 210                 (< (charset-id ka)(charset-id kb))
 211                 )))))
 212       nil)
 213     )
 214    ((find-charset kb))
 215    ((symbolp ka)
 216     (cond ((symbolp kb)
 217            (string< (symbol-name ka)
 218                     (symbol-name kb)))
 219           (t)))
 220    ((symbolp kb)
 221     nil)))
 222
 223
 224 ;;; @ char feature
 225 ;;;
 226
 227 ;;;###autoload
 228 (defun char-ucs (char)
 229   "Return code-point of UCS."
 230   (or (encode-char char '=ucs 'defined-only)
 231       (char-feature char '=ucs)
 232       (char-feature char '=>ucs)))
 233
 234 ;;;###autoload
 235 (defun char-id (char)
 236   (logand (char-int char) #x3FFFFFFF))
 237
 238
 239 ;;; @ char hierarchy
 240 ;;;
 241
 242 ;;;###autoload
 243 (defun char-ucs-chars (character)
 244   "Return list of UCS abstract characters unified by CHARACTER."
 245   (let (ucs dest)
 246     (if (and (setq ucs (encode-char character '=ucs))
 247              (not (and (<= #x2E80 ucs)(<= ucs #x2EF3)))
 248              (null (get-char-attribute character '=>ucs*)))
 249         (setq dest (list character)))
 250     (dolist (c (mapcan #'char-ucs-chars
 251                        (get-char-attribute character '->subsumptive)))
 252       (setq dest (adjoin c dest)))
 253     (dolist (c (mapcan #'char-ucs-chars
 254                        (get-char-attribute character '->denotational)))
 255       (setq dest (adjoin c dest)))
 256     (dolist (c (mapcan #'char-ucs-chars
 257                        (get-char-attribute character '->denotational@component)))
 258       (setq dest (adjoin c dest)))
 259     dest))
 260
 261
 262 ;;;###autoload
 263 (defun map-char-family (function char &optional ignore-sisters)
 264   (let ((rest (list char))
 265         ret checked)
 266     (catch 'tag
 267       (while rest
 268         (unless (memq (car rest) checked)
 269           (if (setq ret (funcall function (car rest)))
 270               (throw 'tag ret))
 271           (setq checked (cons (car rest) checked)
 272                 rest (append rest
 273                              (get-char-attribute (car rest) '->subsumptive)
 274                              (get-char-attribute (car rest) '->denotational)
 275                              (get-char-attribute (car rest) '->identical)))
 276           (unless ignore-sisters
 277             (setq rest (append rest
 278                                (get-char-attribute (car rest) '<-subsumptive)
 279                                (get-char-attribute (car rest) '<-denotational)))))
 280         (setq rest (cdr rest))))))
 281
 282
 283 ;;;###autoload
 284 (defun define-char-before (char-spec next-char)
 285   "Define CHAR-SPEC and insert it before NEXT-CHAR."
 286   (let (mother sisters rest)
 287     (when (and (or (characterp next-char)
 288                    (setq next-char (find-char next-char)))
 289                (setq mother (get-char-attribute next-char '<-subsumptive))
 290                (setq mother (car mother))
 291                (setq sisters (get-char-attribute mother '->subsumptive)))
 292       (if (eq (car sisters) next-char)
 293           (setq sisters (cons (define-char char-spec) sisters))
 294         (setq rest sisters)
 295         (while (and (cdr rest)
 296                     (not (eq (nth 1 rest) next-char)))
 297           (setq rest (cdr rest)))
 298         (if (null rest)
 299             (setq sisters (cons (define-char char-spec) sisters))
 300           (setcdr rest (cons (define-char char-spec) (cdr rest)))))
 301       (put-char-attribute mother '->subsumptive sisters))))
 302
 303 ;;;###autoload
 304 (defun define-char-after (prev-char char-spec)
 305   "Define CHAR-SPEC and insert it after PREV-CHAR."
 306   (let (mother sisters rest)
 307     (when (and (or (characterp prev-char)
 308                    (setq prev-char (find-char prev-char)))
 309                (setq mother (get-char-attribute prev-char '<-subsumptive))
 310                (setq mother (car mother))
 311                (setq sisters (get-char-attribute mother '->subsumptive)))
 312       (setq rest sisters)
 313       (while (and rest
 314                   (not (eq (car rest) prev-char)))
 315         (setq rest (cdr rest)))
 316       (if (null rest)
 317           (setq sisters (cons (define-char char-spec) sisters))
 318         (setcdr rest (cons (define-char char-spec) (cdr rest))))
 319       (put-char-attribute mother '->subsumptive sisters))))
 320
 321
 322 ;;; @ string
 323 ;;;
 324
 325 ;;;###autoload
 326 (defun chise-string< (string1 string2 accessors)
 327   (let ((len1 (length string1))
 328         (len2 (length string2))
 329         len
 330         (i 0)
 331         c1 c2
 332         rest func
 333         v1 v2)
 334     (setq len (min len1 len2))
 335     (catch 'tag
 336       (while (< i len)
 337         (setq c1 (aref string1 i)
 338               c2 (aref string2 i))
 339         (setq rest accessors)
 340         (while (and rest
 341                     (setq func (car rest))
 342                     (setq v1 (funcall func c1)
 343                           v2 (funcall func c2))
 344                     (eq v1 v2))
 345           (setq rest (cdr rest)))
 346         (if v1
 347             (if v2
 348                 (cond ((< v1 v2)
 349                        (throw 'tag t))
 350                       ((> v1 v2)
 351                        (throw 'tag nil)))
 352               (throw 'tag nil))
 353           (if v2
 354               (throw 'tag t)))
 355         (setq i (1+ i)))
 356       (< len1 len2))))
 357
 358
 359 ;;; @ end
 360 ;;;
 361
 362 (provide 'chise-subr)
 363
 364 ;;; chise-subr.el ends here