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