1 ;;; char-db-json.el --- Character Database utility -*- coding: utf-8-er; -*-
3 ;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,
4 ;; 2008,2009,2010,2011,2012,2013,2014,2015,2016 MORIOKA Tomohiko.
6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
7 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
9 ;; This file is part of XEmacs CHISE.
11 ;; XEmacs CHISE is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation; either version 2, or (at
14 ;; your option) any later version.
16 ;; XEmacs CHISE is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs CHISE; see the file COPYING. If not, write to
23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 (require 'char-db-util)
29 (require 'cwiki-format)
31 (setq char-db-ignored-attributes
32 '(ideographic-products
34 *instance@ruimoku/bibliography/title
35 *instance@morpheme-entry/zh-classical))
38 ;;; @ char-db formatters
41 (defun char-db-json-insert-char-spec (char &optional readable column
44 (setq column (current-column)))
45 (let (char-spec temp-char)
46 (setq char-spec (char-db-make-char-spec char))
47 (unless (or (characterp char) ; char
49 (setq char (find-char char-spec))
51 ;; define temporary character
52 ;; Current implementation is dirty.
53 (setq temp-char (define-char (cons '(ideograph-daikanwa . 0)
55 (remove-char-attribute temp-char 'ideograph-daikanwa)
56 (setq char temp-char))
57 (char-db-json-insert-char-features char
59 (union (mapcar #'car char-spec)
63 ;; undefine temporary character
64 ;; Current implementation is dirty.
65 (setq char-spec (char-attribute-alist temp-char))
67 (remove-char-attribute temp-char (car (car char-spec)))
68 (setq char-spec (cdr char-spec))))))
70 (defun char-db-json-insert-alist (alist &optional readable column)
72 (setq column (current-column)))
74 (concat "\n" (make-string (1+ column) ?\ )))
78 lbs cell rest separator)
81 (setq name (car (car alist))
82 value (cdr (car alist)))
83 (cond ((eq name 'char)
85 (if (setq ret (condition-case nil
93 (setq key (car (car value)))
94 ;; (if (find-charset key)
95 ;; (setq cal (cons key cal))
96 (setq al (cons key al))
98 (setq value (cdr value)))
99 (insert-char-attributes ret
103 (insert (prin1-to-string value)))
105 (insert line-breaking))
107 (insert (format "(%-18s " name))
108 (setq lbs (concat "\n" (make-string (current-column) ?\ )))
110 (setq cell (car value))
111 (if (and (consp cell)
113 (setq ret (condition-case nil
123 (setq key (car (car rest)))
124 ;; (if (find-charset key)
125 ;; (setq cal (cons key cal))
126 (setq al (cons key al))
128 (setq rest (cdr rest)))
131 (insert-char-attributes ret
135 (setq separator lbs))
138 (insert (prin1-to-string cell))
139 (setq separator " "))
140 (setq value (cdr value)))
142 (insert line-breaking))
144 (insert (format "(%-18s . %S)%s"
147 (setq alist (cdr alist))))
150 (defun char-db-json-insert-char-reference (plist &optional readable column)
152 (setq column (current-column)))
154 (concat "\n" (make-string (1+ column) ?\ )))
159 (setq name (pop plist))
160 (setq value (pop plist))
161 (cond ((eq name :char)
163 (insert "\"char\":\t")
164 (cond ((numberp value)
165 (setq value (decode-char '=ucs value)))
167 ;; (setq value (or (find-char value)
170 (char-db-json-insert-char-spec value readable)
171 (insert line-breaking)
174 (insert (format "%s%s\t%d, \"_comment\": \"%c\"%s"
177 (ideographic-radical value)
181 (insert (format "%s%s\t%S" separator name value))
182 (setq separator line-breaking)))
186 (defun char-db-json-insert-ccs-feature (name value line-breaking)
192 ((memq name '(=>iwds-1
195 =shinjigen@1ed ==shinjigen@1ed
196 =shinjigen@rev ==shinjigen@rev
197 =shinjigen/+p@rev ==shinjigen/+p@rev
198 ===daikanwa/ho ==daikanwa/ho
199 =daikanwa/ho =>>daikanwa/ho =>daikanwa/ho))
200 " %-18s %4d,\t\"_comment\": \"%c")
201 ((eq name '=shinjigen@1ed/24pr)
202 " %-18s %4d,\t\"_comment\": \"%c")
206 ==daikanwa =daikanwa =>>daikanwa =>daikanwa
207 =daikanwa@rev1 =daikanwa@rev2
208 =daikanwa/+p ==daikanwa/+p ===daikanwa/+p
210 =daikanwa/+2p =>>daikanwa/+2p
215 =adobe-japan1-0 ==adobe-japan1-0 ===adobe-japan1-0
216 =adobe-japan1-1 ==adobe-japan1-1 ===adobe-japan1-1
217 =adobe-japan1-2 ==adobe-japan1-2 ===adobe-japan1-2
218 =adobe-japan1-3 ==adobe-japan1-3 ===adobe-japan1-3
219 =adobe-japan1-4 ==adobe-japan1-4 ===adobe-japan1-4
220 =adobe-japan1-5 ==adobe-japan1-5 ===adobe-japan1-5
221 =adobe-japan1-6 ==adobe-japan1-6 ===adobe-japan1-6
222 =>>adobe-japan1-0 =+>adobe-japan1-0
223 =>>adobe-japan1-1 =+>adobe-japan1-1
224 =>>adobe-japan1-2 =+>adobe-japan1-2
225 =>>adobe-japan1-3 =+>adobe-japan1-3
226 =>>adobe-japan1-4 =+>adobe-japan1-4
227 =>>adobe-japan1-5 =+>adobe-japan1-5
228 =>>adobe-japan1-6 =+>adobe-japan1-6
229 =>cbeta =cbeta =>>cbeta ==cbeta ===cbeta
230 =zinbun-oracle =>zinbun-oracle
231 ===hng-jou ===hng-keg ===hng-dng ===hng-mam
232 ===hng-drt ===hng-kgk ===hng-myz ===hng-kda
233 ===hng-khi ===hng-khm ===hng-hok ===hng-kyd ===hng-sok
234 ===hng-yhk ===hng-kak ===hng-kar ===hng-kae
235 ===hng-sys ===hng-tsu ===hng-tzj
236 ===hng-hos ===hng-nak ===hng-jhk
237 ===hng-hod ===hng-gok ===hng-ink ===hng-nto
238 ===hng-nkm ===hng-k24 ===hng-nkk
239 ===hng-kcc ===hng-kcj ===hng-kbk ===hng-sik
240 ===hng-skk ===hng-kyu ===hng-ksk ===hng-wan
241 ===hng-okd ===hng-wad ===hng-kmi
242 ===hng-zkd ===hng-doh ===hng-jyu
243 ===hng-tzs ===hng-kss ===hng-kyo
245 ;; (string-match "^=adobe-" (symbol-name name))
247 " %-18s %5d,\t\"_comment\": \"%c")
248 ((memq name '(=hanyo-denshi/ks
249 ==hanyo-denshi/ks ===hanyo-denshi/ks
252 =mj ==mj ===mj =>>mj =>mj
254 " %-18s %6d,\t\"_comment\": \"%c")
255 ((memq name '(=hanyo-denshi/tk ==hanyo-denshi/tk))
256 " %-18s %8d,\t\"_comment\": \"%c")
257 ((>= (charset-dimension name) 2)
258 " %-18s %5d,\t\"_comment\": \"%c")
260 " %-18s %3d,\t\"_comment\": \"%c"))
261 (format "\"%s\":" name)
262 (if (= (charset-iso-graphic-plane name) 1)
264 (cond ((= (charset-dimension name) 1)
266 ((= (charset-dimension name) 2)
268 ((= (charset-dimension name) 3)
272 (char-db-decode-isolated-char name value)))
273 (if (and (= (charset-chars name) 94)
274 (= (charset-dimension name) 2))
275 (insert (format " [%02d-%02d]\""
276 (- (lsh value -8) 32)
277 (- (logand value 255) 32)))
281 (insert (format " %-18s %s"
282 (format "\"%s\":" name) value))
286 (defun char-db-json-insert-relation-feature (char name value line-breaking
288 (insert (format " %-18s [%s "
289 (format "\"%s\":" name) line-breaking))
290 (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
291 separator cell sources required-features
294 (setq cell (car value))
296 (setq cell (decode-char '=ucs cell)))
298 ((eq name '->subsumptive)
299 (when (or (not (some (lambda (atr)
300 (get-char-attribute cell atr))
301 char-db-ignored-attributes))
303 (encode-char cell ccs 'defined-only))
307 (setq separator (format ",%s" lbs)))
308 (let ((char-db-ignored-attributes
310 char-db-ignored-attributes)))
311 (char-db-json-insert-char-features
312 cell readable nil nil 'for-sub-node))
318 char (intern (format "%s*sources" name))))
319 (setq required-features nil)
320 (dolist (source sources)
324 shinjigen shinjigen@1ed shinjigen@rev))
325 (setq required-features
326 (union required-features
338 =shinjigen/+p@rev))))
340 (setq required-features
341 (union required-features
346 ((find-charset (setq ret (intern (format "=%s" source))))
347 (setq required-features
348 (cons ret required-features)))
349 (t (setq required-features
350 (cons source required-features)))))
351 (cond ((string-match "@JP" (symbol-name name))
352 (setq required-features
353 (union required-features
361 ((string-match "@CN" (symbol-name name))
362 (setq required-features
363 (union required-features
369 (setq separator (format ",%s" lbs)))
371 (insert (format "%S" cell))
372 (char-db-json-insert-char-spec cell readable
379 (setq separator (format ",%s" lbs)))
380 (if (consp (car cell))
381 (char-db-json-insert-char-spec cell readable)
382 (char-db-json-insert-char-reference cell readable))
388 (insert (prin1-to-string cell))
389 (setq separator " ")))
390 (setq value (cdr value)))
393 (defun char-db-json-insert-char-features (char
394 &optional readable attributes column
397 (setq column (current-column)))
398 (let (name value ; has-long-ccs-name
402 (concat "\n" (make-string (1+ column) ?\ )))
404 lbs cell separator ret
406 dest-ccss ; sources required-features
411 (if (consp attributes)
413 (dolist (name attributes)
414 (unless (memq name char-db-ignored-attributes)
415 (if (find-charset name)
419 (dolist (name (char-attribute-list))
420 (unless (memq name char-db-ignored-attributes)
421 (if (find-charset name)
425 #'char-attribute-name<)))
427 (when (memq '<-subsumptive attributes)
428 (when (or readable (not for-sub-node))
429 (when (setq value (get-char-attribute char '<-subsumptive))
430 (char-db-json-insert-relation-feature char '<-subsumptive value
433 (setq line-separator (format ",%s" line-breaking))
435 (setq attributes (delq '<-subsumptive attributes))
437 (when (and (memq '<-denotational attributes)
438 (setq value (get-char-attribute char '<-denotational)))
440 (insert line-separator)
441 (setq line-separator (format ",%s" line-breaking)))
442 (char-db-json-insert-relation-feature char '<-denotational value
445 (setq attributes (delq '<-denotational attributes)))
446 (when (and (memq '<-denotational@component attributes)
448 (get-char-attribute char '<-denotational@component)))
450 (insert line-separator)
451 (setq line-separator (format ",%s" line-breaking)))
452 (char-db-json-insert-relation-feature
453 char '<-denotational@component value
456 (setq attributes (delq '<-denotational@component attributes)))
457 (when (and (memq 'name attributes)
458 (setq value (get-char-attribute char 'name)))
460 (insert line-separator)
461 (setq line-separator (format ",%s" line-breaking)))
463 (if (> (+ (current-column) (length value)) 48)
467 (setq attributes (delq 'name attributes))
469 (when (and (memq 'name* attributes)
470 (setq value (get-char-attribute char 'name*)))
472 (insert line-separator)
473 (setq line-separator (format ",%s" line-breaking)))
475 (if (> (+ (current-column) (length value)) 48)
479 (setq attributes (delq 'name* attributes))
481 (when (and (memq 'script attributes)
482 (setq value (get-char-attribute char 'script)))
484 (insert line-separator)
485 (setq line-separator (format ",%s" line-breaking)))
486 (insert (format "{\"script\":\t\t%s}%s"
487 (mapconcat (function prin1-to-string)
490 (setq attributes (delq 'script attributes))
492 (dolist (name '(=>ucs =>ucs*))
493 (when (and (memq name attributes)
494 (setq value (get-char-attribute char name)))
496 (insert line-separator)
497 (setq line-separator (format ",%s" line-breaking)))
498 (insert (format "{\"%-18s\": #x%04X},\t\"_comment\": \"%c\"%s"
499 name value (decode-char '=ucs value)
501 (setq attributes (delq name attributes))))
502 (dolist (name '(=>ucs@gb =>ucs@big5))
503 (when (and (memq name attributes)
504 (setq value (get-char-attribute char name)))
506 (insert line-separator)
507 (setq line-separator (format ",%s" line-breaking)))
508 (insert (format "{\"%-18s\": #x%04X},\t\"_comment\": \"%c\"%s"
513 (symbol-name name) 2)))
516 (setq attributes (delq name attributes))
518 (when (and (memq 'general-category attributes)
519 (setq value (get-char-attribute char 'general-category)))
521 (insert line-separator)
522 (setq line-separator (format ",%s" line-breaking)))
524 "{\"general-category\":\t%s} // %s%s"
525 (mapconcat (lambda (cell)
528 (cond ((rassoc value unidata-normative-category-alist)
529 "Normative Category")
530 ((rassoc value unidata-informative-category-alist)
531 "Informative Category")
535 (setq attributes (delq 'general-category attributes))
537 (when (and (memq 'bidi-category attributes)
538 (setq value (get-char-attribute char 'bidi-category)))
540 (insert line-separator)
541 (setq line-separator (format ",%s" line-breaking)))
542 (insert (format "{\"bidi-category\":\t %S}%s"
545 (setq attributes (delq 'bidi-category attributes))
547 (unless (or (not (memq 'mirrored attributes))
548 (eq (setq value (get-char-attribute char 'mirrored 'empty))
551 (insert line-separator)
552 (setq line-separator (format ",%s" line-breaking)))
553 (insert (format "{\"mirrored\":\t\t %S}%s"
556 (setq attributes (delq 'mirrored attributes))
559 ((and (memq 'decimal-digit-value attributes)
560 (setq value (get-char-attribute char 'decimal-digit-value)))
562 (insert line-separator)
563 (setq line-separator (format ",%s" line-breaking)))
564 (insert (format "{\"decimal-digit-value\": %S}%s"
567 (setq attributes (delq 'decimal-digit-value attributes))
568 (when (and (memq 'digit-value attributes)
569 (setq value (get-char-attribute char 'digit-value)))
571 (insert line-separator)
572 (setq line-separator (format ",%s" line-breaking)))
573 (insert (format "{\"digit-value\":\t %S}%s"
576 (setq attributes (delq 'digit-value attributes))
578 (when (and (memq 'numeric-value attributes)
579 (setq value (get-char-attribute char 'numeric-value)))
581 (insert line-separator)
582 (setq line-separator (format ",%s" line-breaking)))
583 (insert (format "{\"numeric-value\":\t %S}%s"
586 (setq attributes (delq 'numeric-value attributes))
590 (when (and (memq 'digit-value attributes)
591 (setq value (get-char-attribute char 'digit-value)))
593 (insert line-separator)
594 (setq line-separator (format ",%s" line-breaking)))
595 (insert (format "{\"digit-value\":\t %S}%s"
598 (setq attributes (delq 'digit-value attributes))
600 (when (and (memq 'numeric-value attributes)
601 (setq value (get-char-attribute char 'numeric-value)))
603 (insert line-separator)
604 (setq line-separator (format ",%s" line-breaking)))
605 (insert (format "{\"numeric-value\":\t %S}%s"
608 (setq attributes (delq 'numeric-value attributes))
610 (when (and (memq 'iso-10646-comment attributes)
611 (setq value (get-char-attribute char 'iso-10646-comment)))
613 (insert line-separator)
614 (setq line-separator (format ",%s" line-breaking)))
615 (insert (format "{\"iso-10646-comment\":\t %S}%s"
618 (setq attributes (delq 'iso-10646-comment attributes))
620 (when (and (memq 'morohashi-daikanwa attributes)
621 (setq value (get-char-attribute char 'morohashi-daikanwa)))
623 (insert line-separator)
624 (setq line-separator (format ",%s" line-breaking)))
625 (insert (format "{\"morohashi-daikanwa\":\t%s}%s"
626 (mapconcat (function prin1-to-string) value " ")
628 (setq attributes (delq 'morohashi-daikanwa attributes))
632 (when (and (memq 'ideographic-radical attributes)
633 (setq value (get-char-attribute char 'ideographic-radical)))
636 (insert line-separator)
637 (setq line-separator (format ",%s" line-breaking)))
638 (insert (format " \"ideographic-radical\": %S,\t\"_comment\": \"%c\""
640 (ideographic-radical radical)
642 (setq attributes (delq 'ideographic-radical attributes))
644 (when (and (memq 'shuowen-radical attributes)
645 (setq value (get-char-attribute char 'shuowen-radical)))
647 (insert line-separator)
648 (setq line-separator (format ",%s" line-breaking)))
649 (insert (format "{\"shuowen-radical\":\t %S},\t\"_comment\": \"%c\"%s"
651 (shuowen-radical value)
653 (setq attributes (delq 'shuowen-radical attributes))
658 char-db-feature-domains
660 (dolist (feature (char-attribute-list))
661 (setq feature (symbol-name feature))
663 "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
665 (setq domain (intern (match-string 2 feature)))
666 (unless (memq domain dest)
667 (setq dest (cons domain dest)))))
668 (sort dest #'string<))))
669 (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
670 (when (and (memq key attributes)
671 (setq value (get-char-attribute char key)))
674 (insert line-separator)
675 (setq line-separator (format ",%s" line-breaking)))
676 (insert (format "{\"%s\": %S},\t\"_comment\": \"%c\"%s"
679 (ideographic-radical radical)
681 (setq attributes (delq key attributes))
683 (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
684 (when (and (memq key attributes)
685 (setq value (get-char-attribute char key)))
688 (insert line-separator)
689 (setq line-separator (format ",%s" line-breaking)))
690 (insert (format " \"%s\": %S"
693 (setq attributes (delq key attributes))
695 (setq key (intern (format "%s@%s" 'total-strokes domain)))
696 (when (and (memq key attributes)
697 (setq value (get-char-attribute char key)))
699 (insert line-separator)
700 (setq line-separator (format ",%s" line-breaking)))
701 (insert (format " \"%s\": %S"
705 (setq attributes (delq key attributes))
707 (dolist (feature '(ideographic-radical
710 (setq key (intern (format "%s@%s*sources" feature domain)))
711 (when (and (memq key attributes)
712 (setq value (get-char-attribute char key)))
714 (insert line-separator)
715 (setq line-separator (format ",%s" line-breaking)))
716 (insert (format " \"%s\":%s" key line-breaking))
718 (insert (format " %s" cell)))
719 (setq attributes (delq key attributes))
722 (when (and (memq 'ideographic-strokes attributes)
723 (setq value (get-char-attribute char 'ideographic-strokes)))
726 (insert line-separator)
727 (setq line-separator (format ",%s" line-breaking)))
728 (insert (format " \"ideographic-strokes\": %S"
731 (setq attributes (delq 'ideographic-strokes attributes))
733 (when (and (memq 'kangxi-radical attributes)
734 (setq value (get-char-attribute char 'kangxi-radical)))
735 (unless (eq value radical)
737 (insert line-separator)
738 (setq line-separator (format ",%s" line-breaking)))
739 (insert (format "{\"kangxi-radical\":\t%S},\t\"_comment\": \"%c\"%s"
741 (ideographic-radical value)
744 (setq radical value)))
745 (setq attributes (delq 'kangxi-radical attributes))
747 (when (and (memq 'kangxi-strokes attributes)
748 (setq value (get-char-attribute char 'kangxi-strokes)))
749 (unless (eq value strokes)
751 (insert line-separator)
752 (setq line-separator (format ",%s" line-breaking)))
753 (insert (format "{\"kangxi-strokes\":\t%S}%s"
757 (setq strokes value)))
758 (setq attributes (delq 'kangxi-strokes attributes))
760 (when (and (memq 'japanese-radical attributes)
761 (setq value (get-char-attribute char 'japanese-radical)))
762 (unless (eq value radical)
764 (insert line-separator)
765 (setq line-separator (format ",%s" line-breaking)))
766 (insert (format "{\"japanese-radical\":\t%S},\t\"_comment\": \"%c\"%s"
768 (ideographic-radical value)
771 (setq radical value)))
772 (setq attributes (delq 'japanese-radical attributes))
774 (when (and (memq 'japanese-strokes attributes)
775 (setq value (get-char-attribute char 'japanese-strokes)))
776 (unless (eq value strokes)
778 (insert line-separator)
779 (setq line-separator (format ",%s" line-breaking)))
780 (insert (format "{\"japanese-strokes\":\t%S}%s"
784 (setq strokes value)))
785 (setq attributes (delq 'japanese-strokes attributes))
787 (when (and (memq 'cns-radical attributes)
788 (setq value (get-char-attribute char 'cns-radical)))
790 (insert line-separator)
791 (setq line-separator (format ",%s" line-breaking)))
792 (insert (format "{\"cns-radical\":\t%S},\t\"_comment\": \"%c\"%s"
794 (ideographic-radical value)
796 (setq attributes (delq 'cns-radical attributes))
798 (when (and (memq 'cns-strokes attributes)
799 (setq value (get-char-attribute char 'cns-strokes)))
800 (unless (eq value strokes)
802 (insert line-separator)
803 (setq line-separator (format ",%s" line-breaking)))
804 (insert (format "{\"cns-strokes\":\t%S}%s"
808 (setq strokes value)))
809 (setq attributes (delq 'cns-strokes attributes))
811 (when (and (memq 'ideographic- attributes)
812 (setq value (get-char-attribute char 'ideographic-)))
814 (insert line-separator)
815 (setq line-separator (format ",%s" line-breaking)))
816 (insert "{\"ideographic-\": ")
817 (setq lbs (concat "\n" (make-string (current-column) ?\ ))
820 (setq cell (car value))
822 (setq cell (decode-char '=ucs cell)))
823 (cond ((characterp cell)
827 (insert (format "%S" cell))
828 (char-db-json-insert-char-spec cell readable))
829 (setq separator lbs))
833 (if (consp (car cell))
834 (char-db-json-insert-char-spec cell readable)
835 (char-db-json-insert-char-reference cell readable))
836 (setq separator lbs))
840 (insert (prin1-to-string cell))
841 (setq separator " ")))
842 (setq value (cdr value)))
844 (insert line-breaking)
845 (setq attributes (delq 'ideographic- attributes)))
846 (when (and (memq 'total-strokes attributes)
847 (setq value (get-char-attribute char 'total-strokes)))
849 (insert line-separator)
850 (setq line-separator (format ",%s" line-breaking)))
851 (insert (format " \"total-strokes\": %S"
854 (setq attributes (delq 'total-strokes attributes))
856 (when (and (memq '->ideograph attributes)
857 (setq value (get-char-attribute char '->ideograph)))
859 (insert line-separator)
860 (setq line-separator (format ",%s" line-breaking)))
861 (insert (format "{\"->ideograph\":\t%s}%s"
862 (mapconcat (lambda (code)
863 (cond ((symbolp code)
866 (format "#x%04X" code))
869 line-breaking code))))
872 (setq attributes (delq '->ideograph attributes))
874 (if (equal (get-char-attribute char '->titlecase)
875 (get-char-attribute char '->uppercase))
876 (setq attributes (delq '->titlecase attributes)))
878 (dolist (ignored '(composition
879 ->denotational <-subsumptive ->ucs-unified
880 ->ideographic-component-forms))
881 (setq attributes (delq ignored attributes))))
883 (setq name (car attributes))
884 (unless (eq (setq value (get-char-attribute char name 'value-is-empty))
886 (cond ((setq ret (find-charset name))
887 (setq name (charset-name ret))
888 (when (not (memq name dest-ccss))
889 (setq dest-ccss (cons name dest-ccss))
891 (insert line-separator)
892 (setq line-separator (format ",%s" line-breaking)))
893 (char-db-json-insert-ccs-feature name value line-breaking))
895 ((string-match "^=>ucs@" (symbol-name name))
897 (insert line-separator)
898 (setq line-separator (format ",%s" line-breaking)))
899 (insert (format "{\"%-18s\": #x%04X},\t\"_comment\": \"%c\"%s"
900 name value (decode-char '=ucs value)
903 ((eq name 'jisx0208-1978/4X)
905 (insert line-separator)
906 (setq line-separator (format ",%s" line-breaking)))
907 (insert (format "{\"%-18s\": #x%04X}%s"
913 (not (eq name '->subsumptive))
914 (not (eq name '->uppercase))
915 (not (eq name '->lowercase))
916 (not (eq name '->titlecase))
917 (not (eq name '->canonical))
918 (not (eq name '->Bopomofo))
919 (not (eq name '->mistakable))
920 (not (eq name '->ideographic-variants))
921 (null (get-char-attribute
922 char (intern (format "%s*sources" name))))
923 (not (string-match "\\*sources$" (symbol-name name)))
924 (null (get-char-attribute
925 char (intern (format "%s*note" name))))
926 (not (string-match "\\*note$" (symbol-name name)))
927 (or (eq name '<-identical)
928 (eq name '<-uppercase)
929 (eq name '<-lowercase)
930 (eq name '<-titlecase)
931 (eq name '<-canonical)
932 (eq name '<-ideographic-variants)
933 ;; (eq name '<-synonyms)
934 (string-match "^<-synonyms" (symbol-name name))
935 (eq name '<-mistakable)
936 (when (string-match "^->" (symbol-name name))
938 ((string-match "^->fullwidth" (symbol-name name))
939 (not (and (consp value)
940 (characterp (car value))
942 (car value) '=ucs 'defined-only)))
947 ((or (eq name 'ideographic-structure)
948 (eq name 'ideographic-combination)
949 (eq name 'ideographic-)
950 (eq name '=decomposition)
951 (char-feature-base-name= '=decomposition name)
952 (char-feature-base-name= '=>decomposition name)
953 ;; (string-match "^=>*decomposition\\(@[^*]+\\)?$"
954 ;; (symbol-name name))
955 (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name))
956 (string-match "^\\(->\\|<-\\)[^*]*\\*sources$"
960 (insert line-separator)
961 (setq line-separator (format ",%s" line-breaking)))
962 (char-db-json-insert-relation-feature char name value
965 ((memq name '(ideograph=
966 original-ideograph-of
970 ;; simplified-ideograph-of
972 ;; ideographic-different-form-of
975 (insert line-separator)
976 (setq line-separator (format ",%s" line-breaking)))
977 (insert (format "{\"%-18s\":%s " name line-breaking))
978 (setq lbs (concat "\n" (make-string (current-column) ?\ ))
981 (setq cell (car value))
982 (if (and (consp cell)
987 (char-db-json-insert-alist cell readable)
988 (setq separator lbs))
991 (insert (prin1-to-string cell))
992 (setq separator " "))
993 (setq value (cdr value)))
995 (insert line-breaking))
998 (insert line-separator)
999 (setq line-separator (format ",%s" line-breaking)))
1000 (insert (format "{\"%-18s\": " name))
1001 (setq lbs (concat "\n" (make-string (current-column) ?\ ))
1003 (while (consp value)
1004 (setq cell (car value))
1005 (if (and (consp cell)
1007 (setq ret (condition-case nil
1015 (setq key (car (car rest)))
1016 (if (find-charset key)
1017 (setq cal (cons key cal))
1018 (setq al (cons key al)))
1019 (setq rest (cdr rest)))
1022 (char-db-json-insert-char-features ret
1026 (setq separator lbs))
1027 (setq ret (prin1-to-string cell))
1029 (if (< (+ (current-column)
1036 (setq separator " "))
1037 (setq value (cdr value)))
1039 (insert line-breaking))
1042 (insert line-separator)
1043 (setq line-separator (format ",%s" line-breaking)))
1044 (insert (format "{\"%-18s\":" name))
1045 (setq ret (prin1-to-string value))
1046 (unless (< (+ (current-column)
1050 (insert line-breaking))
1051 (insert ret " }" line-breaking)
1052 ;; (insert (format "(%-18s . %S)%s"
1057 (setq attributes (cdr attributes)))
1060 (defun char-db-json-char-data (char &optional readable
1063 (setq column (current-column)))
1065 (narrow-to-region (point)(point))
1066 (char-db-json-insert-char-features char readable attributes column)
1067 (goto-char (point-min))
1068 (while (re-search-forward "[ \t]+$" nil t)
1071 (goto-char (point-min))
1072 (while (re-search-forward "[ \t][ \t][ \t]*" nil t)
1073 (let ((column (current-column))
1074 (indent-tabs-mode t))
1075 (delete-region (match-beginning 0) (point))
1076 (indent-to column)))
1077 (goto-char (point-max))
1078 ;; (tabify (point-min)(point-max))
1081 (defun char-db-json-char-data-with-variant (char &optional printable
1083 script excluded-script)
1085 (char-db-json-char-data char printable)
1086 (let ((variants (char-variants char))
1090 (setq variants (sort variants #'<))
1091 (setq rest variants)
1092 (setq variants (cons char variants))
1094 (setq variant (car rest))
1095 (unless (get-char-attribute variant '<-subsumptive)
1096 (if (and (or (null script)
1097 (null (setq vs (get-char-attribute variant 'script)))
1099 (or (null excluded-script)
1100 (null (setq vs (get-char-attribute variant 'script)))
1101 (not (memq excluded-script vs))))
1102 (unless (and no-ucs-unified (get-char-attribute variant '=ucs))
1104 (char-db-json-char-data variant printable)
1105 (if (setq ret (char-variants variant))
1107 (or (memq (car ret) variants)
1108 ;; (get-char-attribute (car ret) '<-subsumptive)
1109 (setq rest (nconc rest (list (car ret)))))
1110 (setq ret (cdr ret)))))))
1111 (setq rest (cdr rest)))
1114 (defun char-db-json-insert-char-range-data (min max
1119 (while (<= code max)
1120 (setq char (decode-char '=ucs code))
1121 (if (encode-char char '=ucs 'defined-only)
1122 (char-db-json-char-data-with-variant char nil 'no-ucs-unified
1123 script excluded-script))
1124 (setq code (1+ code)))))
1126 (defun write-char-range-data-to-json-file (min max file
1129 (let ((coding-system-for-write char-db-file-coding-system))
1131 (insert (format "// -*- coding: %s -*-\n"
1132 char-db-file-coding-system))
1133 (char-db-json-insert-char-range-data min max script excluded-script)
1134 (write-region (point-min)(point-max) file))))
1137 (defun what-char-definition-json (char)
1138 (interactive (list (char-after)))
1139 (let ((buf (get-buffer-create "*Character Description*"))
1140 (the-buf (current-buffer))
1141 (win-conf (current-window-configuration)))
1143 (make-local-variable 'what-character-original-window-configuration)
1144 (setq what-character-original-window-configuration win-conf)
1145 (setq buffer-read-only nil)
1149 (char-db-json-char-data-with-variant char nil)
1150 (unless (char-attribute-alist char)
1151 (insert (format "// = %c\n"
1152 (let* ((rest (split-char char))
1156 (setq code (logior (lsh code 8)
1158 (decode-char ccs code)))))
1159 ;; (char-db-update-comment)
1160 (set-buffer-modified-p nil)
1161 (view-mode the-buf (lambda (buf)
1162 (set-window-configuration
1163 what-character-original-window-configuration)
1165 (goto-char (point-min)))
1167 (set-window-configuration
1168 what-character-original-window-configuration)
1169 (signal (car err) (cdr err)))))))
1171 (defun char-db-json-batch-view ()
1172 (setq terminal-coding-system 'binary)
1174 (let* ((target (pop command-line-args-left))
1177 (princ "Content-Type: application/json; charset=UTF-8
1182 (when (string-match "^char=\\(&[^&;]+;\\)" target)
1183 (setq ret (match-end 0))
1186 (www-uri-encode-object
1187 (www-uri-decode-object
1188 'character (match-string 1 target)))
1189 (substring target ret))))
1191 (mapcar (lambda (cell)
1192 (if (string-match "=" cell)
1194 (setq genre (substring cell 0 (match-beginning 0))
1195 ret (substring cell (match-end 0)))
1198 (decode-uri-string genre 'utf-8-mcs-er))
1200 (list (decode-uri-string cell 'utf-8-mcs-er))))
1201 (split-string target "&")))
1202 (setq ret (car target))
1203 (cond ((eq (car ret) 'char)
1204 (setq object (www-uri-decode-object (car ret)(cdr ret)))
1205 (when (characterp object)
1207 (char-db-json-char-data object)
1208 (encode-coding-region (point-min)(point-max)
1209 char-db-file-coding-system)
1210 (princ (buffer-string))
1213 ((eq (car ret) 'character)
1214 (setq object (www-uri-decode-object (car ret)(cdr ret)))
1215 (when (characterp object)
1217 (char-db-json-char-data object)
1218 (encode-coding-region (point-min)(point-max)
1219 char-db-file-coding-system)
1220 (princ (buffer-string))
1226 (princ (format "%S" err)))
1233 (provide 'char-db-json)
1235 ;;; char-db-json.el ends here