1 ;;; chise-subr.el --- basic lisp subroutines for XEmacs CHISE
3 ;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
4 ;; 2010, 2011, 2012, 2013, 2014, 2015 MORIOKA Tomohiko.
6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
9 ;; This file is part of XEmacs CHISE.
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.
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.
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.
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
43 r030 r140 misc unknown))
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))
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))
70 (defun expand-char-feature-name (feature domain)
72 (intern (format "%s@%s" feature domain))
76 (defun char-attribute-name< (ka kb)
77 "Return t if symbol KA is less than KB in feature-name sorting order."
80 (eq (aref (symbol-name ka) 0) ?*))
81 (cond ((and (symbolp kb)
82 (eq (aref (symbol-name kb) 0) ?*))
83 (string< (symbol-name ka)
88 (eq (aref (symbol-name kb) 0) ?*))
90 ((eq '->denotational kb)
92 ((eq '->subsumptive kb)
93 (not (eq '->denotational ka)))
94 ((eq '->denotational ka)
96 ((eq '->subsumptive ka)
99 (string-match "^->" (symbol-name ka)))
100 (cond ((and (symbolp kb)
101 (string-match "^->" (symbol-name kb)))
102 (string< (symbol-name ka)
107 (string-match "^->" (symbol-name kb)))
110 (string-match "^<-" (symbol-name ka)))
112 (cond ((string-match "^<-" (symbol-name kb))
113 (string< (symbol-name ka)
116 ;; ((string-match "^->" (symbol-name kb))
121 (string-match "^<-" (symbol-name kb)))
123 ;; (not (string-match "^->" (symbol-name 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))
132 (< (charset-id ka)(charset-id kb))
150 ((and (setq b-id (charset-id kb))
151 (charset-id-adobe-japan1-p b-id))
154 (if (setq b-ir (charset-property kb 'iso-ir))
164 ((and (setq a-id (charset-id ka))
165 (charset-id-adobe-japan1-p a-id))
175 ((and (setq a-id (charset-id ka))
176 (charset-id-adobe-japan1-p a-id))
184 ((and (setq b-id (charset-id kb))
185 (charset-id-adobe-japan1-p b-id))
195 ((and (setq b-id (charset-id kb))
196 (charset-id-adobe-japan1-p b-id))
199 (< (charset-id ka)(charset-id kb))
206 (string< (symbol-name ka)
217 (defun char-ucs (char)
218 "Return code-point of UCS."
219 (or (encode-char char '=ucs 'defined-only)
220 (char-feature char '=ucs)
221 (char-feature char '=>ucs)))
224 (defun char-id (char)
225 (logand (char-int char) #x3FFFFFFF))
232 (defun map-char-family (function char &optional ignore-sisters)
233 (let ((rest (list char))
237 (unless (memq (car rest) checked)
238 (if (setq ret (funcall function (car rest)))
240 (setq checked (cons (car rest) checked)
242 (get-char-attribute (car rest) '->subsumptive)
243 (get-char-attribute (car rest) '->denotational)
244 (get-char-attribute (car rest) '->identical)))
245 (unless ignore-sisters
248 (if (setq ret (get-char-attribute
249 (car rest) '<-subsumptive))
251 (if (setq ret (get-char-attribute
252 (car rest) '<-denotational))
255 (setq rest (cdr rest))))))
259 (defun define-char-before (char-spec next-char)
260 "Define CHAR-SPEC and insert it before NEXT-CHAR."
261 (let (mother sisters rest)
262 (when (and (or (characterp next-char)
263 (setq next-char (find-char next-char)))
264 (setq mother (get-char-attribute next-char '<-subsumptive))
265 (setq mother (car mother))
266 (setq sisters (get-char-attribute mother '->subsumptive)))
267 (if (eq (car sisters) next-char)
268 (setq sisters (cons (define-char char-spec) sisters))
270 (while (and (cdr rest)
271 (not (eq (nth 1 rest) next-char)))
272 (setq rest (cdr rest)))
274 (setq sisters (cons (define-char char-spec) sisters))
275 (setcdr rest (cons (define-char char-spec) (cdr rest)))))
276 (put-char-attribute mother '->subsumptive sisters))))
279 (defun define-char-after (prev-char char-spec)
280 "Define CHAR-SPEC and insert it after PREV-CHAR."
281 (let (mother sisters rest)
282 (when (and (or (characterp prev-char)
283 (setq prev-char (find-char prev-char)))
284 (setq mother (get-char-attribute prev-char '<-subsumptive))
285 (setq mother (car mother))
286 (setq sisters (get-char-attribute mother '->subsumptive)))
289 (not (eq (car rest) prev-char)))
290 (setq rest (cdr rest)))
292 (setq sisters (cons (define-char char-spec) sisters))
293 (setcdr rest (cons (define-char char-spec) (cdr rest))))
294 (put-char-attribute mother '->subsumptive sisters))))
301 (defun chise-string< (string1 string2 accessors)
302 (let ((len1 (length string1))
303 (len2 (length string2))
309 (setq len (min len1 len2))
312 (setq c1 (aref string1 i)
314 (setq rest accessors)
316 (setq func (car rest))
317 (setq v1 (funcall func c1)
318 v2 (funcall func c2))
320 (setq rest (cdr rest)))
337 (provide 'chise-subr)
339 ;;; chise-subr.el ends here