(insert-char-data-with-variant): Don't insert characters which have
[chise/xemacs-chise.git-] / lisp / utf-2000 / char-db-util.el
1 ;;; char-db-util.el --- Character Database utility
2
3 ;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004 MORIOKA Tomohiko.
4
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: CHISE, Character Database, 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,
16 ;; but 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 'alist)
28
29 (defconst unidata-normative-category-alist
30   '(("Lu" letter        uppercase)
31     ("Ll" letter        lowercase)
32     ("Lt" letter        titlecase)
33     ("Mn" mark          non-spacing)
34     ("Mc" mark          spacing-combining)
35     ("Me" mark          enclosing)
36     ("Nd" number        decimal-digit)
37     ("Nl" number        letter)
38     ("No" number        other)
39     ("Zs" separator     space)
40     ("Zl" separator     line)
41     ("Zp" separator     paragraph)
42     ("Cc" other         control)
43     ("Cf" other         format)
44     ("Cs" other         surrogate)
45     ("Co" other         private-use)
46     ("Cn" other         not-assigned)))
47
48 (defconst unidata-informative-category-alist
49   '(("Lm" letter        modifier)
50     ("Lo" letter        other)
51     ("Pc" punctuation   connector)
52     ("Pd" punctuation   dash)
53     ("Ps" punctuation   open)
54     ("Pe" punctuation   close)
55     ("Pi" punctuation   initial-quote)
56     ("Pf" punctuation   final-quote)
57     ("Po" punctuation   other)
58     ("Sm" symbol        math)
59     ("Sc" symbol        currency)
60     ("Sk" symbol        modifier)
61     ("So" symbol        other)
62     ))
63
64 (defconst ideographic-radicals
65   (let ((v (make-vector 215 nil))
66         (i 1))
67     (while (< i 215)
68       (aset v i (decode-char '=ucs (+ #x2EFF i)))
69       (setq i (1+ i)))
70     v))
71
72 (defvar char-db-file-coding-system 'utf-8-mcs-er)
73
74 (defvar char-db-feature-domains
75   '(ucs daikanwa cns gt jis jis/alt jis/a jis/b
76         jis-x0212 jis-x0213 cdp shinjigen misc unknown))
77
78 (defvar char-db-ignored-attributes nil)
79
80 (defun char-attribute-name< (ka kb)
81   (cond
82    ((eq '->denotational kb)
83     t)
84    ((eq '->subsumptive kb)
85     (not (eq '->denotational ka)))
86    ((eq '->denotational ka)
87     nil)
88    ((eq '->subsumptive ka)
89     nil)
90    ((find-charset ka)
91     (if (find-charset kb)
92         (if (<= (charset-id ka) 1)
93             (if (<= (charset-id kb) 1)
94                 (cond
95                  ((= (charset-dimension ka)
96                      (charset-dimension kb))
97                   (> (charset-id ka)(charset-id kb)))
98                  (t
99                   (> (charset-dimension ka)
100                      (charset-dimension kb))
101                   ))
102               t)
103           (if (<= (charset-id kb) 1)
104               nil
105             (< (charset-id ka)(charset-id kb))))
106       nil))
107    ((find-charset kb)
108     t)
109    ((symbolp ka)
110     (cond ((symbolp kb)
111            (string< (symbol-name ka)
112                     (symbol-name kb)))
113           (t)))
114    ((symbolp kb)
115     nil)))
116
117 (defvar char-db-coded-charset-priority-list
118   '(ascii
119     control-1
120     latin-iso8859-1
121     latin-iso8859-2
122     latin-iso8859-3
123     latin-iso8859-4
124     latin-iso8859-9
125     latin-jisx0201
126     cyrillic-iso8859-5
127     greek-iso8859-7
128     thai-tis620
129     =jis-x0208
130     japanese-jisx0208
131     japanese-jisx0212
132     japanese-jisx0208-1978
133     chinese-gb2312
134     chinese-cns11643-1
135     chinese-cns11643-2
136     chinese-cns11643-3
137     chinese-cns11643-4
138     chinese-cns11643-5
139     chinese-cns11643-6
140     chinese-cns11643-7
141     =jis-x0208-1990
142     =jis-x0213-1-2000
143     =jis-x0213-2-2000
144     korean-ksc5601
145     chinese-isoir165
146     katakana-jisx0201
147     hebrew-iso8859-8
148     chinese-gb12345
149     latin-viscii
150     ethiopic-ucs
151     =big5-cdp
152     =gt
153     ideograph-daikanwa-2
154     ideograph-daikanwa
155     =cbeta
156     ideograph-hanziku-1
157     ideograph-hanziku-2
158     ideograph-hanziku-3
159     ideograph-hanziku-4
160     ideograph-hanziku-5
161     ideograph-hanziku-6
162     ideograph-hanziku-7
163     ideograph-hanziku-8
164     ideograph-hanziku-9
165     ideograph-hanziku-10
166     ideograph-hanziku-11
167     ideograph-hanziku-12
168     =big5
169     =big5-eten
170     =gt-k
171     =jis-x0208@1997
172     =jef-china3))
173
174 (defun char-db-make-char-spec (char)
175   (let (ret char-spec)
176     (cond ((characterp char)
177            (cond ((and (setq ret (encode-char char '=ucs 'defined-only))
178                        (not (and (<= #xE000 ret)(<= ret #xF8FF))))
179                   (setq char-spec (list (cons '=ucs ret)))
180                   (cond ((setq ret (get-char-attribute char 'name))
181                          (setq char-spec (cons (cons 'name ret) char-spec))
182                          )
183                         ((setq ret (get-char-attribute char 'name*))
184                          (setq char-spec (cons (cons 'name* ret) char-spec))
185                          ))
186                   )
187                  ((setq ret
188                         (catch 'tag
189                           (let ((rest char-db-coded-charset-priority-list)
190                                 ccs)
191                             (while rest
192                               (setq ccs (charset-name
193                                          (find-charset (car rest))))
194                               (if (setq ret
195                                         (encode-char char ccs
196                                                      'defined-only))
197                                   (throw 'tag (cons ccs ret)))
198                               (setq rest (cdr rest))))))
199                   (setq char-spec (list ret))
200                   (dolist (ccs (delq (car ret) (charset-list)))
201                     (if (and (or (charset-iso-final-char ccs)
202                                  (memq ccs
203                                        '(=daikanwa
204                                          =daikanwa@rev2
205                                          ;; =gt-k
206                                          )))
207                              (setq ret (encode-char char ccs 'defined-only)))
208                         (setq char-spec (cons (cons ccs ret) char-spec))))
209                   (if (null char-spec)
210                       (setq char-spec (split-char char)))
211                   (cond ((setq ret (get-char-attribute char 'name))
212                          (setq char-spec (cons (cons 'name ret) char-spec))
213                          )
214                         ((setq ret (get-char-attribute char 'name*))
215                          (setq char-spec (cons (cons 'name* ret) char-spec))
216                          ))
217                   ))
218            char-spec)
219           ((consp char)
220            char))))
221     
222 (defun char-db-insert-char-spec (char &optional readable column
223                                       required-features)
224   (unless column
225     (setq column (current-column)))
226   (let (char-spec temp-char)
227     (setq char-spec (char-db-make-char-spec char))
228     (unless (or (characterp char) ; char
229                 (condition-case nil
230                     (setq char (find-char char-spec))
231                   (error nil)))
232       ;; define temporary character
233       ;;   Current implementation is dirty.
234       (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
235                                          char-spec)))
236       (remove-char-attribute temp-char 'ideograph-daikanwa)
237       (setq char temp-char))
238     (insert-char-attributes char
239                             readable
240                             (union (mapcar #'car char-spec)
241                                    required-features))
242     (when temp-char
243       ;; undefine temporary character
244       ;;   Current implementation is dirty.
245       (setq char-spec (char-attribute-alist temp-char))
246       (while char-spec
247         (remove-char-attribute temp-char (car (car char-spec)))
248         (setq char-spec (cdr char-spec))))))
249
250 (defun char-db-insert-alist (alist &optional readable column)
251   (unless column
252     (setq column (current-column)))
253   (let ((line-breaking
254          (concat "\n" (make-string (1+ column) ?\ )))
255         name value
256         ret al ; cal
257         key
258         lbs cell rest separator)
259     (insert "(")
260     (while alist
261       (setq name (car (car alist))
262             value (cdr (car alist)))
263       (cond ((eq name 'char)
264              (insert "(char . ")
265              (if (setq ret (condition-case nil
266                                (find-char value)
267                              (error nil)))
268                  (progn
269                    (setq al nil
270                          ;; cal nil
271                          )
272                    (while value
273                      (setq key (car (car value)))
274                      ;; (if (find-charset key)
275                      ;;     (setq cal (cons key cal))
276                      (setq al (cons key al))
277                      ;; )
278                      (setq value (cdr value)))
279                    (insert-char-attributes ret
280                                            readable
281                                            (or al 'none) ; cal
282                                            ))
283                (insert (prin1-to-string value)))
284              (insert ")")
285              (insert line-breaking))
286             ((consp value)
287              (insert (format "(%-18s " name))
288              (setq lbs (concat "\n" (make-string (current-column) ?\ )))
289              (while (consp value)
290                (setq cell (car value))
291                (if (and (consp cell)
292                         (consp (car cell))
293                         (setq ret (condition-case nil
294                                       (find-char cell)
295                                     (error nil)))
296                         )
297                    (progn
298                      (setq rest cell
299                            al nil
300                            ;; cal nil
301                            )
302                      (while rest
303                        (setq key (car (car rest)))
304                        ;; (if (find-charset key)
305                        ;;     (setq cal (cons key cal))
306                        (setq al (cons key al))
307                        ;; )
308                        (setq rest (cdr rest)))
309                      (if separator
310                          (insert lbs))
311                      (insert-char-attributes ret
312                                              readable
313                                              al ; cal
314                                              )
315                      (setq separator lbs))
316                  (if separator
317                      (insert separator))
318                  (insert (prin1-to-string cell))
319                  (setq separator " "))
320                (setq value (cdr value)))
321              (insert ")")
322              (insert line-breaking))
323             (t
324              (insert (format "(%-18s . %S)%s"
325                              name value
326                              line-breaking))))
327       (setq alist (cdr alist))))
328   (insert ")"))
329
330 (defun char-db-insert-char-reference (plist &optional readable column)
331   (unless column
332     (setq column (current-column)))
333   (let ((line-breaking
334          (concat "\n" (make-string (1+ column) ?\ )))
335         (separator "")
336         name value)
337     (insert "(")
338     (while plist
339       (setq name (pop plist))
340       (setq value (pop plist))
341       (cond ((eq name :char)
342              (insert separator)
343              (insert ":char\t")
344              (cond ((numberp value)
345                     (setq value (decode-char '=ucs value)))
346                    ;; ((consp value)
347                    ;;  (setq value (or (find-char value)
348                    ;;                  value)))
349                    )
350              (char-db-insert-char-spec value readable)
351              (insert line-breaking)
352              (setq separator ""))
353             ((eq name :radical)
354              (insert (format "%s%s\t%d ; %c%s"
355                              separator
356                              name value
357                              (aref ideographic-radicals value)
358                              line-breaking))
359              (setq separator ""))
360             (t
361              (insert (format "%s%s\t%S" separator name value))
362              (setq separator line-breaking)))
363       ))
364   (insert ")"))
365
366 (defun char-db-decode-isolated-char (ccs code-point)
367   (let (ret)
368     (setq ret
369           (cond ((eq ccs 'arabic-iso8859-6)
370                  (decode-char ccs code-point))
371                 ((and (memq ccs '(=gt-pj-1
372                                   =gt-pj-2
373                                   =gt-pj-3
374                                   =gt-pj-4
375                                   =gt-pj-5
376                                   =gt-pj-6
377                                   =gt-pj-7
378                                   =gt-pj-8
379                                   =gt-pj-9
380                                   =gt-pj-10
381                                   =gt-pj-11))
382                       (setq ret (decode-char ccs code-point))
383                       (setq ret (encode-char ret '=gt 'defined-only)))
384                  (decode-builtin-char '=gt ret))
385                 (t
386                  (decode-builtin-char ccs code-point))))
387     (cond ((and (<= 0 (char-int ret))
388                 (<= (char-int ret) #x1F))
389            (decode-char '=ucs (+ #x2400 (char-int ret))))
390           ((= (char-int ret) #x7F)
391            ?\u2421)
392           (t ret))))
393
394 (defvar char-db-convert-obsolete-format t)
395
396 (defun char-db-insert-ccs-feature (name value line-breaking)
397   (insert
398    (format
399     (cond ((memq name '(=daikanwa
400                         =daikanwa@rev1 =daikanwa@rev2
401                         =gt =gt-k =cbeta))
402            "(%-18s . %05d)\t; %c")
403           ((eq name 'mojikyo)
404            "(%-18s . %06d)\t; %c")
405           ((>= (charset-dimension name) 2)
406            "(%-18s . #x%04X)\t; %c")
407           (t
408            "(%-18s . #x%02X)\t; %c"))
409     name
410     (if (= (charset-iso-graphic-plane name) 1)
411         (logior value
412                 (cond ((= (charset-dimension name) 1)
413                        #x80)
414                       ((= (charset-dimension name) 2)
415                        #x8080)
416                       ((= (charset-dimension name) 3)
417                        #x808080)
418                       (t 0)))
419       value)
420     (char-db-decode-isolated-char name value)))
421   (if (and (= (charset-chars name) 94)
422            (= (charset-dimension name) 2))
423       (insert (format " [%02d-%02d]"
424                       (- (lsh value -8) 32)
425                       (- (logand value 255) 32))))
426   (insert line-breaking))
427
428 (defun insert-char-attributes (char &optional readable attributes column)
429   (unless column
430     (setq column (current-column)))
431   (let (name value ; has-long-ccs-name
432         rest
433         radical strokes
434         (line-breaking
435          (concat "\n" (make-string (1+ column) ?\ )))
436         lbs cell separator ret
437         key al cal
438         dest-ccss
439         sources required-features
440         ccss)
441     (let (atr-d)
442       (setq attributes
443             (sort (if attributes
444                       (if (consp attributes)
445                           (progn
446                             (dolist (name attributes)
447                               (unless (memq name char-db-ignored-attributes)
448                                 (if (find-charset name)
449                                     (push name ccss))
450                                 (push name atr-d)))
451                             atr-d))
452                     (dolist (name (char-attribute-list))
453                       (unless (memq name char-db-ignored-attributes)
454                         (if (find-charset name)
455                             (push name ccss))
456                         (push name atr-d)))
457                     atr-d)
458                   #'char-attribute-name<)))
459     (insert "(")
460     (when (and (memq 'name attributes)
461                (setq value (get-char-attribute char 'name)))
462       (insert (format
463                (if (> (+ (current-column) (length value)) 48)
464                    "(name . %S)%s"
465                  "(name               . %S)%s")
466                value line-breaking))
467       (setq attributes (delq 'name attributes))
468       )
469     (when (and (memq 'name* attributes)
470                (setq value (get-char-attribute char 'name*)))
471       (insert (format
472                (if (> (+ (current-column) (length value)) 48)
473                    "(name* . %S)%s"
474                  "(name*              . %S)%s")
475                value line-breaking))
476       (setq attributes (delq 'name* attributes))
477       )
478     (when (and (memq 'script attributes)
479                (setq value (get-char-attribute char 'script)))
480       (insert (format "(script\t\t%s)%s"
481                       (mapconcat (function prin1-to-string)
482                                  value " ")
483                       line-breaking))
484       (setq attributes (delq 'script attributes))
485       )
486     ;; (when (and (memq '<-denotational attributes)
487     ;;            (setq value (get-char-attribute char '<-denotational))
488     ;;            (null (cdr value))
489     ;;            (setq value (encode-char (car value) 'ucs 'defined-only)))
490     ;;   (insert (format "(%-18s . #x%04X)\t; %c%s"
491     ;;                   '=>ucs value (decode-char 'ucs value)
492     ;;                   line-breaking))
493     ;;   (setq attributes (delq '<-denotational attributes)))
494     (dolist (name '(=>ucs =>ucs*))
495       (when (and (memq name attributes)
496                  (setq value (get-char-attribute char name)))
497         (insert (format "(%-18s . #x%04X)\t; %c%s"
498                         name value (decode-char '=ucs value)
499                         line-breaking))
500         (setq attributes (delq name attributes))))
501     (dolist (name '(=>ucs@gb =>ucs@cns =>ucs@jis =>ucs@ks =>ucs@big5))
502       (when (and (memq name attributes)
503                  (setq value (get-char-attribute char name)))
504         (insert (format "(%-18s . #x%04X)\t; %c%s"
505                         name value
506                         (decode-char (intern
507                                       (concat "="
508                                               (substring
509                                                (symbol-name name) 2)))
510                                      value)
511                         line-breaking))
512         (setq attributes (delq name attributes))
513         ))
514     (dolist (name '(=>daikanwa))
515       (when (and (memq name attributes)
516                  (setq value (get-char-attribute char name)))
517         (insert
518          (if (integerp value)
519              (format "(%-18s . %05d)\t; %c%s"
520                      name value (decode-char '=daikanwa value)
521                      line-breaking)
522            (format "(%-18s %s)\t; %c%s"
523                    name
524                    (mapconcat (function prin1-to-string)
525                               value " ")
526                    (char-representative-of-daikanwa char)
527                    line-breaking)))
528         (setq attributes (delq name attributes))))
529     (when (and (memq 'general-category attributes)
530                (setq value (get-char-attribute char 'general-category)))
531       (insert (format
532                "(general-category\t%s) ; %s%s"
533                (mapconcat (lambda (cell)
534                             (format "%S" cell))
535                           value " ")
536                (cond ((rassoc value unidata-normative-category-alist)
537                       "Normative Category")
538                      ((rassoc value unidata-informative-category-alist)
539                       "Informative Category")
540                      (t
541                       "Unknown Category"))
542                line-breaking))
543       (setq attributes (delq 'general-category attributes))
544       )
545     (when (and (memq 'bidi-category attributes)
546                (setq value (get-char-attribute char 'bidi-category)))
547       (insert (format "(bidi-category\t. %S)%s"
548                       value
549                       line-breaking))
550       (setq attributes (delq 'bidi-category attributes))
551       )
552     (unless (or (not (memq 'mirrored attributes))
553                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
554                     'empty))
555       (insert (format "(mirrored\t\t. %S)%s"
556                       value
557                       line-breaking))
558       (setq attributes (delq 'mirrored attributes))
559       )
560     (cond
561      ((and (memq 'decimal-digit-value attributes)
562            (setq value (get-char-attribute char 'decimal-digit-value)))
563       (insert (format "(decimal-digit-value . %S)%s"
564                       value
565                       line-breaking))
566       (setq attributes (delq 'decimal-digit-value attributes))
567       (when (and (memq 'digit-value attributes)
568                  (setq value (get-char-attribute char 'digit-value)))
569         (insert (format "(digit-value\t . %S)%s"
570                         value
571                         line-breaking))
572         (setq attributes (delq 'digit-value attributes))
573         )
574       (when (and (memq 'numeric-value attributes)
575                  (setq value (get-char-attribute char 'numeric-value)))
576         (insert (format "(numeric-value\t . %S)%s"
577                         value
578                         line-breaking))
579         (setq attributes (delq 'numeric-value attributes))
580         )
581       )
582      (t
583       (when (and (memq 'digit-value attributes)
584                  (setq value (get-char-attribute char 'digit-value)))
585         (insert (format "(digit-value\t. %S)%s"
586                         value
587                         line-breaking))
588         (setq attributes (delq 'digit-value attributes))
589         )
590       (when (and (memq 'numeric-value attributes)
591                  (setq value (get-char-attribute char 'numeric-value)))
592         (insert (format "(numeric-value\t. %S)%s"
593                         value
594                         line-breaking))
595         (setq attributes (delq 'numeric-value attributes))
596         )))
597     (when (and (memq 'iso-10646-comment attributes)
598                (setq value (get-char-attribute char 'iso-10646-comment)))
599       (insert (format "(iso-10646-comment\t. %S)%s"
600                       value
601                       line-breaking))
602       (setq attributes (delq 'iso-10646-comment attributes))
603       )
604     (when (and (memq 'morohashi-daikanwa attributes)
605                (setq value (get-char-attribute char 'morohashi-daikanwa)))
606       (insert (format "(morohashi-daikanwa\t%s)%s"
607                       (mapconcat (function prin1-to-string) value " ")
608                       line-breaking))
609       (setq attributes (delq 'morohashi-daikanwa attributes))
610       )
611     (setq radical nil
612           strokes nil)
613     (when (and (memq 'ideographic-radical attributes)
614                (setq value (get-char-attribute char 'ideographic-radical)))
615       (setq radical value)
616       (insert (format "(ideographic-radical . %S)\t; %c%s"
617                       radical
618                       (aref ideographic-radicals radical)
619                       line-breaking))
620       (setq attributes (delq 'ideographic-radical attributes))
621       )
622     (let (key)
623       (dolist (domain
624                (append
625                 char-db-feature-domains
626                 (let (dest domain)
627                   (dolist (feature (char-attribute-list))
628                     (setq feature (symbol-name feature))
629                     (when (string-match
630                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
631                            feature)
632                       (setq domain (intern (match-string 2 feature)))
633                      (unless (memq domain dest)
634                        (setq dest (cons domain dest)))))
635                   (sort dest #'string<))))
636         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
637         (when (and (memq key attributes)
638                    (setq value (get-char-attribute char key)))
639           (setq radical value)
640           (insert (format "(%s . %S)\t; %c%s"
641                           key
642                           radical
643                           (aref ideographic-radicals radical)
644                           line-breaking))
645           (setq attributes (delq key attributes))
646           )
647         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
648         (when (and (memq key attributes)
649                    (setq value (get-char-attribute char key)))
650           (setq strokes value)
651           (insert (format "(%s . %S)%s"
652                           key
653                           strokes
654                           line-breaking))
655           (setq attributes (delq key attributes))
656           )
657         (setq key (intern (format "%s@%s" 'total-strokes domain)))
658         (when (and (memq key attributes)
659                    (setq value (get-char-attribute char key)))
660           (insert (format "(%s       . %S)%s"
661                           key
662                           value
663                           line-breaking))
664           (setq attributes (delq key attributes))
665           )
666         (dolist (feature '(ideographic-radical
667                            ideographic-strokes
668                            total-strokes))
669           (setq key (intern (format "%s@%s*sources" feature domain)))
670           (when (and (memq key attributes)
671                      (setq value (get-char-attribute char key)))
672             (insert (format "(%s%s" key line-breaking))
673             (dolist (cell value)
674               (insert (format " %s" cell)))
675             (insert ")")
676             (insert line-breaking)
677             (setq attributes (delq key attributes))
678             ))
679         ))
680     (when (and (memq 'ideographic-strokes attributes)
681                (setq value (get-char-attribute char 'ideographic-strokes)))
682       (setq strokes value)
683       (insert (format "(ideographic-strokes . %S)%s"
684                       strokes
685                       line-breaking))
686       (setq attributes (delq 'ideographic-strokes attributes))
687       )
688     (when (and (memq 'kangxi-radical attributes)
689                (setq value (get-char-attribute char 'kangxi-radical)))
690       (unless (eq value radical)
691         (insert (format "(kangxi-radical\t . %S)\t; %c%s"
692                         value
693                         (aref ideographic-radicals value)
694                         line-breaking))
695         (or radical
696             (setq radical value)))
697       (setq attributes (delq 'kangxi-radical attributes))
698       )
699     (when (and (memq 'kangxi-strokes attributes)
700                (setq value (get-char-attribute char 'kangxi-strokes)))
701       (unless (eq value strokes)
702         (insert (format "(kangxi-strokes\t . %S)%s"
703                         value
704                         line-breaking))
705         (or strokes
706             (setq strokes value)))
707       (setq attributes (delq 'kangxi-strokes attributes))
708       )
709     (when (and (memq 'japanese-radical attributes)
710                (setq value (get-char-attribute char 'japanese-radical)))
711       (unless (eq value radical)
712         (insert (format "(japanese-radical\t . %S)\t; %c%s"
713                         value
714                         (aref ideographic-radicals value)
715                         line-breaking))
716         (or radical
717             (setq radical value)))
718       (setq attributes (delq 'japanese-radical attributes))
719       )
720     (when (and (memq 'japanese-strokes attributes)
721                (setq value (get-char-attribute char 'japanese-strokes)))
722       (unless (eq value strokes)
723         (insert (format "(japanese-strokes\t . %S)%s"
724                         value
725                         line-breaking))
726         (or strokes
727             (setq strokes value)))
728       (setq attributes (delq 'japanese-strokes attributes))
729       )
730     (when (and (memq 'cns-radical attributes)
731                (setq value (get-char-attribute char 'cns-radical)))
732       (insert (format "(cns-radical\t . %S)\t; %c%s"
733                       value
734                       (aref ideographic-radicals value)
735                       line-breaking))
736       (setq attributes (delq 'cns-radical attributes))
737       )
738     (when (and (memq 'cns-strokes attributes)
739                (setq value (get-char-attribute char 'cns-strokes)))
740       (unless (eq value strokes)
741         (insert (format "(cns-strokes\t . %S)%s"
742                         value
743                         line-breaking))
744         (or strokes
745             (setq strokes value)))
746       (setq attributes (delq 'cns-strokes attributes))
747       )
748     (when (and (memq 'shinjigen-1-radical attributes)
749                (setq value (get-char-attribute char 'shinjigen-1-radical)))
750       (unless (eq value radical)
751         (insert (format "(shinjigen-1-radical . %S)\t; %c%s"
752                         value
753                         (aref ideographic-radicals value)
754                         line-breaking))
755         (or radical
756             (setq radical value)))
757       (setq attributes (delq 'shinjigen-1-radical attributes))
758       )
759     (when (and (memq 'ideographic- attributes)
760                (setq value (get-char-attribute char 'ideographic-)))
761       (insert "(ideographic-       ")
762       (setq lbs (concat "\n" (make-string (current-column) ?\ ))
763             separator nil)
764       (while (consp value)
765         (setq cell (car value))
766         (if (integerp cell)
767             (setq cell (decode-char '=ucs cell)))
768         (cond ((characterp cell)
769                (if separator
770                    (insert lbs))
771                (if readable
772                    (insert (format "%S" cell))
773                  (char-db-insert-char-spec cell readable))
774                (setq separator lbs))
775               ((consp cell)
776                (if separator
777                    (insert lbs))
778                (if (consp (car cell))
779                    (char-db-insert-char-spec cell readable)
780                  (char-db-insert-char-reference cell readable))
781                (setq separator lbs))
782               (t
783                (if separator
784                    (insert separator))
785                (insert (prin1-to-string cell))
786                (setq separator " ")))
787         (setq value (cdr value)))
788       (insert ")")
789       (insert line-breaking)
790       (setq attributes (delq 'ideographic- attributes)))
791     (when (and (memq 'total-strokes attributes)
792                (setq value (get-char-attribute char 'total-strokes)))
793       (insert (format "(total-strokes       . %S)%s"
794                       value
795                       line-breaking))
796       (setq attributes (delq 'total-strokes attributes))
797       )
798     (when (and (memq '->ideograph attributes)
799                (setq value (get-char-attribute char '->ideograph)))
800       (insert (format "(->ideograph\t%s)%s"
801                       (mapconcat (lambda (code)
802                                    (cond ((symbolp code)
803                                           (symbol-name code))
804                                          ((integerp code)
805                                           (format "#x%04X" code))
806                                          (t
807                                           (format "%s %S"
808                                                   line-breaking code))))
809                                  value " ")
810                       line-breaking))
811       (setq attributes (delq '->ideograph attributes))
812       )
813     (when (and (memq '->decomposition attributes)
814                (setq value (get-char-attribute char '->decomposition)))
815       (insert (format "(->decomposition\t%s)%s"
816                       (mapconcat (lambda (code)
817                                    (cond ((symbolp code)
818                                           (symbol-name code))
819                                          ((characterp code)
820                                           (if readable
821                                               (format "%S" code)
822                                             (format "#x%04X"
823                                                     (char-int code))
824                                             ))
825                                          ((integerp code)
826                                           (format "#x%04X" code))
827                                          (t
828                                           (format "%s%S" line-breaking code))))
829                                  value " ")
830                       line-breaking))
831       (setq attributes (delq '->decomposition attributes))
832       )
833     (if (equal (get-char-attribute char '->titlecase)
834                (get-char-attribute char '->uppercase))
835         (setq attributes (delq '->titlecase attributes)))
836     (when (and (memq '->mojikyo attributes)
837                (setq value (get-char-attribute char '->mojikyo)))
838       (insert (format "(->mojikyo\t\t. %06d)\t; %c%s"
839                       value (decode-char 'mojikyo value)
840                       line-breaking))
841       (setq attributes (delq '->mojikyo attributes))
842       )
843     (when (and (memq 'hanyu-dazidian-vol attributes)
844                (setq value (get-char-attribute char 'hanyu-dazidian-vol)))
845       (insert (format "(hanyu-dazidian-vol  . %d)%s"
846                       value line-breaking))
847       (setq attributes (delq 'hanyu-dazidian-vol attributes))
848       )
849     (when (and (memq 'hanyu-dazidian-page attributes)
850                (setq value (get-char-attribute char 'hanyu-dazidian-page)))
851       (insert (format "(hanyu-dazidian-page . %d)%s"
852                       value line-breaking))
853       (setq attributes (delq 'hanyu-dazidian-page attributes))
854       )
855     (when (and (memq 'hanyu-dazidian-char attributes)
856                (setq value (get-char-attribute char 'hanyu-dazidian-char)))
857       (insert (format "(hanyu-dazidian-char . %d)%s"
858                       value line-breaking))
859       (setq attributes (delq 'hanyu-dazidian-char attributes))
860       )
861     (unless readable
862       (dolist (ignored '(composition
863                          ->denotational <-subsumptive ->ucs-unified
864                          ->ideographic-component-forms))
865         (setq attributes (delq ignored attributes))))
866     (while attributes
867       (setq name (car attributes))
868       (if (setq value (get-char-attribute char name))
869           (cond ((setq ret (find-charset name))
870                  (setq name (charset-name ret))
871                  (if (and (not (memq name dest-ccss))
872                           (prog1
873                               (setq value (get-char-attribute char name))
874                             (setq dest-ccss (cons name dest-ccss))))
875                      (char-db-insert-ccs-feature name value line-breaking))
876                  )
877                 ((string-match "^=>ucs@" (symbol-name name))
878                  (insert (format "(%-18s . #x%04X)\t; %c%s"
879                                  name value (decode-char '=ucs value)
880                                  line-breaking))
881                  )
882                 ((eq name 'jisx0208-1978/4X)
883                  (insert (format "(%-18s . #x%04X)%s"
884                                  name value
885                                  line-breaking))
886                  )
887                 ((and (not readable)
888                       (null (get-char-attribute
889                              char
890                              (intern (format "%s*sources" name))))
891                       (not (string-match "\\*sources$" (symbol-name name)))
892                       (or (eq name '<-identical)
893                           (string-match "^->halfwidth" (symbol-name name))
894                           (and
895                            (string-match "^->fullwidth" (symbol-name name))
896                            (not
897                             (and (consp value)
898                                  (characterp (car value))
899                                  (encode-char
900                                   (car value) '=ucs 'defined-only))))
901                           (string-match "^->simplified" (symbol-name name))
902                           (string-match "^->vulgar" (symbol-name name))
903                           (string-match "^->wrong" (symbol-name name))
904                           (string-match "^->same" (symbol-name name))
905                           (string-match "^->original" (symbol-name name))
906                           (string-match "^->ancient" (symbol-name name))
907                           ))
908                  )
909                 ((or (eq name 'ideographic-structure)
910                      (eq name 'ideographic-)
911                      (string-match "^\\(->\\|<-\\)" (symbol-name name)))
912                  (insert (format "(%-18s%s " name line-breaking))
913                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
914                        separator nil)
915                  (while (consp value)
916                    (setq cell (car value))
917                    (if (integerp cell)
918                        (setq cell (decode-char '=ucs cell)))
919                    (cond ((eq name '->subsumptive)
920                           (when (or (not
921                                      (some (lambda (atr)
922                                              (get-char-attribute cell atr))
923                                            char-db-ignored-attributes))
924                                     (some (lambda (ccs)
925                                             (encode-char cell ccs
926                                                          'defined-only))
927                                           ccss))
928                             (if separator
929                                 (insert lbs))
930                             (let ((char-db-ignored-attributes
931                                    (cons '<-subsumptive
932                                          char-db-ignored-attributes)))
933                               (insert-char-attributes cell readable))
934                             (setq separator lbs))
935                           )
936                          ((characterp cell)
937                           (setq sources
938                                 (get-char-attribute
939                                  char
940                                  (intern (format "%s*sources" name))))
941                           (setq required-features nil)
942                           (dolist (source sources)
943                             (cond
944                              ((memq source '(JP JP/Jouyou
945                                                 shinjigen-1))
946                               (setq required-features
947                                     (union required-features
948                                            '(=jis-x0208
949                                              =jis-x0208@1990
950                                              =jis-x0213-1-2000
951                                              =jis-x0213-2-2000
952                                              =jis-x0212
953                                              =jis-x0208@1983
954                                              =jis-x0208@1978))))
955                              ((eq source 'CN)
956                               (setq required-features
957                                     (union required-features
958                                            '(=gb2312
959                                              =gb12345
960                                              =iso-ir165)))))
961                             (cond
962                              ((find-charset
963                                (setq ret (intern (format "=%s" source))))
964                               (setq required-features
965                                     (cons ret required-features)))
966                              (t (setq required-features
967                                       (cons source required-features)))))
968                           (cond ((string-match "@JP" (symbol-name name))
969                                  (setq required-features
970                                        (union required-features
971                                               '(=jis-x0208
972                                                 =jis-x0208@1990
973                                                 =jis-x0213-1-2000
974                                                 =jis-x0213-2-2000
975                                                 =jis-x0212
976                                                 =jis-x0208@1983
977                                                 =jis-x0208@1978))))
978                                 ((string-match "@CN" (symbol-name name))
979                                  (setq required-features
980                                        (union required-features
981                                               '(=gb2312
982                                                 =gb12345
983                                                 =iso-ir165)))))
984                           (if separator
985                               (insert lbs))
986                           (if readable
987                               (insert (format "%S" cell))
988                             (char-db-insert-char-spec cell readable
989                                                       nil
990                                                       required-features))
991                           (setq separator lbs))
992                          ((consp cell)
993                           (if separator
994                               (insert lbs))
995                           (if (consp (car cell))
996                               (char-db-insert-char-spec cell readable)
997                             (char-db-insert-char-reference cell readable))
998                           (setq separator lbs))
999                          (t
1000                           (if separator
1001                               (insert separator))
1002                           (insert (prin1-to-string cell))
1003                           (setq separator " ")))
1004                    (setq value (cdr value)))
1005                  (insert ")")
1006                  (insert line-breaking))
1007                 ((memq name '(ideograph=
1008                               original-ideograph-of
1009                               ancient-ideograph-of
1010                               vulgar-ideograph-of
1011                               wrong-ideograph-of
1012                               ;; simplified-ideograph-of
1013                               ideographic-variants
1014                               ;; ideographic-different-form-of
1015                               ))
1016                  (insert (format "(%-18s%s " name line-breaking))
1017                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1018                        separator nil)
1019                  (while (consp value)
1020                    (setq cell (car value))
1021                    (if (and (consp cell)
1022                             (consp (car cell)))
1023                        (progn
1024                          (if separator
1025                              (insert lbs))
1026                          (char-db-insert-alist cell readable)
1027                          (setq separator lbs))
1028                      (if separator
1029                          (insert separator))
1030                      (insert (prin1-to-string cell))
1031                      (setq separator " "))
1032                    (setq value (cdr value)))
1033                  (insert ")")
1034                  (insert line-breaking))
1035                 ((consp value)
1036                  (insert (format "(%-18s " name))
1037                  (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1038                        separator nil)
1039                  (while (consp value)
1040                    (setq cell (car value))
1041                    (if (and (consp cell)
1042                             (consp (car cell))
1043                             (setq ret (condition-case nil
1044                                           (find-char cell)
1045                                         (error nil))))
1046                        (progn
1047                          (setq rest cell
1048                                al nil
1049                                cal nil)
1050                          (while rest
1051                            (setq key (car (car rest)))
1052                            (if (find-charset key)
1053                                (setq cal (cons key cal))
1054                              (setq al (cons key al)))
1055                            (setq rest (cdr rest)))
1056                          (if separator
1057                              (insert lbs))
1058                          (insert-char-attributes ret
1059                                                  readable
1060                                                  al cal)
1061                          (setq separator lbs))
1062                      (setq ret (prin1-to-string cell))
1063                      (if separator
1064                          (if (< (+ (current-column)
1065                                    (length ret)
1066                                    (length separator))
1067                                 76)
1068                              (insert separator)
1069                            (insert lbs)))
1070                      (insert ret)
1071                      (setq separator " "))
1072                    (setq value (cdr value)))
1073                  (insert ")")
1074                  (insert line-breaking))
1075                 (t
1076                  (insert (format "(%-18s . %S)%s"
1077                                  name value
1078                                  line-breaking)))
1079                 ))
1080       (setq attributes (cdr attributes)))
1081     (insert ")")))
1082
1083 (defun insert-char-data (char &optional readable
1084                               attributes)
1085   (save-restriction
1086     (narrow-to-region (point)(point))
1087     (insert "(define-char
1088   '")
1089     (insert-char-attributes char readable attributes)
1090     (insert ")\n")
1091     (goto-char (point-min))
1092     (while (re-search-forward "[ \t]+$" nil t)
1093       (replace-match ""))
1094     ;; from tabify.
1095     (goto-char (point-min))
1096     (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1097       (let ((column (current-column))
1098             (indent-tabs-mode t))
1099         (delete-region (match-beginning 0) (point))
1100         (indent-to column)))
1101     (goto-char (point-max))
1102     ;; (tabify (point-min)(point-max))
1103     ))
1104
1105 (defun insert-char-data-with-variant (char &optional printable
1106                                            no-ucs-unified
1107                                            script excluded-script)
1108   (insert-char-data char printable)
1109   (let ((variants (or (char-variants char)
1110                       (let ((ucs (get-char-attribute char '->ucs)))
1111                         (if ucs
1112                             (delete char (char-variants (int-char ucs)))))))
1113         variant vs ret)
1114     (setq variants (sort variants #'<))
1115     (while variants
1116       (setq variant (car variants))
1117       (if (and (or (null script)
1118                    (null (setq vs (get-char-attribute variant 'script)))
1119                    (memq script vs))
1120                (or (null excluded-script)
1121                    (null (setq vs (get-char-attribute variant 'script)))
1122                    (not (memq excluded-script vs))))
1123           (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1124             (insert-char-data variant printable)
1125             (if (setq ret (char-variants variant))
1126                 (while ret
1127                   (or (memq (car ret) variants)
1128                       (get-char-attribute (car ret) '<-subsumptive)
1129                       (setq variants (append variants (list (car ret)))))
1130                   (setq ret (cdr ret))))
1131             ))
1132       (setq variants (cdr variants))
1133       )))
1134
1135 (defun insert-char-range-data (min max &optional script excluded-script)
1136   (let ((code min)
1137         char)
1138     (while (<= code max)
1139       (setq char (decode-char '=ucs code))
1140       (if (encode-char char '=ucs 'defined-only)
1141           (insert-char-data-with-variant char nil 'no-ucs-unified
1142                                          script excluded-script))
1143       (setq code (1+ code)))))
1144
1145 (defun write-char-range-data-to-file (min max file
1146                                           &optional script excluded-script)
1147   (let ((coding-system-for-write char-db-file-coding-system))
1148     (with-temp-buffer
1149       (insert (format ";; -*- coding: %s -*-\n"
1150                       char-db-file-coding-system))
1151       (insert-char-range-data min max script excluded-script)
1152       (write-region (point-min)(point-max) file))))
1153
1154 (defvar what-character-original-window-configuration)
1155
1156 ;;;###autoload
1157 (defun what-char-definition (char)
1158   (interactive (list (char-after)))
1159   (let ((buf (get-buffer-create "*Character Description*"))
1160         (the-buf (current-buffer))
1161         (win-conf (current-window-configuration)))
1162     (pop-to-buffer buf)
1163     (make-local-variable 'what-character-original-window-configuration)
1164     (setq what-character-original-window-configuration win-conf)
1165     (setq buffer-read-only nil)
1166     (erase-buffer)
1167     (condition-case err
1168         (progn
1169           (insert-char-data-with-variant char 'printable)
1170           (unless (char-attribute-alist char)
1171             (insert (format ";; = %c\n"
1172                             (let* ((rest (split-char char))
1173                                    (ccs (pop rest))
1174                                    (code (pop rest)))
1175                               (while rest
1176                                 (setq code (logior (lsh code 8)
1177                                                    (pop rest))))
1178                               (decode-char ccs code)))))
1179           ;; (char-db-update-comment)
1180           (set-buffer-modified-p nil)
1181           (view-mode the-buf (lambda (buf)
1182                                (set-window-configuration
1183                                 what-character-original-window-configuration)
1184                                ))
1185           (goto-char (point-min)))
1186       (error (progn
1187                (set-window-configuration
1188                 what-character-original-window-configuration)
1189                (signal (car err) (cdr err)))))))
1190
1191 (provide 'char-db-util)
1192
1193 ;;; char-db-util.el ends here