1 ;;; ideograph-util.el --- Ideographic Character Database utility
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
4 ;; 2009, 2010 MORIOKA Tomohiko.
6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
7 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, 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, but
17 ;; 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.
29 (require 'char-db-util)
31 (defun get-char-feature-from-domains (char feature domains
38 (dolist (domain domains)
39 (if (and (or (null tester)
40 (equal (or (char-feature
41 ch (expand-char-feature-name
43 (char-feature ch tester))
45 (setq ret (or (char-feature
46 ch (expand-char-feature-name
48 (char-feature ch feature))))
53 (defvar ideograph-radical-chars-vector
54 (make-vector 215 nil))
56 (defun char-ideographic-radical (char &optional radical ignore-sisters)
59 (get-char-feature-from-domains
60 char 'ideographic-radical (cons nil char-db-feature-domains)
61 'ideographic-radical radical ignore-sisters)
62 (get-char-feature-from-domains
63 char 'ideographic-radical (cons nil char-db-feature-domains)
66 ;; (dolist (domain char-db-feature-domains)
67 ;; (if (and (setq ret (char-feature
71 ;; 'ideographic-radical domain))))
72 ;; (or (eq ret radical)
74 ;; (throw 'tag ret))))
76 (dolist (cell (get-char-attribute char 'ideographic-))
77 (if (and (setq ret (plist-get cell :radical))
81 (get-char-feature-from-domains
82 char 'ideographic-radical (cons nil char-db-feature-domains))
83 ;; (char-feature char 'ideographic-radical)
86 (or (get-char-attribute char 'daikanwa-radical)
87 (get-char-attribute char 'kangxi-radical)
88 (get-char-attribute char 'japanese-radical)
89 (get-char-attribute char 'korean-radical)))
91 (put-char-attribute char 'ideographic-radical ret)
94 (defvar ideograph-radical-strokes-vector
96 [nil 1 1 1 1 1 1 2 2 2
115 9 9 9 9 8 9 9 10 10 10
116 10 10 10 10 10 11 11 11 11 11
118 11 12 12 12 12 13 13 13 13 14
122 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
124 (get-char-feature-from-domains char 'ideographic-strokes domains
125 'ideographic-radical radical)
126 (get-char-feature-from-domains char 'ideographic-strokes domains)))
129 (defun char-ideographic-strokes (char &optional radical preferred-domains)
132 (dolist (cell (get-char-attribute char 'ideographic-))
133 (if (and (setq ret (plist-get cell :radical))
136 (throw 'tag (plist-get cell :strokes)))))
137 (char-ideographic-strokes-from-domains
138 char (append preferred-domains
140 char-db-feature-domains))
142 (get-char-attribute char 'daikanwa-strokes)
144 (or (get-char-attribute char 'kangxi-strokes)
145 (get-char-attribute char 'japanese-strokes)
146 (get-char-attribute char 'korean-strokes)
147 (let ((r (char-ideographic-radical char))
148 (ts (get-char-attribute char 'total-strokes)))
150 (- ts (aref ideograph-radical-strokes-vector r))))
153 (put-char-attribute char 'ideographic-strokes strokes)
157 (defun char-total-strokes-from-domains (char domains)
160 (dolist (domain domains)
161 (if (setq ret (char-feature
165 'total-strokes domain))))
166 (throw 'tag ret))))))
169 (defun char-total-strokes (char &optional preferred-domains)
170 (or (char-total-strokes-from-domains char preferred-domains)
171 (char-feature char 'total-strokes)
172 (char-total-strokes-from-domains char char-db-feature-domains)))
175 (defun update-ideograph-radical-table ()
177 (let (ret rret radical script dest)
179 (cons 'ideographic-radical
181 (dolist (feature (char-attribute-list))
182 (if (string-match "^ideographic-radical@[^@*]+$"
183 (symbol-name feature))
184 (setq dest (cons feature dest))))
187 (lambda (chr radical)
188 (dolist (char (append
190 (get-char-attribute chr '<-subsumptive))
194 (unless (eq (get-char-attribute
195 pc 'ideographic-radical)
200 (setq ret (append ret rret))
201 (setq dest (cons pc dest)))))
205 (get-char-attribute chr '<-identical)
206 (get-char-attribute chr '->denotational)))
212 (setq rest (cdr rest))
213 (setq dest (cons pc dest))
219 pc '->denotational)))))
223 (or (get-char-attribute
224 char 'ideographic-radical)
225 (char-ideographic-radical char radical)))
226 (null (char-ideographic-radical char)))
227 (or (null (setq script
228 (get-char-attribute char 'script)))
229 (memq 'Ideograph script)))
232 (aref ideograph-radical-chars-vector
234 (char-ideographic-strokes char)
235 (aset ideograph-radical-chars-vector radical
242 (setq radical (plist-get cell :radical))
244 (or (null (setq script (get-char-attribute char 'script)))
245 (memq 'Ideograph script)))
248 (aref ideograph-radical-chars-vector radical)))
249 (char-ideographic-strokes char)
250 (aset ideograph-radical-chars-vector radical
254 (defun int-list< (a b)
255 (if (numberp (car a))
256 (if (numberp (car b))
257 (if (= (car a) (car b))
258 (int-list< (cdr a)(cdr b))
263 (if (numberp (car b))
269 (defun morohashi-daikanwa< (a b)
274 (cond ((eq (car-safe a) 'ho)
275 (if (eq (car-safe b) 'ho)
276 (int-list< (cdr-safe a)(cdr-safe b))
284 (if (eq (car-safe b) 'ho)
288 ;; (defun nil=-int< (a b)
289 ;; (cond ((null a) nil)
293 ;; (defun nil>-int< (a b)
294 ;; (cond ((null a) nil)
298 (defvar ideographic-radical nil)
301 (defun char-representative-of-daikanwa (char &optional radical
302 ignore-default checked)
304 (setq radical ideographic-radical))
305 (if (or (null radical)
306 (eq (or (get-char-attribute char 'ideographic-radical)
307 (char-ideographic-radical char radical t))
309 (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
310 (encode-char char '=daikanwa-rev2 'defined-only))))
312 (if (setq ret (get-char-attribute char 'morohashi-daikanwa))
313 (let ((m-m (car ret))
317 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
318 (decode-char 'ideograph-daikanwa m-m))
319 (setq pat (list m-m m-s))
320 (map-char-attribute (lambda (c v)
323 'morohashi-daikanwa))))
324 (and (setq ret (get-char-attribute char '=>daikanwa))
326 (or (decode-char '=daikanwa-rev2 ret 'defined-only)
327 (decode-char 'ideograph-daikanwa ret))
328 (map-char-attribute (lambda (c v)
331 'morohashi-daikanwa)))
332 (unless (memq char checked)
335 (append (get-char-attribute char '->subsumptive)
336 (get-char-attribute char '->denotational)))
339 (setq checked (cons char checked))
342 (if (setq ret (char-representative-of-daikanwa
343 sc radical t checked))
345 (setq checked (cons sc checked)
348 (setq rest (get-char-attribute char '->identical))
351 (when (setq ret (char-representative-of-daikanwa
352 sc radical t checked))
354 (setq checked (cons sc checked)
357 (append (get-char-attribute char '<-subsumptive)
358 (get-char-attribute char '<-denotational)))
361 (when (setq ret (char-representative-of-daikanwa
362 sc radical t checked))
364 (setq checked (cons sc checked)
366 (unless ignore-default
369 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
371 (let (a1 a2 accessor tester dm)
372 (while (and accessors testers)
373 (setq accessor (car accessors)
376 (when (and accessor tester)
377 (setq a1 (funcall accessor c1)
378 a2 (funcall accessor c2))
391 (cond ((funcall tester a1 a2)
393 ((funcall tester a2 a1)
394 (throw 'tag nil))))))
395 (setq accessors (cdr accessors)
396 testers (cdr testers)
397 defaulters (cdr defaulters))))))
399 (defun char-daikanwa-strokes (char &optional radical)
401 (setq radical ideographic-radical))
402 (let ((drc (char-representative-of-daikanwa char radical))
403 (r (char-ideographic-radical char radical)))
405 (= (char-ideographic-radical drc radical) r))
407 (char-ideographic-strokes char radical '(daikanwa)))
410 (defun char-daikanwa (char &optional radical checked depth)
412 (setq radical ideographic-radical))
413 (if (or (null radical)
414 (eq (or (get-char-attribute char 'ideographic-radical)
415 (char-ideographic-radical char radical t))
417 (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
418 (encode-char char '=daikanwa-rev2 'defined-only)
419 (get-char-attribute char 'morohashi-daikanwa))))
424 (append ret (list depth)))
426 (and (setq ret (get-char-attribute char '=>daikanwa))
430 (unless (memq char checked)
435 (append (get-char-attribute char '->subsumptive)
436 (get-char-attribute char '->denotational)))
439 (setq checked (cons char checked))
442 (if (setq ret (char-daikanwa sc radical checked
445 (setq checked (cons sc checked)
448 (setq rest (get-char-attribute char '->identical))
451 (when (setq ret (char-daikanwa sc radical checked depth))
455 (append ret (list i)))))
456 (setq checked (cons sc checked)
459 (append (get-char-attribute char '<-subsumptive)
460 (get-char-attribute char '<-denotational)))
463 (when (setq ret (char-daikanwa sc radical checked depth))
467 (if (>= (setq lnum (car (last ret))) 0)
468 (append ret (list i))
470 (list 0 (- lnum) i))))))
471 (setq checked (cons sc checked)
472 rest (cdr rest))))))))))
474 (defun char-ideographic-strokes-diff (char &optional radical)
475 (if (or (get-char-attribute char '<-subsumptive)
476 (get-char-attribute char '<-denotational))
478 (when (and (setq s (char-ideographic-strokes char radical))
479 (setq ds (char-daikanwa-strokes char radical)))
484 (defun ideograph-char< (a b &optional radical)
485 (let ((ideographic-radical (or radical
486 ideographic-radical)))
487 (char-attributes-poly<
489 '(char-daikanwa-strokes char-daikanwa char-ucs
490 char-ideographic-strokes-diff char-id)
491 '(< morohashi-daikanwa< < < <)
494 (defun insert-ideograph-radical-char-data (radical)
496 (sort (copy-list (aref ideograph-radical-chars-vector radical))
498 (ideograph-char< a b radical))))
501 (dolist (name (char-attribute-list))
502 (unless (memq name char-db-ignored-attributes)
503 ;; (if (find-charset name)
505 (push name attributes)
508 (setq attributes (sort attributes #'char-attribute-name<)
509 ;; ccss (sort ccss #'char-attribute-name<)
511 (aset ideograph-radical-chars-vector radical chars)
514 (not (some (lambda (atr)
515 (get-char-attribute char atr))
516 char-db-ignored-attributes))
517 ;; (some (lambda (ccs)
518 ;; (encode-char char ccs 'defined-only))
521 (insert-char-data char nil attributes ;ccss
524 (defun write-ideograph-radical-char-data (radical file)
525 (if (file-directory-p file)
526 (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
528 (if (string-match "KANGXI RADICAL " name)
529 (setq name (capitalize (substring name (match-end 0)))))
530 (setq name (mapconcat (lambda (char)
533 (char-to-string char))) name ""))
536 (format "Ideograph-R%03d-%s.el" radical name)
539 (insert (format ";; -*- coding: %s -*-\n"
540 char-db-file-coding-system))
541 (insert-ideograph-radical-char-data radical)
542 (let ((coding-system-for-write char-db-file-coding-system))
543 (write-region (point-min)(point-max) file))))
545 (defun ideographic-structure= (char1 char2)
546 (if (char-ref-p char1)
547 (setq char1 (plist-get char1 :char)))
548 (if (char-ref-p char2)
549 (setq char2 (plist-get char2 :char)))
550 (let ((s1 (if (characterp char1)
551 (get-char-attribute char1 'ideographic-structure)
552 (cdr (assq 'ideographic-structure char1))))
553 (s2 (if (characterp char2)
554 (get-char-attribute char2 'ideographic-structure)
555 (cdr (assq 'ideographic-structure char2))))
557 (if (or (null s1)(null s2))
558 (char-spec= char1 char2)
563 (unless (ideographic-structure= e1 e2)
567 (and (null s1)(null s2))))))
570 (defun ideographic-structure-find-char (structure)
572 (map-char-attribute (lambda (char value)
573 (setq rest structure)
575 (while (and rest value)
576 (unless (ideographic-structure=
577 (car rest)(car value))
579 (setq rest (cdr rest)
581 (unless (or rest value)
583 'ideographic-structure)))
586 (provide 'ideograph-util)
588 ;;; ideograph-util.el ends here