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