Reformatted.
[chise/xemacs-chise.git.1] / lisp / utf-2000 / ideograph-util.el
1 ;;; ideograph-util.el --- Ideographic Character Database utility
2
3 ;; Copyright (C) 1999,2000,2001,2002,2003,2004 MORIOKA Tomohiko.
4
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
7
8 ;; This file is part of XEmacs CHISE.
9
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.
14
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.
19
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.
24
25 ;;; Code:
26
27 (require 'char-db-util)
28
29 ;;;###autoload
30 (defun expand-char-feature-name (feature domain)
31   (if domain
32       (intern (format "%s@%s" feature domain))
33     feature))
34
35 (defun map-char-family (function char &optional ignore-sisters)
36   (let ((rest (list char))
37         ret checked)
38     (catch 'tag
39       (while rest
40         (unless (memq (car rest) checked)
41           (if (setq ret (funcall function (car rest)))
42               (throw 'tag ret))
43           (setq checked (cons (car rest) checked)
44                 rest (append rest
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))))))
53
54 (defun get-char-feature-from-domains (char feature domains
55                                            &optional tester arg
56                                            ignore-sisters)
57   (map-char-family
58    (lambda (ch)
59      (let (ret)
60        (catch 'tag
61          (dolist (domain domains)
62            (if (and (or (null tester)
63                         (equal (or (char-feature
64                                     ch (expand-char-feature-name
65                                         tester domain))
66                                    (char-feature ch tester))
67                                arg))
68                     (setq ret (or (char-feature
69                                    ch (expand-char-feature-name
70                                        feature domain))
71                                   (char-feature ch feature))))
72                (throw 'tag ret))))))
73    char ignore-sisters)
74   ;; (let ((rest (list char))
75   ;;       ret checked)
76   ;;   (catch 'tag
77   ;;     (while rest
78   ;;       (setq char (car rest))
79   ;;       (unless (memq char checked)
80   ;;         (dolist (domain domains)
81   ;;           (if (and (setq ret (char-feature
82   ;;                               char
83   ;;                               (expand-char-feature-name
84   ;;                                feature domain)))
85   ;;                    (or (null tester)
86   ;;                        (equal (or (char-feature
87   ;;                                    char
88   ;;                                    (expand-char-feature-name
89   ;;                                     tester domain))
90   ;;                                   (char-feature char tester))
91   ;;                               arg)))
92   ;;               (throw 'tag ret)))
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)))))
100   )
101
102
103 (defvar ideograph-radical-chars-vector
104   (make-vector 215 nil))
105
106 (defun char-ideographic-radical (char &optional radical ignore-sisters)
107   (let (ret)
108     (or (if radical
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)
114            ignore-sisters))
115         ;; (catch 'tag
116         ;;   (dolist (domain char-db-feature-domains)
117         ;;     (if (and (setq ret (char-feature
118         ;;                         char
119         ;;                         (intern
120         ;;                          (format "%s@%s"
121         ;;                                  'ideographic-radical domain))))
122         ;;              (or (eq ret radical)
123         ;;                  (null radical)))
124         ;;         (throw 'tag ret))))
125         (catch 'tag
126           (dolist (cell (get-char-attribute char 'ideographic-))
127             (if (and (setq ret (plist-get cell :radical))
128                      (or (eq ret radical)
129                          (null radical)))
130                 (throw 'tag ret))))
131         (get-char-feature-from-domains
132          char 'ideographic-radical (cons nil char-db-feature-domains))
133         ;; (char-feature char 'ideographic-radical)
134         (progn
135           (setq ret
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)))
140           (when ret
141             (put-char-attribute char 'ideographic-radical ret)
142             ret)))))
143
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
147     2  2  2  2  2  2  2  2  2  2
148     2  2  2  2  2  2  2  2  2  2
149     3  3  3  3  3  3  3  3  3  3
150     3  3  3  3  3  3  3  3  3  3
151     3  3  3  3  3  3  3  3  3  3
152     3  4  4  4  3  4  4  4  4  4
153     4  4  4  4  4  4  4  4  4  4
154     4  4  4  4  4  3  4  4  4  4
155     4  4  4  4  3  5  4  5  5  5
156     ;; 100
157     5  5  5  5  5  5  5  5  5  5
158     5  5  5  5  5  5  5  5  6  6
159     6  6  6  6  6  6  6  6  6  6
160     4  6  6  6  6  6  6  6  6  6
161     4  6  6  6  6  6  6  7  7  7
162     7  7  7  7  7  7  7  7  7  7
163     7  7  4  3  7  7  7  8  7  8
164     3  8  8  8  8  8  9  9  9  9
165     9  9  9  9  8  9  9 10 10 10
166    10 10 10 10 10 11 11 11 11 11
167    ;; 200
168    11 12 12 12 12 13 13 13 13 14
169    14 15 16 16 17])
170
171 ;;;###autoload
172 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
173   (if 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))
178   ;;       ret checked)
179   ;;   (catch 'tag
180   ;;     (while rest
181   ;;       (setq char (car rest))
182   ;;       (unless (memq char checked)
183   ;;         (dolist (domain domains)
184   ;;           (if (and (setq ret (or (char-feature
185   ;;                                   char
186   ;;                                   (expand-char-feature-name
187   ;;                                    'ideographic-radical domain))
188   ;;                                  (char-feature
189   ;;                                   char 'ideographic-radical)))
190   ;;                    (or (eq ret radical)
191   ;;                        (null radical))
192   ;;                    (setq ret (or (char-feature
193   ;;                                   char
194   ;;                                   (expand-char-feature-name
195   ;;                                    'ideographic-strokes domain))
196   ;;                                  (char-feature
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)))))
204   )
205
206 ;;;###autoload
207 (defun char-ideographic-strokes (char &optional radical preferred-domains)
208   (let (ret)
209     (or (catch 'tag
210           (dolist (cell (get-char-attribute char 'ideographic-))
211             (if (and (setq ret (plist-get cell :radical))
212                      (or (eq ret radical)
213                          (null radical)))
214                 (throw 'tag (plist-get cell :strokes)))))
215         (char-ideographic-strokes-from-domains
216          char (append preferred-domains
217                       (cons nil
218                             char-db-feature-domains))
219          radical)
220         (get-char-attribute char 'daikanwa-strokes)
221         (let ((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)))
227                      (if (and r ts)
228                          (- ts (aref ideograph-radical-strokes-vector r))))
229                    )))
230           (when strokes
231             (put-char-attribute char 'ideographic-strokes strokes)
232             strokes)))))
233
234 ;;;###autoload
235 (defun char-total-strokes-from-domains (char domains)
236   (let (ret)
237     (catch 'tag
238       (dolist (domain domains)
239         (if (setq ret (get-char-attribute
240                        char
241                        (intern
242                         (format "%s@%s"
243                                 'total-strokes domain))))
244             (throw 'tag ret))))))
245
246 ;;;###autoload
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)))
251
252 ;;;###autoload
253 (defun update-ideograph-radical-table ()
254   (interactive)
255   (let (ret radical script dest)
256     (dolist (feature
257              (cons 'ideographic-radical
258                    (mapcar
259                     (lambda (domain)
260                       (intern (format "%s@%s" 'ideographic-radical domain)))
261                     char-db-feature-domains)))
262       (map-char-attribute
263        (lambda (chr radical)
264          (dolist (char (append
265                         (if (setq ret
266                                   (get-char-attribute chr '<-subsumptive))
267                             (progn
268                               (setq dest nil)
269                               (dolist (pc ret)
270                                 (unless (eq (get-char-attribute
271                                              pc 'ideographic-radical)
272                                             radical)
273                                   (setq dest (cons pc dest))))
274                               dest)
275                           (list chr))
276                         (let ((rest (append
277                                      (get-char-attribute chr '<-identical)
278                                      (get-char-attribute chr '->denotational)))
279                               pc)
280                           (setq dest nil)
281                           (while rest
282                             (setq pc (car rest))
283                             (if (memq pc dest)
284                                 (setq rest (cdr rest))
285                               (setq dest (cons pc dest))
286                               (setq rest
287                                     (append (cdr rest)
288                                             (get-char-attribute
289                                              pc '<-identical)
290                                             (get-char-attribute
291                                              pc '->denotational)))))
292                           dest)))
293            (when (and radical
294                       (or (eq radical
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)))
302              (unless (memq char
303                            (setq ret
304                                  (aref ideograph-radical-chars-vector
305                                        radical)))
306                (char-ideographic-strokes char)
307                (aset ideograph-radical-chars-vector radical
308                      (cons char ret)))))
309          nil)
310        feature))
311     (map-char-attribute
312      (lambda (char data)
313        (dolist (cell data)
314          (setq radical (plist-get cell :radical))
315          (when (and radical
316                     (or (null (setq script (get-char-attribute char 'script)))
317                         (memq 'Ideograph script)))
318            (unless (memq char
319                          (setq ret
320                                (aref ideograph-radical-chars-vector radical)))
321              (char-ideographic-strokes char)
322              (aset ideograph-radical-chars-vector radical
323                    (cons char ret))))))
324      'ideographic-)))
325
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))
331             (< (car a) (car b)))
332         nil)
333     (numberp (car b))))
334
335 (defun morohashi-daikanwa< (a b)
336   (if (integerp a)
337       (setq a (list a)))
338   (if (integerp b)
339       (setq b (list b)))
340   (cond ((eq (car a) 'ho)
341          (if (eq (car b) 'ho)
342              (int-list< (cdr a)(cdr b))
343            nil))
344         ((numberp (car a))
345          (if (eq (car b) 'ho)
346              t
347            (int-list< a b)))
348         (t
349          (if (eq (car b) 'ho)
350              t
351            (int-list< a b)))))
352
353 ;; (defun nil=-int< (a b)
354 ;;   (cond ((null a) nil)
355 ;;         ((null b) nil)
356 ;;         (t (< a b))))
357
358 ;; (defun nil>-int< (a b)
359 ;;   (cond ((null a) nil)
360 ;;         ((null b) t)
361 ;;         (t (< a b))))
362
363 ;;;###autoload
364 (defun char-representative-of-daikanwa (char &optional radical
365                                              ignore-default dont-inherit)
366   (unless radical
367     (setq radical ideographic-radical))
368   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
369           (encode-char char '=daikanwa-rev2 'defined-only))
370       char
371     (let ((m (char-feature char '=>daikanwa))
372           m-m m-s pat
373           ;;scs sc ret
374           )
375       (or (and (integerp m)
376                (or (decode-char '=daikanwa-rev2 m 'defined-only)
377                    (decode-char 'ideograph-daikanwa m)))
378           (when (or m
379                     (setq m (get-char-attribute char 'morohashi-daikanwa)))
380             (setq m-m (car m))
381             (setq m-s (nth 1 m))
382             (if (= m-s 0)
383                 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
384                     (decode-char 'ideograph-daikanwa m-m))
385               (when m
386                 (setq pat (list m-m m-s))
387                 (map-char-attribute (lambda (c v)
388                                       (if (equal pat v)
389                                           c))
390                                     'morohashi-daikanwa))))
391           (unless dont-inherit
392             (map-char-family
393              (lambda (sc)
394                (let ((ret (char-representative-of-daikanwa sc nil t t)))
395                  (if (and ret
396                           (or (null radical)
397                               (eq (char-ideographic-radical ret radical)
398                                   radical)))
399                      ret)))
400              char))
401           ;; (when (setq scs (append
402           ;;                  (get-char-attribute char '->subsumptive)
403           ;;                  (get-char-attribute char '->denotational)))
404           ;;   (while (and scs
405           ;;               (setq sc (car scs))
406           ;;               (not
407           ;;                (and
408           ;;                 (setq ret
409           ;;                       (char-representative-of-daikanwa sc nil t))
410           ;;                 (or (null radical)
411           ;;                     (eq (char-ideographic-radical ret radical)
412           ;;                         radical)
413           ;;                     (setq ret nil)))))
414           ;;     (setq scs (cdr scs)))
415           ;;   ret)
416           (unless ignore-default
417             char)))))
418
419 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
420   (catch 'tag
421     (let (a1 a2 accessor tester dm)
422       (while (and accessors testers)
423         (setq accessor (car accessors)
424               tester (car testers)
425               dm (car defaulters))
426         (when (and accessor tester)
427           (setq a1 (funcall accessor c1)
428                 a2 (funcall accessor c2))
429           (cond ((null a1)
430                  (if a2
431                      (cond ((eq dm '<)
432                             (throw 'tag t))
433                            ((eq dm '>)
434                             (throw 'tag nil)))))
435                 ((null a2)
436                  (cond ((eq dm '<)
437                         (throw 'tag nil))
438                        ((eq dm '>)
439                         (throw 'tag t))))
440                 (t
441                  (cond ((funcall tester a1 a2)
442                         (throw 'tag t))
443                        ((funcall tester a2 a1)
444                         (throw 'tag nil))))))
445         (setq accessors (cdr accessors)
446               testers (cdr testers)
447               defaulters (cdr defaulters))))))
448
449 (defvar ideographic-radical nil)
450
451 (defun char-daikanwa-strokes (char &optional radical)
452   (unless radical
453     (setq radical ideographic-radical))
454   (let ((drc (char-representative-of-daikanwa char radical))
455         (r (char-ideographic-radical char radical)))
456     (if (or (null r)
457             (= (char-ideographic-radical drc radical) r))
458         (setq char drc)))
459   (char-ideographic-strokes char radical '(daikanwa)))
460
461 ;;;###autoload
462 (defun char-daikanwa (char &optional radical checked)
463   (unless radical
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))
468               radical))
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))))
472         (or ret
473             (and (setq ret (get-char-attribute char '=>daikanwa))
474                  (if (numberp ret)
475                      (list ret 0)
476                    (append ret '(0))))
477             (unless (memq char checked)
478               (catch 'tag
479                 (let ((rest
480                        (append (get-char-attribute char '->subsumptive)
481                                (get-char-attribute char '->denotational)))
482                       (i 0)
483                       sc)
484                   (setq checked (cons char checked))
485                   (while rest
486                     (setq sc (car rest))
487                     (if (setq ret (char-daikanwa sc radical checked))
488                         (throw 'tag ret))
489                     (setq checked (cons sc checked)
490                           rest (cdr rest)
491                           i (1+ i)))
492                   (setq rest (get-char-attribute char '->identical))
493                   (while rest
494                     (setq sc (car rest))
495                     (when (setq ret (char-daikanwa sc radical checked))
496                       (throw 'tag
497                              (if (numberp ret)
498                                  (list ret 0)
499                                (append ret (list i)))))
500                     (setq checked (cons sc checked)
501                           rest (cdr rest)))
502                   (setq rest
503                         (append (get-char-attribute char '<-subsumptive)
504                                 (get-char-attribute char '<-denotational)))
505                   (while rest
506                     (setq sc (car rest))
507                     (when (setq ret (char-daikanwa sc radical checked))
508                       (throw 'tag
509                              (if (numberp ret)
510                                  (list ret 0 i)
511                                (append ret (list i)))))
512                     (setq checked (cons sc checked)
513                           rest (cdr rest))))))))))
514
515 ;;;###autoload
516 (defun char-ucs (char)
517   (or (encode-char char '=ucs 'defined-only)
518       (char-feature char '=>ucs)))
519
520 (defun char-id (char)
521   (logand (char-int char) #x3FFFFFFF))
522
523 (defun ideograph-char< (a b &optional radical)
524   (let ((ideographic-radical (or radical
525                                  ideographic-radical)))
526     (char-attributes-poly<
527      a b
528      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
529      '(< morohashi-daikanwa< < <)
530      '(> > > >))))
531
532 (defun insert-ideograph-radical-char-data (radical)
533   (let ((chars
534          (sort (copy-list (aref ideograph-radical-chars-vector radical))
535                (lambda (a b)
536                  (ideograph-char< a b radical))))
537         attributes ; ccss
538         )
539     (dolist (name (char-attribute-list))
540       (unless (memq name char-db-ignored-attributes)
541         ;; (if (find-charset name)
542         ;;     (push name ccss)
543         (push name attributes)
544         ;; )
545         ))
546     (setq attributes (sort attributes #'char-attribute-name<)
547           ;; ccss (sort ccss #'char-attribute-name<)
548           )
549     (aset ideograph-radical-chars-vector radical chars)
550     (dolist (char chars)
551       (when ;;(or
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))
557         ;;       ccss)
558         ;;)
559         (insert-char-data char nil attributes ;ccss
560                           )))))
561
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))
565                                 'name)))
566         (if (string-match "KANGXI RADICAL " name)
567             (setq name (capitalize (substring name (match-end 0)))))
568         (setq name (mapconcat (lambda (char)
569                                 (if (eq char ? )
570                                     "-"
571                                   (char-to-string char))) name ""))
572         (setq file
573               (expand-file-name
574                (format "Ideograph-R%03d-%s.el" radical name)
575                file))))
576   (with-temp-buffer
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))))
582
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))))
594         e1 e2)
595     (if (or (null s1)(null s2))
596         (char-spec= char1 char2)
597       (catch 'tag
598         (while (and s1 s2)
599           (setq e1 (car s1)
600                 e2 (car s2))
601           (unless (ideographic-structure= e1 e2)
602             (throw 'tag nil))
603           (setq s1 (cdr s1)
604                 s2 (cdr s2)))
605         (and (null s1)(null s2))))))
606
607 ;;;###autoload
608 (defun ideographic-structure-find-char (structure)
609   (let (rest)
610     (map-char-attribute (lambda (char value)
611                           (setq rest structure)
612                           (catch 'tag
613                             (while (and rest value)
614                               (unless (ideographic-structure=
615                                        (car rest)(car value))
616                                 (throw 'tag nil))
617                               (setq rest (cdr rest)
618                                     value (cdr value)))
619                             (unless (or rest value)
620                               char)))
621                         'ideographic-structure)))
622
623 ;;;###autoload
624 (defun chise-string< (string1 string2 accessors)
625   (let ((len1 (length string1))
626         (len2 (length string2))
627         len
628         (i 0)
629         c1 c2
630         rest func
631         v1 v2)
632     (setq len (min len1 len2))
633     (catch 'tag
634       (while (< i len)
635         (setq c1 (aref string1 i)
636               c2 (aref string2 i))
637         (setq rest accessors)
638         (while (and rest
639                     (setq func (car rest))
640                     (setq v1 (funcall func c1)
641                           v2 (funcall func c2))
642                     (eq v1 v2))
643           (setq rest (cdr rest)))
644         (if v1
645             (if v2
646                 (cond ((< v1 v2)
647                        (throw 'tag t))
648                       ((> v1 v2)
649                        (throw 'tag nil)))
650               (throw 'tag nil))
651           (if v2
652               (throw 'tag t)))
653         (setq i (1+ i)))
654       (< len1 len2))))
655
656
657 (provide 'ideograph-util)
658
659 ;;; ideograph-util.el ends here