(U+50E2): Apply new conventions for glyph granularity for components
[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, 2005, 2007, 2008,
4 ;;   2009, 2010, 2012, 2014, 2015 MORIOKA Tomohiko.
5
6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
7 ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, 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, 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.
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 (require 'chise-subr)
29 (require 'ideograph-subr)
30 (require 'char-db-util)
31
32
33 (defvar ideograph-radical-chars-vector
34   (make-vector 215 nil))
35
36
37 ;;;###autoload
38 (defun update-ideograph-radical-table ()
39   (interactive)
40   (let (ret rret radical script dest)
41     (dolist (feature
42              (cons 'ideographic-radical
43                    (progn
44                      (dolist (feature (char-attribute-list))
45                        (if (string-match "^ideographic-radical@[^@*]+$"
46                                          (symbol-name feature))
47                            (setq dest (cons feature dest))))
48                      dest)))
49       (map-char-attribute
50        (lambda (chr radical)
51          (dolist (char (append
52                         (if (setq ret
53                                   (get-char-attribute chr '<-subsumptive))
54                             (progn
55                               (setq dest nil)
56                               (dolist (pc ret)
57                                 (unless (eq (get-char-attribute
58                                              pc 'ideographic-radical)
59                                             radical)
60                                   (if (setq rret
61                                             (get-char-attribute
62                                              pc '<-subsumptive))
63                                       (setq ret (append ret rret))
64                                     (setq dest (cons pc dest)))))
65                               dest)
66                           (list chr))
67                         (let ((rest (append
68                                      (get-char-attribute chr '<-identical)
69                                      (get-char-attribute chr '->denotational)))
70                               pc)
71                           (setq dest nil)
72                           (while rest
73                             (setq pc (car rest))
74                             (if (memq pc dest)
75                                 (setq rest (cdr rest))
76                               (setq dest (cons pc dest))
77                               (setq rest
78                                     (append (cdr rest)
79                                             (get-char-attribute
80                                              pc '<-identical)
81                                             (get-char-attribute
82                                              pc '->denotational)))))
83                           dest)))
84            (when (and radical
85                       (or (eq radical
86                               (or (get-char-attribute
87                                    char 'ideographic-radical)
88                                   (char-ideographic-radical char radical)))
89                           (null (char-ideographic-radical char)))
90                       (or (null (setq script
91                                       (get-char-attribute char 'script)))
92                           (memq 'Ideograph script)))
93              (unless (memq char
94                            (setq ret
95                                  (aref ideograph-radical-chars-vector
96                                        radical)))
97                (char-ideographic-strokes char)
98                (aset ideograph-radical-chars-vector radical
99                      (cons char ret)))))
100          nil)
101        feature))
102     (map-char-attribute
103      (lambda (char data)
104        (dolist (cell data)
105          (setq radical (plist-get cell :radical))
106          (when (and radical
107                     (or (null (setq script (get-char-attribute char 'script)))
108                         (memq 'Ideograph script)))
109            (unless (memq char
110                          (setq ret
111                                (aref ideograph-radical-chars-vector radical)))
112              (char-ideographic-strokes char)
113              (aset ideograph-radical-chars-vector radical
114                    (cons char ret))))))
115      'ideographic-)))
116
117
118 (defun int-list< (a b)
119   (if (numberp (car a))
120       (if (numberp (car b))
121           (if (= (car a) (car b))
122               (int-list< (cdr a)(cdr b))
123             (< (car a) (car b)))
124         (if (= (car a) 0)
125             nil
126           (< (car a) 0)))
127     (if (numberp (car b))
128         (if (= (car b) 0)
129             t
130           (< 0 (car b)))
131       )))
132
133 (defun morohashi-daikanwa< (a b)
134   (if (integerp a)
135       (setq a (list a)))
136   (if (integerp b)
137       (setq b (list b)))
138   (cond ((eq (car-safe a) 'ho)
139          (if (eq (car-safe b) 'ho)
140              (int-list< (cdr-safe a)(cdr-safe b))
141            nil))
142         ((or (integerp a)
143              (integerp (car a)))
144          (if (eq (car b) 'ho)
145              t
146            (int-list< a b)))
147         (t
148          (if (eq (car-safe b) 'ho)
149              t
150            (int-list< a b)))))
151
152 ;; (defun nil=-int< (a b)
153 ;;   (cond ((null a) nil)
154 ;;         ((null b) nil)
155 ;;         (t (< a b))))
156
157 ;; (defun nil>-int< (a b)
158 ;;   (cond ((null a) nil)
159 ;;         ((null b) t)
160 ;;         (t (< a b))))
161
162 (defvar ideographic-radical nil)
163
164 ;;;###autoload
165 (defun char-representative-of-daikanwa (char &optional radical
166                                              ignore-default checked)
167   (unless radical
168     (setq radical ideographic-radical))
169   (if (or (null radical)
170           (eq (or (get-char-attribute char 'ideographic-radical)
171                   (char-ideographic-radical char radical t))
172               radical))
173       (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
174                      (encode-char char '=daikanwa/+p 'defined-only)
175                      (encode-char char '=daikanwa/+2p 'defined-only)
176                      (encode-char char '=daikanwa/ho 'defined-only)
177                      )))
178         (or (and ret char)
179             (if (setq ret (get-char-attribute char 'morohashi-daikanwa))
180                 (let ((m-m (car ret))
181                       (m-s (nth 1 ret))
182                       pat)
183                   (if (= m-s 0)
184                       (or (decode-char '=daikanwa@rev2 m-m 'defined-only)
185                           (decode-char '=daikanwa m-m))
186                     (or (cond ((eq m-m 'ho)
187                                (decode-char '=daikanwa/ho m-s))
188                               ((eq m-s 1)
189                                (decode-char '=daikanwa/+p m-m))
190                               ((eq m-s 2)
191                                (decode-char '=daikanwa/+2p m-m)))
192                         (progn
193                           (setq pat (list m-m m-s))
194                           (map-char-attribute (lambda (c v)
195                                                 (if (equal pat v)
196                                                     c))
197                                               'morohashi-daikanwa))))))
198             (and (setq ret (get-char-attribute char '=>daikanwa))
199                  (if (numberp ret)
200                      (or (decode-char '=daikanwa@rev2 ret 'defined-only)
201                          (decode-char '=daikanwa ret))
202                    (map-char-attribute (lambda (c v)
203                                          (if (equal ret v)
204                                              char))
205                                        'morohashi-daikanwa)))
206             (unless (memq char checked)
207               (catch 'tag
208                 (let ((rest
209                        (append (get-char-attribute char '->subsumptive)
210                                (get-char-attribute char '->denotational)))
211                       (i 0)
212                       sc)
213                   (setq checked (cons char checked))
214                   (while rest
215                     (setq sc (car rest))
216                     (if (setq ret (char-representative-of-daikanwa
217                                    sc radical t checked))
218                         (throw 'tag ret))
219                     (setq checked (cons sc checked)
220                           rest (cdr rest)
221                           i (1+ i)))
222                   (setq rest (get-char-attribute char '->identical))
223                   (while rest
224                     (setq sc (car rest))
225                     (when (setq ret (char-representative-of-daikanwa
226                                      sc radical t checked))
227                       (throw 'tag ret))
228                     (setq checked (cons sc checked)
229                           rest (cdr rest)))
230                   (setq rest
231                         (append (get-char-attribute char '<-subsumptive)
232                                 (get-char-attribute char '<-denotational)))
233                   (while rest
234                     (setq sc (car rest))
235                     (when (setq ret (char-representative-of-daikanwa
236                                      sc radical t checked))
237                       (throw 'tag ret))
238                     (setq checked (cons sc checked)
239                           rest (cdr rest))))))
240             (unless ignore-default
241               char)))))
242
243 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
244   (catch 'tag
245     (let (a1 a2 accessor tester dm)
246       (while (and accessors testers)
247         (setq accessor (car accessors)
248               tester (car testers)
249               dm (car defaulters))
250         (when (and accessor tester)
251           (setq a1 (funcall accessor c1)
252                 a2 (funcall accessor c2))
253           (cond ((null a1)
254                  (if a2
255                      (cond ((eq dm '<)
256                             (throw 'tag t))
257                            ((eq dm '>)
258                             (throw 'tag nil)))))
259                 ((null a2)
260                  (cond ((eq dm '<)
261                         (throw 'tag nil))
262                        ((eq dm '>)
263                         (throw 'tag t))))
264                 (t
265                  (cond ((funcall tester a1 a2)
266                         (throw 'tag t))
267                        ((funcall tester a2 a1)
268                         (throw 'tag nil))))))
269         (setq accessors (cdr accessors)
270               testers (cdr testers)
271               defaulters (cdr defaulters))))))
272
273 (defun char-daikanwa-radical (char &optional radical ignore-sisters)
274   (or (and (encode-char char '=daikanwa@rev2 'defined-only)
275            (or (get-char-attribute char 'ideographic-radical@daikanwa)
276                (get-char-attribute char 'ideographic-radical)))
277       (char-ideographic-radical char radical ignore-sisters)))
278
279 (defun char-daikanwa-strokes (char &optional radical)
280   (unless radical
281     (setq radical ideographic-radical))
282   (let ((drc (char-representative-of-daikanwa char radical))
283         (r (char-ideographic-radical char radical)))
284     (if (and drc
285              (or (null r)
286                  (= (char-ideographic-radical drc radical) r)))
287         (setq char drc)))
288   (char-ideographic-strokes char radical '(daikanwa)))
289
290 ;;;###autoload
291 (defun char-daikanwa (char &optional radical checked depth)
292   (unless radical
293     (setq radical ideographic-radical))
294   (if (or (null radical)
295           (eq (or (get-char-attribute char 'ideographic-radical)
296                   (char-daikanwa-radical char radical t))
297               radical))
298       (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
299                      ;; (encode-char char '=daikanwa 'defined-only)
300                      (get-char-attribute char 'morohashi-daikanwa))))
301         (unless ret
302           (cond
303            ((setq ret (encode-char char '=daikanwa/+p 'defined-only))
304             (setq ret (list ret 1)))
305            ((setq ret (encode-char char '=daikanwa/+2p 'defined-only))
306             (setq ret (list ret 2)))
307            ((setq ret (encode-char char '=daikanwa/ho 'defined-only))
308             (setq ret (list 'ho ret)))))
309         (or (if ret
310                 (if depth
311                     (if (integerp ret)
312                         (list ret depth)
313                       (append ret (list depth)))
314                   ret))
315             (and (setq ret (get-char-attribute char '=>daikanwa))
316                  (if (numberp ret)
317                      (list ret -10)
318                    (append ret '(-10))))
319             (unless (memq char checked)
320               (unless depth
321                 (setq depth 0))
322               (catch 'tag
323                 (let ((rest
324                        (append
325                         (get-char-attribute char '->subsumptive)
326                         (get-char-attribute char '->denotational)
327                         (get-char-attribute char '->denotational@component)
328                         ))
329                       (i 0)
330                       sc lnum)
331                   (setq checked (cons char checked))
332                   (while rest
333                     (setq sc (car rest))
334                     (if (setq ret (char-daikanwa sc radical checked
335                                                  (1- depth)))
336                         (throw 'tag ret))
337                     (setq checked (cons sc checked)
338                           rest (cdr rest)
339                           i (1+ i)))
340                   (setq rest (get-char-attribute char '->identical))
341                   (while rest
342                     (setq sc (car rest))
343                     (when (setq ret (char-daikanwa sc radical checked depth))
344                       (throw 'tag
345                              (if (numberp ret)
346                                  (list ret 0)
347                                (append ret (list i)))))
348                     (setq checked (cons sc checked)
349                           rest (cdr rest)))
350                   (setq rest
351                         (append
352                          (get-char-attribute char '<-subsumptive)
353                          (get-char-attribute char '<-denotational)
354                          (get-char-attribute char '<-denotational@component)
355                          ))
356                   (while rest
357                     (setq sc (car rest))
358                     (when (setq ret (char-daikanwa sc radical checked depth))
359                       (throw 'tag
360                              (if (numberp ret)
361                                  (list ret 0 i)
362                                (if (>= (setq lnum (car (last ret))) 0)
363                                    (append ret (list i))
364                                  (nconc (butlast ret)
365                                         (list 0 (- lnum) i))))))
366                     (setq checked (cons sc checked)
367                           rest (cdr rest))))))))))
368
369 (defun char-ideographic-strokes-diff (char &optional radical)
370   (if (or (get-char-attribute char '<-subsumptive)
371           (get-char-attribute char '<-denotational))
372       (let (s ds)
373         (when (and (setq s (char-ideographic-strokes char radical))
374                    (setq ds (char-daikanwa-strokes char radical)))
375           (abs (- s ds))))
376     0))
377
378 ;;;###autoload
379 (defun ideograph-char< (a b &optional radical)
380   (let ((ideographic-radical (or radical
381                                  ideographic-radical)))
382     (char-attributes-poly<
383      a b
384      '(char-daikanwa-strokes char-daikanwa char-ucs
385                              char-ideographic-strokes-diff char-id)
386      '(< morohashi-daikanwa< < < <)
387      '(> > > > >))))
388
389 (defun insert-ideograph-radical-char-data (radical)
390   (let ((chars
391          (sort (copy-list (aref ideograph-radical-chars-vector radical))
392                (lambda (a b)
393                  (ideograph-char< a b radical))))
394         attributes ; ccss
395         )
396     (dolist (name (char-attribute-list))
397       (unless (memq name char-db-ignored-attributes)
398         ;; (if (find-charset name)
399         ;;     (push name ccss)
400         (push name attributes)
401         ;; )
402         ))
403     (setq attributes (sort attributes #'char-attribute-name<)
404           ;; ccss (sort ccss #'char-attribute-name<)
405           )
406     (aset ideograph-radical-chars-vector radical chars)
407     (dolist (char chars)
408       (when ;;(or
409           (not (some (lambda (atr)
410                        (get-char-attribute char atr))
411                      char-db-ignored-attributes))
412         ;; (some (lambda (ccs)
413         ;;         (encode-char char ccs 'defined-only))
414         ;;       ccss)
415         ;;)
416         (insert-char-data char nil attributes ;ccss
417                           )))))
418
419 (defun write-ideograph-radical-char-data (radical file)
420   (if (file-directory-p file)
421       (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
422                                 'name)))
423         (if (string-match "KANGXI RADICAL " name)
424             (setq name (capitalize (substring name (match-end 0)))))
425         (setq name (mapconcat (lambda (char)
426                                 (if (eq char ? )
427                                     "-"
428                                   (char-to-string char))) name ""))
429         (setq file
430               (expand-file-name
431                (format "Ideograph-R%03d-%s.el" radical name)
432                file))))
433   (with-temp-buffer
434     (insert (format ";; -*- coding: %s -*-\n"
435                     char-db-file-coding-system))
436     (insert-ideograph-radical-char-data radical)
437     (let ((coding-system-for-write char-db-file-coding-system))
438       (write-region (point-min)(point-max) file))))
439
440 (defun ideographic-structure= (char1 char2)
441   (if (char-ref-p char1)
442       (setq char1 (plist-get char1 :char)))
443   (if (char-ref-p char2)
444       (setq char2 (plist-get char2 :char)))
445   (let ((s1 (if (characterp char1)
446                 (get-char-attribute char1 'ideographic-structure)
447               (cdr (assq 'ideographic-structure char1))))
448         (s2 (if (characterp char2)
449                 (get-char-attribute char2 'ideographic-structure)
450               (cdr (assq 'ideographic-structure char2))))
451         e1 e2)
452     (if (or (null s1)(null s2))
453         (char-spec= char1 char2)
454       (catch 'tag
455         (while (and s1 s2)
456           (setq e1 (car s1)
457                 e2 (car s2))
458           (unless (ideographic-structure= e1 e2)
459             (throw 'tag nil))
460           (setq s1 (cdr s1)
461                 s2 (cdr s2)))
462         (and (null s1)(null s2))))))
463
464 ;;;###autoload
465 (defun ideographic-structure-find-char (structure)
466   (let (rest)
467     (map-char-attribute (lambda (char value)
468                           (setq rest structure)
469                           (catch 'tag
470                             (while (and rest value)
471                               (unless (ideographic-structure=
472                                        (car rest)(car value))
473                                 (throw 'tag nil))
474                               (setq rest (cdr rest)
475                                     value (cdr value)))
476                             (unless (or rest value)
477                               char)))
478                         'ideographic-structure)))
479
480
481 (provide 'ideograph-util)
482
483 ;;; ideograph-util.el ends here