1 ;;; ideograph-util.el --- Ideographic Character Database utility
3 ;; Copyright (C) 1999,2000,2001,2002,2003,2004 MORIOKA Tomohiko.
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
8 ;; This file is part of XEmacs CHISE.
10 ;; XEmacs CHISE is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
15 ;; XEmacs CHISE is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs CHISE; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 (require 'char-db-util)
30 (defun expand-char-feature-name (feature domain)
32 (intern (format "%s@%s" feature domain))
35 (defun map-char-family (function char &optional ignore-sisters)
36 (let ((rest (list char))
40 (unless (memq (car rest) checked)
41 (if (setq ret (funcall function (car rest)))
43 (setq checked (cons (car rest) checked)
45 (get-char-attribute (car rest) '->subsumptive)
46 (get-char-attribute (car rest) '->denotational)
47 (get-char-attribute (car rest) '->identical)))
48 (unless ignore-sisters
49 (setq rest (append rest
50 (get-char-attribute (car rest) '<-subsumptive)
51 (get-char-attribute (car rest) '<-denotational)))))
52 (setq rest (cdr rest))))))
54 (defun get-char-feature-from-domains (char feature domains
61 (dolist (domain domains)
62 (if (and (or (null tester)
63 (equal (or (char-feature
64 ch (expand-char-feature-name
66 (char-feature ch tester))
68 (setq ret (or (char-feature
69 ch (expand-char-feature-name
71 (char-feature ch feature))))
74 ;; (let ((rest (list char))
78 ;; (setq char (car rest))
79 ;; (unless (memq char checked)
80 ;; (dolist (domain domains)
81 ;; (if (and (setq ret (char-feature
83 ;; (expand-char-feature-name
86 ;; (equal (or (char-feature
88 ;; (expand-char-feature-name
90 ;; (char-feature char tester))
93 ;; (setq rest (append rest
94 ;; (get-char-attribute char '->subsumptive)
95 ;; (get-char-attribute char '->denotational)
96 ;; (get-char-attribute char '<-subsumptive)
97 ;; (get-char-attribute char '<-denotational))
98 ;; checked (cons char checked)))
99 ;; (setq rest (cdr rest)))))
103 (defvar ideograph-radical-chars-vector
104 (make-vector 215 nil))
106 (defun char-ideographic-radical (char &optional radical ignore-sisters)
109 (get-char-feature-from-domains
110 char 'ideographic-radical (cons nil char-db-feature-domains)
111 'ideographic-radical radical ignore-sisters)
112 (get-char-feature-from-domains
113 char 'ideographic-radical (cons nil char-db-feature-domains)
116 ;; (dolist (domain char-db-feature-domains)
117 ;; (if (and (setq ret (char-feature
121 ;; 'ideographic-radical domain))))
122 ;; (or (eq ret radical)
124 ;; (throw 'tag ret))))
126 (dolist (cell (get-char-attribute char 'ideographic-))
127 (if (and (setq ret (plist-get cell :radical))
131 (get-char-feature-from-domains
132 char 'ideographic-radical (cons nil char-db-feature-domains))
133 ;; (char-feature char 'ideographic-radical)
136 (or (get-char-attribute char 'daikanwa-radical)
137 (get-char-attribute char 'kangxi-radical)
138 (get-char-attribute char 'japanese-radical)
139 (get-char-attribute char 'korean-radical)))
141 (put-char-attribute char 'ideographic-radical ret)
144 (defvar ideograph-radical-strokes-vector
145 ;;0 1 2 3 4 5 6 7 8 9
146 [nil 1 1 1 1 1 1 2 2 2
165 9 9 9 9 8 9 9 10 10 10
166 10 10 10 10 10 11 11 11 11 11
168 11 12 12 12 12 13 13 13 13 14
172 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
174 (get-char-feature-from-domains char 'ideographic-strokes domains
175 'ideographic-radical radical)
176 (get-char-feature-from-domains char 'ideographic-strokes domains))
177 ;; (let ((rest (list char))
181 ;; (setq char (car rest))
182 ;; (unless (memq char checked)
183 ;; (dolist (domain domains)
184 ;; (if (and (setq ret (or (char-feature
186 ;; (expand-char-feature-name
187 ;; 'ideographic-radical domain))
189 ;; char 'ideographic-radical)))
190 ;; (or (eq ret radical)
192 ;; (setq ret (or (char-feature
194 ;; (expand-char-feature-name
195 ;; 'ideographic-strokes domain))
197 ;; char 'ideographic-strokes))))
198 ;; (throw 'tag ret)))
199 ;; (setq rest (append rest
200 ;; (get-char-attribute char '->subsumptive)
201 ;; (get-char-attribute char '->denotational))
202 ;; checked (cons char checked)))
203 ;; (setq rest (cdr rest)))))
207 (defun char-ideographic-strokes (char &optional radical preferred-domains)
210 (dolist (cell (get-char-attribute char 'ideographic-))
211 (if (and (setq ret (plist-get cell :radical))
214 (throw 'tag (plist-get cell :strokes)))))
215 (char-ideographic-strokes-from-domains
216 char (append preferred-domains
218 char-db-feature-domains))
220 (get-char-attribute char 'daikanwa-strokes)
222 (or (get-char-attribute char 'kangxi-strokes)
223 (get-char-attribute char 'japanese-strokes)
224 (get-char-attribute char 'korean-strokes)
225 (let ((r (char-ideographic-radical char))
226 (ts (get-char-attribute char 'total-strokes)))
228 (- ts (aref ideograph-radical-strokes-vector r))))
231 (put-char-attribute char 'ideographic-strokes strokes)
235 (defun char-total-strokes-from-domains (char domains)
238 (dolist (domain domains)
239 (if (setq ret (get-char-attribute
243 'total-strokes domain))))
244 (throw 'tag ret))))))
247 (defun char-total-strokes (char &optional preferred-domains)
248 (or (char-total-strokes-from-domains char preferred-domains)
249 (get-char-attribute char 'total-strokes)
250 (char-total-strokes-from-domains char char-db-feature-domains)))
253 (defun update-ideograph-radical-table ()
255 (let (ret radical script dest)
257 (cons 'ideographic-radical
260 (intern (format "%s@%s" 'ideographic-radical domain)))
261 char-db-feature-domains)))
263 (lambda (chr radical)
264 (dolist (char (append
266 (get-char-attribute chr '<-subsumptive))
270 (unless (eq (get-char-attribute
271 pc 'ideographic-radical)
273 (setq dest (cons pc dest))))
277 (get-char-attribute chr '<-identical)
278 (get-char-attribute chr '->denotational)))
284 (setq rest (cdr rest))
285 (setq dest (cons pc dest))
291 pc '->denotational)))))
295 (or (get-char-attribute
296 char 'ideographic-radical)
297 (char-ideographic-radical char radical)))
298 (null (char-ideographic-radical char)))
299 (or (null (setq script
300 (get-char-attribute char 'script)))
301 (memq 'Ideograph script)))
304 (aref ideograph-radical-chars-vector
306 (char-ideographic-strokes char)
307 (aset ideograph-radical-chars-vector radical
314 (setq radical (plist-get cell :radical))
316 (or (null (setq script (get-char-attribute char 'script)))
317 (memq 'Ideograph script)))
320 (aref ideograph-radical-chars-vector radical)))
321 (char-ideographic-strokes char)
322 (aset ideograph-radical-chars-vector radical
326 (defun int-list< (a b)
327 (if (numberp (car a))
328 (if (numberp (car b))
329 (if (= (car a) (car b))
330 (int-list< (cdr a)(cdr b))
335 (defun morohashi-daikanwa< (a b)
340 (cond ((eq (car a) 'ho)
342 (int-list< (cdr a)(cdr b))
353 ;; (defun nil=-int< (a b)
354 ;; (cond ((null a) nil)
358 ;; (defun nil>-int< (a b)
359 ;; (cond ((null a) nil)
364 (defun char-representative-of-daikanwa (char &optional radical
365 ignore-default dont-inherit)
367 (setq radical ideographic-radical))
368 (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
369 (encode-char char '=daikanwa-rev2 'defined-only))
371 (let ((m (char-feature char '=>daikanwa))
375 (or (and (integerp m)
376 (or (decode-char '=daikanwa-rev2 m 'defined-only)
377 (decode-char 'ideograph-daikanwa m)))
379 (setq m (get-char-attribute char 'morohashi-daikanwa)))
383 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
384 (decode-char 'ideograph-daikanwa m-m))
386 (setq pat (list m-m m-s))
387 (map-char-attribute (lambda (c v)
390 'morohashi-daikanwa))))
394 (let ((ret (char-representative-of-daikanwa sc nil t t)))
397 (eq (char-ideographic-radical ret radical)
401 ;; (when (setq scs (append
402 ;; (get-char-attribute char '->subsumptive)
403 ;; (get-char-attribute char '->denotational)))
405 ;; (setq sc (car scs))
409 ;; (char-representative-of-daikanwa sc nil t))
410 ;; (or (null radical)
411 ;; (eq (char-ideographic-radical ret radical)
413 ;; (setq ret nil)))))
414 ;; (setq scs (cdr scs)))
416 (unless ignore-default
419 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
421 (let (a1 a2 accessor tester dm)
422 (while (and accessors testers)
423 (setq accessor (car accessors)
426 (when (and accessor tester)
427 (setq a1 (funcall accessor c1)
428 a2 (funcall accessor c2))
441 (cond ((funcall tester a1 a2)
443 ((funcall tester a2 a1)
444 (throw 'tag nil))))))
445 (setq accessors (cdr accessors)
446 testers (cdr testers)
447 defaulters (cdr defaulters))))))
449 (defvar ideographic-radical nil)
451 (defun char-daikanwa-strokes (char &optional radical)
453 (setq radical ideographic-radical))
454 (let ((drc (char-representative-of-daikanwa char radical))
455 (r (char-ideographic-radical char radical)))
457 (= (char-ideographic-radical drc radical) r))
459 (char-ideographic-strokes char radical '(daikanwa)))
462 (defun char-daikanwa (char &optional radical checked)
464 (setq radical ideographic-radical))
465 (if (or (null radical)
466 (eq (or (get-char-attribute char 'ideographic-radical)
467 (char-ideographic-radical char radical t))
469 (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
470 (encode-char char '=daikanwa-rev2 'defined-only)
471 (get-char-attribute char 'morohashi-daikanwa))))
473 (and (setq ret (get-char-attribute char '=>daikanwa))
477 (unless (memq char checked)
480 (append (get-char-attribute char '->subsumptive)
481 (get-char-attribute char '->denotational)))
484 (setq checked (cons char checked))
487 (if (setq ret (char-daikanwa sc radical checked))
489 (setq checked (cons sc checked)
492 (setq rest (get-char-attribute char '->identical))
495 (when (setq ret (char-daikanwa sc radical checked))
499 (append ret (list i)))))
500 (setq checked (cons sc checked)
503 (append (get-char-attribute char '<-subsumptive)
504 (get-char-attribute char '<-denotational)))
507 (when (setq ret (char-daikanwa sc radical checked))
511 (append ret (list i)))))
512 (setq checked (cons sc checked)
513 rest (cdr rest))))))))))
516 (defun char-ucs (char)
517 (or (encode-char char '=ucs 'defined-only)
518 (char-feature char '=>ucs)))
520 (defun char-id (char)
521 (logand (char-int char) #x3FFFFFFF))
523 (defun ideograph-char< (a b &optional radical)
524 (let ((ideographic-radical (or radical
525 ideographic-radical)))
526 (char-attributes-poly<
528 '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
529 '(< morohashi-daikanwa< < <)
532 (defun insert-ideograph-radical-char-data (radical)
534 (sort (copy-list (aref ideograph-radical-chars-vector radical))
536 (ideograph-char< a b radical))))
539 (dolist (name (char-attribute-list))
540 (unless (memq name char-db-ignored-attributes)
541 ;; (if (find-charset name)
543 (push name attributes)
546 (setq attributes (sort attributes #'char-attribute-name<)
547 ;; ccss (sort ccss #'char-attribute-name<)
549 (aset ideograph-radical-chars-vector radical chars)
552 (not (some (lambda (atr)
553 (get-char-attribute char atr))
554 char-db-ignored-attributes))
555 ;; (some (lambda (ccs)
556 ;; (encode-char char ccs 'defined-only))
559 (insert-char-data char nil attributes ;ccss
562 (defun write-ideograph-radical-char-data (radical file)
563 (if (file-directory-p file)
564 (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
566 (if (string-match "KANGXI RADICAL " name)
567 (setq name (capitalize (substring name (match-end 0)))))
568 (setq name (mapconcat (lambda (char)
571 (char-to-string char))) name ""))
574 (format "Ideograph-R%03d-%s.el" radical name)
577 (insert (format ";; -*- coding: %s -*-\n"
578 char-db-file-coding-system))
579 (insert-ideograph-radical-char-data radical)
580 (let ((coding-system-for-write char-db-file-coding-system))
581 (write-region (point-min)(point-max) file))))
583 (defun ideographic-structure= (char1 char2)
584 (if (char-ref-p char1)
585 (setq char1 (plist-get char1 :char)))
586 (if (char-ref-p char2)
587 (setq char2 (plist-get char2 :char)))
588 (let ((s1 (if (characterp char1)
589 (get-char-attribute char1 'ideographic-structure)
590 (cdr (assq 'ideographic-structure char1))))
591 (s2 (if (characterp char2)
592 (get-char-attribute char2 'ideographic-structure)
593 (cdr (assq 'ideographic-structure char2))))
595 (if (or (null s1)(null s2))
596 (char-spec= char1 char2)
601 (unless (ideographic-structure= e1 e2)
605 (and (null s1)(null s2))))))
608 (defun ideographic-structure-find-char (structure)
610 (map-char-attribute (lambda (char value)
611 (setq rest structure)
613 (while (and rest value)
614 (unless (ideographic-structure=
615 (car rest)(car value))
617 (setq rest (cdr rest)
619 (unless (or rest value)
621 'ideographic-structure)))
624 (defun chise-string< (string1 string2 accessors)
625 (let ((len1 (length string1))
626 (len2 (length string2))
632 (setq len (min len1 len2))
635 (setq c1 (aref string1 i)
637 (setq rest accessors)
639 (setq func (car rest))
640 (setq v1 (funcall func c1)
641 v2 (funcall func c2))
643 (setq rest (cdr rest)))
657 (provide 'ideograph-util)
659 ;;; ideograph-util.el ends here