X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=2cdd3f9eb5a89916dec0dd83b86c0cb2743678bc;hb=0f491c1083161c021800689e467902d140758cdc;hp=27200fd0a85f12c6cc1d173842dd9f7c9397b046;hpb=681fab1941272adbc5cffab08552cd79213fee74;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index 27200fd..2cdd3f9 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -1,7 +1,7 @@ ;;; char-db-util.el --- Character Database utility -*- coding: utf-8-er; -*- -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010, 2011 MORIOKA Tomohiko. +;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2005,2006,2007, +;; 2008,2009,2010,2011,2012,2013,2014,2015,2016,2017,2018 MORIOKA Tomohiko. ;; Author: MORIOKA Tomohiko ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE. @@ -70,7 +70,7 @@ ?正 ?是 ?辵 ?彳 ?廴 ?㢟 ?行 ?齒 ?牙 ?足 ; 040 ?疋 ?品 ?龠 ?冊 ?㗊 ?舌 ?干 ?谷 ?只 ?㕯 ; 050 ?句 ?丩 ?古 ?十 ?卅 ?言 ?誩 ?音 ?䇂 ?丵 ; 060 - ?菐 ?𠬞 ?廾 ?共 ?異 ?舁 ?𦥑 ?䢅 ?爨 ?革 ; 070 + ?菐 ?𠬞 ?𠬜 ?共 ?異 ?舁 ?𦥑 ?䢅 ?爨 ?革 ; 070 ?鬲 ?䰜 ?爪 ?𠃨 ?鬥 ?又 ?𠂇 ?㕜 ?支 ?𦘒 ; 080 ?聿 ?畫 ?隶 ?臤 ?臣 ?殳 ?殺 ?𠘧 ?寸 ?皮 ; 090 ?㼱 ?攴 ?敎 ?卜 ?用 ?爻 ?㸚 ?𥄎 ?目 ?䀠 ; 100 @@ -80,6 +80,7 @@ ?歺 ?死 ?冎 ?骨 ?肉 ?筋 ?刀 ?刃 ?㓞 ?丰 ; 140 ?耒 ?𧢲 ?竹 ?箕 ?丌 ?左 ?工 ?㠭 ?巫 ?甘 ; 150 ?曰 ?乃 ?丂 ?可 ?兮 ?号 ?亏 ?旨 ?喜 ?壴 ; 160 +; ?旨 ?曰 ?乃 ?丂 ?可 ?兮 ?号 ?亏 ?喜 ?壴 ; 160 ?鼓 ?豈 ?豆 ?豊 ?豐 ?䖒 ?虍 ?虎 ?虤 ?皿 ; 170 ?𠙴 ?去 ?血 ?丶 ?丹 ?青 ?井 ?皀 ?鬯 ?食 ; 180 ?亼 ?會 ?倉 ?入 ?缶 ?矢 ?高 ?冂 ?𩫏 ?京 ; 190 @@ -93,6 +94,16 @@ ?𣎳 ?林 ?麻 ?尗 ?耑 ?韭 ?瓜 ?瓠 ?宀 ?宮 ; 270 ?呂 ?穴 ?㝱 ?𤕫 ?冖 ?𠔼 ?冃 ?㒳 ?网 ?襾 ; 280 ?巾 ?巿 ?帛 ?白 ?㡀 ?黹 ?人 ?𠤎 ?匕 ?从 ; 290 + ?比 ?北 ?丘 ?㐺 ?𡈼 ?重 ?臥 ?身 ?㐆 ?衣 ; 300 + ?裘 ?老 ?毛 ?毳 ?尸 ?尺 ?尾 ?履 ?舟 ?方 ; 310 + ?儿 ?兄 ?兂 ?皃 ?𠑹 ?先 ?秃 ?見 ?覞 ?欠 ; 320 + ?㱃 ?㳄 ?旡 ?頁 ?𦣻 ?面 ?丏 ?首 ?𥄉 ?須 ; 330 + ?彡 ?彣 ?文 ?髟 ?后 ?司 ?卮 ?卩 ?印 ?色 ; 340 + ?𠨍 ?辟 ?勹 ?包 ?茍 ?鬼 ?甶 ?厶 ?嵬 ?山 ; 350 + ?屾 ?屵 ?广 ?厂 ?丸 ?危 ?石 ?長 ?勿 ?冄 ; 360 + ?而 ?豕 ?㣇 ?彑 ?豚 ?豸 ?𤉡 ?易 ?象 ?馬 ; 370 + ?𢊁 ?鹿 ?麤 ?㲋 ?兔 ?萈 ?犬 ?㹜 ?鼠 ?能 ; 380 + ?熊 ?火 ?炎 ?黑 ?囪 ?焱 ?炙 ?赤 ?大 ?亦 ; 390 ]) (defun shuowen-radical (number) @@ -114,6 +125,14 @@ cyrillic-iso8859-5 greek-iso8859-7 thai-tis620 + ;; =mj + ;; =adobe-japan1-0 + ;; =adobe-japan1-1 + ;; =adobe-japan1-2 + ;; =adobe-japan1-3 + ;; =adobe-japan1-4 + ;; =adobe-japan1-5 + ;; =adobe-japan1-6 =jis-x0208 =jis-x0208@1978 =jis-x0208@1983 @@ -139,14 +158,6 @@ latin-viscii ethiopic-ucs =big5-cdp - =gt - =adobe-japan1-0 - =adobe-japan1-1 - =adobe-japan1-2 - =adobe-japan1-3 - =adobe-japan1-4 - =adobe-japan1-5 - =adobe-japan1-6 =hanyo-denshi/ja =hanyo-denshi/jb =hanyo-denshi/jc @@ -155,10 +166,39 @@ =hanyo-denshi/ia =hanyo-denshi/ib =hanyo-denshi/hg - ideograph-daikanwa-2 - ideograph-daikanwa - =cbeta + =hanyo-denshi/jt + =hanyo-denshi/ks + =hanyo-denshi/tk + ;; ==mj + ;; ==adobe-japan1-0 + ;; ==adobe-japan1-1 + ;; ==adobe-japan1-2 + ;; ==adobe-japan1-3 + ;; ==adobe-japan1-4 + ;; ==adobe-japan1-5 + ;; ==adobe-japan1-6 + ==jis-x0208 + ==jis-x0213-1 + ==jis-x0213-2 + ==jis-x0212 + ==hanyo-denshi/ja + ==hanyo-denshi/jb + ==hanyo-denshi/jc + ==hanyo-denshi/ft + ==hanyo-denshi/ia + ==hanyo-denshi/ib + ==hanyo-denshi/hg + ==hanyo-denshi/jt + ==hanyo-denshi/ks + ==hanyo-denshi/tk + =gt =gt-k + =daikanwa + =daikanwa@rev2 + =daikanwa@rev1 + =daikanwa/+p + ==daikanwa + =cbeta ideograph-hanziku-1 ideograph-hanziku-2 ideograph-hanziku-3 @@ -171,6 +211,32 @@ ideograph-hanziku-10 ideograph-hanziku-11 ideograph-hanziku-12 + ;; =>>>adobe-japan1-0 + ;; =>>>adobe-japan1-1 + ;; =>>>adobe-japan1-2 + ;; =>>>adobe-japan1-3 + ;; =>>>adobe-japan1-4 + ;; =>>>adobe-japan1-5 + ;; =>>>adobe-japan1-6 + ;; =>>>jis-x0208 + ;; =>>>jis-x0213-1 + ;; =>>>jis-x0213-2 + ;; =>>>hanyo-denshi/ja + ;; =>>>hanyo-denshi/jb + ;; =>>>hanyo-denshi/jc + ;; =>>>hanyo-denshi/ft + ;; =>>>hanyo-denshi/ib + ;; =>>>hanyo-denshi/hg + ;; =>>>hanyo-denshi/jt + ;; =>>>hanyo-denshi/ks + ;; =>>>gt + =>>adobe-japan1-0 + =>>adobe-japan1-1 + =>>adobe-japan1-2 + =>>adobe-japan1-3 + =>>adobe-japan1-4 + =>>adobe-japan1-5 + =>>adobe-japan1-6 =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-1@2000 @@ -178,32 +244,81 @@ =>>jis-x0213-2 =>>jis-x0208@1978 =>>hanyo-denshi/ft + =>>hanyo-denshi/jt + =>>hanyo-denshi/ks =>>gt - =>jis-x0208@usual + =>>daikanwa + =>>cbeta + =+>jis-x0208 + =+>jis-x0213-1 + =+>jis-x0213-2 + =+>adobe-japan1-0 + =+>adobe-japan1-1 + =+>adobe-japan1-2 + =+>adobe-japan1-3 + =+>adobe-japan1-4 + =+>adobe-japan1-5 + =+>adobe-japan1-6 + =+>jis-x0208@1978 =>jis-x0208 =>jis-x0208@1997 =>jis-x0213-1 =>jis-x0213-1@2000 =>jis-x0213-1@2004 - =>jis-x0213-2@usual =>jis-x0213-2 ==>ucs@bucs + =>iwds-1 + ;; =>ucs@hanyo-denshi =>ucs@iso =>ucs@unicode =>ucs@jis - =>ucs@JP =>ucs@cns =>ucs@ks + =+>ucs@iso + =+>ucs@unicode + =+>ucs@jis + =+>ucs@jis/1990 + =+>ucs@cns + =+>ucs@ks + =>>ucs@iso =>>ucs@unicode =>>ucs@jis =>>ucs@cns + =>>>ucs@iso + =>>>ucs@unicode + ==ucs@iso + ==ucs@unicode + ;; ==ucs@cns + ==gb2312 + ==ks-x1001 + ==cns11643-1 + ==cns11643-2 + ==cns11643-3 + ==cns11643-4 + ==cns11643-5 + ==cns11643-6 + ==cns11643-7 + ==gt + ==jis-x0208@1990 + ;; ==jis-x0208@1983 + ==jis-x0208@1978 + ==gt-k =ucs@iso =ucs@unicode + =ucs@cns + ==big5-cdp + ==cbeta =>>big5-cdp =>>gt-k + =+>gt + =+>big5-cdp =>gt + =>mj =>big5-cdp =>daikanwa + =>daikanwa/ho + =>cns11643-5 + =>cns11643-7 =big5 =big5-eten =>gt-k @@ -211,8 +326,58 @@ =>zinbun-oracle =ruimoku-v6 =>>ruimoku-v6 + ==ruimoku-v6 =jef-china3 - =shinjigen)) + =>cbeta + =shinjigen + =ucs-var-001 + =ucs-var-002 + =ucs-var-003 + =ucs-var-004 + =ucs-var-005 + =ucs-var-006 + =ucs-var-008 + =ucs-var-010 + =ucs-itaiji-001 + =ucs-itaiji-002 + =ucs-itaiji-003 + =ucs-itaiji-004 + =ucs-itaiji-005 + =ucs-itaiji-006 + =ucs-itaiji-007 + =ucs-itaiji-008 + =ucs-itaiji-009 + =ucs-itaiji-010 + =ucs-itaiji-011 + =>ucs-itaiji-001 + =>ucs-itaiji-002 + =>ucs-itaiji-003 + =>ucs-itaiji-004 + =>ucs-itaiji-005 + =>ucs-itaiji-006 + =>ucs-itaiji-007 + =>ucs-itaiji-009 + =big5-cdp-var-001 + =big5-cdp-var-002 + =big5-cdp-var-003 + =big5-cdp-var-004 + =big5-cdp-var-005 + =big5-cdp-var-010 + =big5-cdp-itaiji-001 + =big5-cdp-itaiji-002 + =big5-cdp-itaiji-003 + =>big5-cdp-itaiji-001 + =>ucs@iwds-1 + =>ucs@cognate + =>ucs@component + =>ucs-itaiji-001@iwds-1 + =>big5-cdp@iwds-1 + =>big5-cdp@component + =>big5-cdp@cognate + ==ucs@gb + =ucs@gb + ==ucs-var-002 + =ucs@JP/hanazono)) ;;; @ char-db formatters @@ -231,6 +396,70 @@ (setq char-spec (cons (cons 'name* ret) char-spec)) )) ) + ((encode-char char '=mj 'defined-only) + (setq char-spec nil) + (dolist (ccs (charset-list)) + (if (and (or (eq ccs '=mj) + ;; (eq (charset-property ccs 'iso-ir) 177) + (string-match "=ucs@" (symbol-name ccs)) + ) + (setq ccs (charset-name ccs)) + (null (assq ccs char-spec)) + (setq ret (encode-char char ccs 'defined-only))) + (setq char-spec (cons (cons ccs ret) char-spec)))) + ) + ((encode-char char '==mj 'defined-only) + (setq char-spec nil) + (dolist (ccs (charset-list)) + (if (and (or (eq ccs '==mj) + ;; (eq (charset-property ccs 'iso-ir) 177) + (string-match "=ucs@" (symbol-name ccs)) + ) + (setq ccs (charset-name ccs)) + (null (assq ccs char-spec)) + (setq ret (encode-char char ccs 'defined-only))) + (setq char-spec (cons (cons ccs ret) char-spec)))) + ) + ((encode-char char '=adobe-japan1 'defined-only) + (setq char-spec nil) + (dolist (ccs (charset-list)) + (if (and (or (memq ccs + '(=adobe-japan1-0 + =adobe-japan1-1 + =adobe-japan1-2 + =adobe-japan1-3 + =adobe-japan1-4 + =adobe-japan1-5 + =adobe-japan1-6 + )) + ;; (eq (charset-property ccs 'iso-ir) 177) + (string-match "=ucs@" (symbol-name ccs)) + ) + (setq ccs (charset-name ccs)) + (null (assq ccs char-spec)) + (setq ret (encode-char char ccs 'defined-only))) + (setq char-spec (cons (cons ccs ret) char-spec)))) + ) + ((encode-char char '==adobe-japan1 'defined-only) + (setq char-spec nil) + (dolist (ccs (charset-list)) + (if (and (or (memq ccs + '(==adobe-japan1-0 + ==adobe-japan1-1 + ==adobe-japan1-2 + ==adobe-japan1-3 + ==adobe-japan1-4 + ==adobe-japan1-5 + ==adobe-japan1-6 + )) + ;; (eq (charset-property ccs 'iso-ir) 177) + (string-match "=ucs@" (symbol-name ccs)) + ) + (setq ccs (charset-name ccs)) + (null (assq ccs char-spec)) + (setq ret (encode-char char ccs 'defined-only))) + (setq char-spec (cons (cons ccs ret) char-spec)))) + ) ((setq ret (catch 'tag (let ((rest char-db-coded-charset-priority-list) @@ -252,7 +481,10 @@ ;; =gt-k =jis-x0208@1997 )) - (string-match "=ucs@" (symbol-name ccs))) + (and (eq (charset-property ccs 'iso-ir) 177) + (not (eq (charset-name ccs) '=ucs@big5))) + ;; (string-match "=ucs@" (symbol-name ccs)) + ) (setq ccs (charset-name ccs)) (null (assq ccs char-spec)) (setq ret (encode-char char ccs 'defined-only))) @@ -295,7 +527,8 @@ (insert-char-attributes char readable (union (mapcar #'car char-spec) - required-features)) + required-features) + nil 'for-sub-node) (when temp-char ;; undefine temporary character ;; Current implementation is dirty. @@ -336,7 +569,7 @@ (insert-char-attributes ret readable (or al 'none) ; cal - )) + nil 'for-sub-node)) (insert (prin1-to-string value))) (insert ")") (insert line-breaking)) @@ -368,7 +601,7 @@ (insert-char-attributes ret readable al ; cal - ) + nil 'for-sub-node) (setq separator lbs)) (if separator (insert separator)) @@ -425,6 +658,8 @@ (setq ret (cond ((eq ccs 'arabic-iso8859-6) (decode-char ccs code-point)) + ;; ((eq ccs '=gt) + ;; (decode-builtin-char '==gt code-point)) ((and (memq ccs '(=gt-pj-1 =gt-pj-2 =gt-pj-3 @@ -441,7 +676,10 @@ (decode-builtin-char '=gt ret)) (t (decode-builtin-char ccs code-point)))) - (cond ((and (<= 0 (char-int ret)) + (cond ((null ret) + (or (decode-char ccs code-point) + (define-char (list (cons ccs code-point))))) + ((and (<= 0 (char-int ret)) (<= (char-int ret) #x1F)) (decode-char '=ucs (+ #x2400 (char-int ret)))) ((= (char-int ret) #x7F) @@ -451,46 +689,101 @@ (defvar char-db-convert-obsolete-format t) (defun char-db-insert-ccs-feature (name value line-breaking) - (insert - (format - (cond ((memq name '(=shinjigen - =shinjigen@1ed - =shinjigen@rev =shinjigen/+p@rev - =daikanwa/ho)) - "(%-18s . %04d)\t; %c") - ((eq name '=shinjigen@1ed/24pr) - "(%-18s . %04d)\t; %c") - ((or (memq name '(=daikanwa - =daikanwa@rev1 =daikanwa@rev2 - =daikanwa/+p =daikanwa/+2p - =>>daikanwa =>daikanwa - =gt =>>gt =>gt =gt-k =>>gt-k =>gt-k =cbeta - =zinbun-oracle =>zinbun-oracle)) - (string-match "^=adobe-" (symbol-name name))) - "(%-18s . %05d)\t; %c") - ((memq name '(=hanyo-denshi/ks mojikyo)) - "(%-18s . %06d)\t; %c") - ((>= (charset-dimension name) 2) - "(%-18s . #x%04X)\t; %c") - (t - "(%-18s . #x%02X)\t; %c")) - name - (if (= (charset-iso-graphic-plane name) 1) - (logior value - (cond ((= (charset-dimension name) 1) - #x80) - ((= (charset-dimension name) 2) - #x8080) - ((= (charset-dimension name) 3) - #x808080) - (t 0))) - value) - (char-db-decode-isolated-char name value))) - (if (and (= (charset-chars name) 94) - (= (charset-dimension name) 2)) - (insert (format " [%02d-%02d]" - (- (lsh value -8) 32) - (- (logand value 255) 32)))) + (cond + ((integerp value) + (insert + (format + (cond + ((memq name '(=>iwds-1 + ==shinjigen + =shinjigen + =shinjigen@1ed ==shinjigen@1ed + =shinjigen@rev ==shinjigen@rev + =shinjigen/+p@rev ==shinjigen/+p@rev + ===daikanwa/ho ==daikanwa/ho + =daikanwa/ho =>>daikanwa/ho =>daikanwa/ho)) + "(%-18s . %04d)\t; %c") + ((eq name '=shinjigen@1ed/24pr) + "(%-18s . %04d)\t; %c") + ((or + (memq name + '(===daikanwa + ==daikanwa =daikanwa =>>daikanwa =>daikanwa + =daikanwa@rev1 =daikanwa@rev2 + =daikanwa/+p ==daikanwa/+p ===daikanwa/+p + =>>daikanwa/+p + =daikanwa/+2p =>>daikanwa/+2p + =gt ==gt ===gt + =>>gt =+>gt =>gt + =gt-k ==gt-k ===gt-k + =>>gt-k =>gt-k + =adobe-japan1-0 ==adobe-japan1-0 ===adobe-japan1-0 + =adobe-japan1-1 ==adobe-japan1-1 ===adobe-japan1-1 + =adobe-japan1-2 ==adobe-japan1-2 ===adobe-japan1-2 + =adobe-japan1-3 ==adobe-japan1-3 ===adobe-japan1-3 + =adobe-japan1-4 ==adobe-japan1-4 ===adobe-japan1-4 + =adobe-japan1-5 ==adobe-japan1-5 ===adobe-japan1-5 + =adobe-japan1-6 ==adobe-japan1-6 ===adobe-japan1-6 + =>>adobe-japan1-0 =+>adobe-japan1-0 + =>>adobe-japan1-1 =+>adobe-japan1-1 + =>>adobe-japan1-2 =+>adobe-japan1-2 + =>>adobe-japan1-3 =+>adobe-japan1-3 + =>>adobe-japan1-4 =+>adobe-japan1-4 + =>>adobe-japan1-5 =+>adobe-japan1-5 + =>>adobe-japan1-6 =+>adobe-japan1-6 + =>cbeta =cbeta =>>cbeta ==cbeta ===cbeta + =zinbun-oracle =>zinbun-oracle + ===hng-jou ===hng-keg ===hng-dng ===hng-mam + ===hng-drt ===hng-kgk ===hng-myz ===hng-kda + ===hng-khi ===hng-khm ===hng-hok ===hng-kyd ===hng-sok + ===hng-yhk ===hng-kak ===hng-kar ===hng-kae + ===hng-sys ===hng-tsu ===hng-tzj + ===hng-hos ===hng-nak ===hng-jhk + ===hng-hod ===hng-gok ===hng-ink ===hng-nto + ===hng-nkm ===hng-k24 ===hng-nkk + ===hng-kcc ===hng-kcj ===hng-kbk ===hng-sik + ===hng-skk ===hng-kyu ===hng-ksk ===hng-wan + ===hng-okd ===hng-wad ===hng-kmi + ===hng-zkd ===hng-doh ===hng-jyu + ===hng-tzs ===hng-kss ===hng-kyo + ===hng-smk)) + ;; (string-match "^=adobe-" (symbol-name name)) + ) + "(%-18s . %05d)\t; %c") + ((memq name '(=hanyo-denshi/ks + ==hanyo-denshi/ks ===hanyo-denshi/ks + =>>hanyo-denshi/ks + =koseki ==koseki + =mj ==mj ===mj =>>mj =>mj + =zihai mojikyo)) + "(%-18s . %06d)\t; %c") + ((memq name '(=hanyo-denshi/tk ==hanyo-denshi/tk)) + "(%-18s . %08d)\t; %c") + ((>= (charset-dimension name) 2) + "(%-18s . #x%04X)\t; %c") + (t + "(%-18s . #x%02X)\t; %c")) + name + (if (= (charset-iso-graphic-plane name) 1) + (logior value + (cond ((= (charset-dimension name) 1) + #x80) + ((= (charset-dimension name) 2) + #x8080) + ((= (charset-dimension name) 3) + #x808080) + (t 0))) + value) + (char-db-decode-isolated-char name value))) + (if (and (= (charset-chars name) 94) + (= (charset-dimension name) 2)) + (insert (format " [%02d-%02d]" + (- (lsh value -8) 32) + (- (logand value 255) 32)))) + ) + (t + (insert (format "(%-18s . %s)" name value)) + )) (insert line-breaking)) (defun char-db-insert-relation-feature (char name value line-breaking @@ -516,7 +809,7 @@ (let ((char-db-ignored-attributes (cons '<-subsumptive char-db-ignored-attributes))) - (insert-char-attributes cell readable)) + (insert-char-attributes cell readable nil nil 'for-sub-node)) (setq separator lbs)) ) ((characterp cell) @@ -539,7 +832,10 @@ =jis-x0212 =jis-x0208@1983 =jis-x0208@1978 - =shinjigen)))) + =shinjigen + =shinjigen@1ed + =shinjigen@rev + =shinjigen/+p@rev)))) ((eq source 'CN) (setq required-features (union required-features @@ -592,7 +888,8 @@ (insert ")") (insert line-breaking))) -(defun insert-char-attributes (char &optional readable attributes column) +(defun insert-char-attributes (char &optional readable attributes column + for-sub-node) (unless column (setq column (current-column))) (let (name value ; has-long-ccs-name @@ -624,7 +921,7 @@ #'char-attribute-name<))) (insert "(") (when (memq '<-subsumptive attributes) - (when readable + (when (or readable (not for-sub-node)) (when (setq value (get-char-attribute char '<-subsumptive)) (char-db-insert-relation-feature char '<-subsumptive value line-breaking @@ -636,6 +933,12 @@ line-breaking ccss readable) (setq attributes (delq '<-denotational attributes))) + (when (and (memq '<-denotational@component attributes) + (setq value (get-char-attribute char '<-denotational@component))) + (char-db-insert-relation-feature char '<-denotational@component value + line-breaking + ccss readable) + (setq attributes (delq '<-denotational@component attributes))) (when (and (memq 'name attributes) (setq value (get-char-attribute char 'name))) (insert (format @@ -885,17 +1188,17 @@ (setq strokes value))) (setq attributes (delq 'kangxi-strokes attributes)) ) - (when (and (memq 'japanese-radical attributes) - (setq value (get-char-attribute char 'japanese-radical))) - (unless (eq value radical) - (insert (format "(japanese-radical\t . %S)\t; %c%s" - value - (ideographic-radical value) - line-breaking)) - (or radical - (setq radical value))) - (setq attributes (delq 'japanese-radical attributes)) - ) + ;; (when (and (memq 'japanese-radical attributes) + ;; (setq value (get-char-attribute char 'japanese-radical))) + ;; (unless (eq value radical) + ;; (insert (format "(japanese-radical\t . %S)\t; %c%s" + ;; value + ;; (ideographic-radical value) + ;; line-breaking)) + ;; (or radical + ;; (setq radical value))) + ;; (setq attributes (delq 'japanese-radical attributes)) + ;; ) (when (and (memq 'japanese-strokes attributes) (setq value (get-char-attribute char 'japanese-strokes))) (unless (eq value strokes) @@ -924,49 +1227,49 @@ (setq strokes value))) (setq attributes (delq 'cns-strokes attributes)) ) - (when (and (memq 'shinjigen-1-radical attributes) - (setq value (get-char-attribute char 'shinjigen-1-radical))) - (unless (eq value radical) - (insert (format "(shinjigen-1-radical . %S)\t; %c%s" - value - (ideographic-radical value) - line-breaking)) - (or radical - (setq radical value))) - (setq attributes (delq 'shinjigen-1-radical attributes)) - ) - (when (and (memq 'ideographic- attributes) - (setq value (get-char-attribute char 'ideographic-))) - (insert "(ideographic- ") - (setq lbs (concat "\n" (make-string (current-column) ?\ )) - separator nil) - (while (consp value) - (setq cell (car value)) - (if (integerp cell) - (setq cell (decode-char '=ucs cell))) - (cond ((characterp cell) - (if separator - (insert lbs)) - (if readable - (insert (format "%S" cell)) - (char-db-insert-char-spec cell readable)) - (setq separator lbs)) - ((consp cell) - (if separator - (insert lbs)) - (if (consp (car cell)) - (char-db-insert-char-spec cell readable) - (char-db-insert-char-reference cell readable)) - (setq separator lbs)) - (t - (if separator - (insert separator)) - (insert (prin1-to-string cell)) - (setq separator " "))) - (setq value (cdr value))) - (insert ")") - (insert line-breaking) - (setq attributes (delq 'ideographic- attributes))) + ;; (when (and (memq 'shinjigen-1-radical attributes) + ;; (setq value (get-char-attribute char 'shinjigen-1-radical))) + ;; (unless (eq value radical) + ;; (insert (format "(shinjigen-1-radical . %S)\t; %c%s" + ;; value + ;; (ideographic-radical value) + ;; line-breaking)) + ;; (or radical + ;; (setq radical value))) + ;; (setq attributes (delq 'shinjigen-1-radical attributes)) + ;; ) + ;; (when (and (memq 'ideographic- attributes) + ;; (setq value (get-char-attribute char 'ideographic-))) + ;; (insert "(ideographic- ") + ;; (setq lbs (concat "\n" (make-string (current-column) ?\ )) + ;; separator nil) + ;; (while (consp value) + ;; (setq cell (car value)) + ;; (if (integerp cell) + ;; (setq cell (decode-char '=ucs cell))) + ;; (cond ((characterp cell) + ;; (if separator + ;; (insert lbs)) + ;; (if readable + ;; (insert (format "%S" cell)) + ;; (char-db-insert-char-spec cell readable)) + ;; (setq separator lbs)) + ;; ((consp cell) + ;; (if separator + ;; (insert lbs)) + ;; (if (consp (car cell)) + ;; (char-db-insert-char-spec cell readable) + ;; (char-db-insert-char-reference cell readable)) + ;; (setq separator lbs)) + ;; (t + ;; (if separator + ;; (insert separator)) + ;; (insert (prin1-to-string cell)) + ;; (setq separator " "))) + ;; (setq value (cdr value))) + ;; (insert ")") + ;; (insert line-breaking) + ;; (setq attributes (delq 'ideographic- attributes))) (when (and (memq 'total-strokes attributes) (setq value (get-char-attribute char 'total-strokes))) (insert (format "(total-strokes . %S)%s" @@ -974,21 +1277,21 @@ line-breaking)) (setq attributes (delq 'total-strokes attributes)) ) - (when (and (memq '->ideograph attributes) - (setq value (get-char-attribute char '->ideograph))) - (insert (format "(->ideograph\t%s)%s" - (mapconcat (lambda (code) - (cond ((symbolp code) - (symbol-name code)) - ((integerp code) - (format "#x%04X" code)) - (t - (format "%s %S" - line-breaking code)))) - value " ") - line-breaking)) - (setq attributes (delq '->ideograph attributes)) - ) + ;; (when (and (memq '->ideograph attributes) + ;; (setq value (get-char-attribute char '->ideograph))) + ;; (insert (format "(->ideograph\t%s)%s" + ;; (mapconcat (lambda (code) + ;; (cond ((symbolp code) + ;; (symbol-name code)) + ;; ((integerp code) + ;; (format "#x%04X" code)) + ;; (t + ;; (format "%s %S" + ;; line-breaking code)))) + ;; value " ") + ;; line-breaking)) + ;; (setq attributes (delq '->ideograph attributes)) + ;; ) ;; (when (and (memq '->decomposition attributes) ;; (setq value (get-char-attribute char '->decomposition))) ;; (insert (format "(->decomposition\t%s)%s" @@ -1019,24 +1322,24 @@ line-breaking)) (setq attributes (delq '->mojikyo attributes)) ) - (when (and (memq 'hanyu-dazidian-vol attributes) - (setq value (get-char-attribute char 'hanyu-dazidian-vol))) - (insert (format "(hanyu-dazidian-vol . %d)%s" - value line-breaking)) - (setq attributes (delq 'hanyu-dazidian-vol attributes)) - ) - (when (and (memq 'hanyu-dazidian-page attributes) - (setq value (get-char-attribute char 'hanyu-dazidian-page))) - (insert (format "(hanyu-dazidian-page . %d)%s" - value line-breaking)) - (setq attributes (delq 'hanyu-dazidian-page attributes)) - ) - (when (and (memq 'hanyu-dazidian-char attributes) - (setq value (get-char-attribute char 'hanyu-dazidian-char))) - (insert (format "(hanyu-dazidian-char . %d)%s" - value line-breaking)) - (setq attributes (delq 'hanyu-dazidian-char attributes)) - ) + ;; (when (and (memq 'hanyu-dazidian-vol attributes) + ;; (setq value (get-char-attribute char 'hanyu-dazidian-vol))) + ;; (insert (format "(hanyu-dazidian-vol . %d)%s" + ;; value line-breaking)) + ;; (setq attributes (delq 'hanyu-dazidian-vol attributes)) + ;; ) + ;; (when (and (memq 'hanyu-dazidian-page attributes) + ;; (setq value (get-char-attribute char 'hanyu-dazidian-page))) + ;; (insert (format "(hanyu-dazidian-page . %d)%s" + ;; value line-breaking)) + ;; (setq attributes (delq 'hanyu-dazidian-page attributes)) + ;; ) + ;; (when (and (memq 'hanyu-dazidian-char attributes) + ;; (setq value (get-char-attribute char 'hanyu-dazidian-char))) + ;; (insert (format "(hanyu-dazidian-char . %d)%s" + ;; value line-breaking)) + ;; (setq attributes (delq 'hanyu-dazidian-char attributes)) + ;; ) (unless readable (dolist (ignored '(composition ->denotational <-subsumptive ->ucs-unified @@ -1044,156 +1347,158 @@ (setq attributes (delq ignored attributes)))) (while attributes (setq name (car attributes)) - (if (setq value (get-char-attribute char name)) - (cond ((setq ret (find-charset name)) - (setq name (charset-name ret)) - (if (and (not (memq name dest-ccss)) - (prog1 - (setq value (get-char-attribute char name)) - (setq dest-ccss (cons name dest-ccss)))) - (char-db-insert-ccs-feature name value line-breaking)) - ) - ((string-match "^=>ucs@" (symbol-name name)) - (insert (format "(%-18s . #x%04X)\t; %c%s" - name value (decode-char '=ucs value) - line-breaking)) - ) - ((eq name 'jisx0208-1978/4X) - (insert (format "(%-18s . #x%04X)%s" - name value - line-breaking)) - ) - ((and - (not readable) - (not (eq name '->subsumptive)) - (not (eq name '->uppercase)) - (not (eq name '->lowercase)) - (not (eq name '->titlecase)) - (not (eq name '->canonical)) - (not (eq name '->Bopomofo)) - (not (eq name '->mistakable)) - (not (eq name '->ideographic-variants)) - (null (get-char-attribute - char (intern (format "%s*sources" name)))) - (not (string-match "\\*sources$" (symbol-name name))) - (null (get-char-attribute - char (intern (format "%s*note" name)))) - (not (string-match "\\*note$" (symbol-name name))) - (or (eq name '<-identical) - (eq name '<-uppercase) - (eq name '<-lowercase) - (eq name '<-titlecase) - (eq name '<-canonical) - (eq name '<-ideographic-variants) - ;; (eq name '<-synonyms) - (string-match "^<-synonyms" (symbol-name name)) - (eq name '<-mistakable) - (when (string-match "^->" (symbol-name name)) - (cond - ((string-match "^->fullwidth" (symbol-name name)) - (not (and (consp value) - (characterp (car value)) - (encode-char - (car value) '=ucs 'defined-only))) - ) - (t))) - )) - ) - ((or (eq name 'ideographic-structure) - (eq name 'ideographic-combination) - (eq name 'ideographic-) - (eq name '=decomposition) - (string-match "^=>*decomposition\\(@[^*]+\\)?$" - (symbol-name name)) - (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name)) - (string-match "^\\(->\\|<-\\)[^*]*\\*sources$" - (symbol-name name)) - ) - (char-db-insert-relation-feature char name value - line-breaking - ccss readable)) - ((memq name '(ideograph= - original-ideograph-of - ancient-ideograph-of - vulgar-ideograph-of - wrong-ideograph-of - ;; simplified-ideograph-of - ideographic-variants - ;; ideographic-different-form-of - )) - (insert (format "(%-18s%s " name line-breaking)) - (setq lbs (concat "\n" (make-string (current-column) ?\ )) - separator nil) - (while (consp value) - (setq cell (car value)) - (if (and (consp cell) - (consp (car cell))) - (progn - (if separator - (insert lbs)) - (char-db-insert-alist cell readable) - (setq separator lbs)) - (if separator - (insert separator)) - (insert (prin1-to-string cell)) - (setq separator " ")) - (setq value (cdr value))) - (insert ")") - (insert line-breaking)) - ((consp value) - (insert (format "(%-18s " name)) - (setq lbs (concat "\n" (make-string (current-column) ?\ )) - separator nil) - (while (consp value) - (setq cell (car value)) - (if (and (consp cell) - (consp (car cell)) - (setq ret (condition-case nil - (find-char cell) - (error nil)))) - (progn - (setq rest cell - al nil - cal nil) - (while rest - (setq key (car (car rest))) - (if (find-charset key) - (setq cal (cons key cal)) - (setq al (cons key al))) - (setq rest (cdr rest))) - (if separator - (insert lbs)) - (insert-char-attributes ret - readable - al cal) - (setq separator lbs)) - (setq ret (prin1-to-string cell)) - (if separator - (if (< (+ (current-column) - (length ret) - (length separator)) - 76) - (insert separator) - (insert lbs))) - (insert ret) - (setq separator " ")) - (setq value (cdr value))) - (insert ")") + (unless (eq (setq value (get-char-attribute char name 'value-is-empty)) + 'value-is-empty) + (cond ((setq ret (find-charset name)) + (setq name (charset-name ret)) + (when (not (memq name dest-ccss)) + (setq dest-ccss (cons name dest-ccss)) + (char-db-insert-ccs-feature name value line-breaking)) + ) + ((string-match "^=>ucs@" (symbol-name name)) + (insert (format "(%-18s . #x%04X)\t; %c%s" + name value (decode-char '=ucs value) + line-breaking)) + ) + ((eq name 'jisx0208-1978/4X) + (insert (format "(%-18s . #x%04X)%s" + name value + line-breaking)) + ) + ((and + (not readable) + (not (eq name '->subsumptive)) + (not (eq name '->uppercase)) + (not (eq name '->lowercase)) + (not (eq name '->titlecase)) + (not (eq name '->canonical)) + (not (eq name '->Bopomofo)) + (not (eq name '->mistakable)) + (not (eq name '->ideographic-variants)) + (null (get-char-attribute + char (intern (format "%s*sources" name)))) + (not (string-match "\\*sources$" (symbol-name name))) + (null (get-char-attribute + char (intern (format "%s*note" name)))) + (not (string-match "\\*note$" (symbol-name name))) + (or (eq name '<-identical) + (eq name '<-uppercase) + (eq name '<-lowercase) + (eq name '<-titlecase) + (eq name '<-canonical) + (eq name '<-ideographic-variants) + ;; (eq name '<-synonyms) + (string-match "^<-synonyms" (symbol-name name)) + (eq name '<-mistakable) + (when (string-match "^->" (symbol-name name)) + (cond + ((string-match "^->fullwidth" (symbol-name name)) + (not (and (consp value) + (characterp (car value)) + (encode-char + (car value) '=ucs 'defined-only))) + ) + (t))) + )) + ) + ((or (eq name 'ideographic-structure) + (eq name 'ideographic-combination) + ;; (eq name 'ideographic-) + (eq name '=decomposition) + (char-feature-base-name= '=decomposition name) + (char-feature-base-name= '=>decomposition name) + ;; (string-match "^=>*decomposition\\(@[^*]+\\)?$" + ;; (symbol-name name)) + (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name name)) + (string-match "^\\(->\\|<-\\)[^*]*\\*sources$" + (symbol-name name)) + ) + (char-db-insert-relation-feature char name value + line-breaking + ccss readable)) + ;; ((memq name '(ideograph= + ;; original-ideograph-of + ;; ancient-ideograph-of + ;; vulgar-ideograph-of + ;; wrong-ideograph-of + ;; ;; simplified-ideograph-of + ;; ideographic-variants + ;; ;; ideographic-different-form-of + ;; )) + ;; (insert (format "(%-18s%s " name line-breaking)) + ;; (setq lbs (concat "\n" (make-string (current-column) ?\ )) + ;; separator nil) + ;; (while (consp value) + ;; (setq cell (car value)) + ;; (if (and (consp cell) + ;; (consp (car cell))) + ;; (progn + ;; (if separator + ;; (insert lbs)) + ;; (char-db-insert-alist cell readable) + ;; (setq separator lbs)) + ;; (if separator + ;; (insert separator)) + ;; (insert (prin1-to-string cell)) + ;; (setq separator " ")) + ;; (setq value (cdr value))) + ;; (insert ")") + ;; (insert line-breaking)) + ((consp value) + (insert (format "(%-18s " name)) + (setq lbs (concat "\n" (make-string (current-column) ?\ )) + separator nil) + (while (consp value) + (setq cell (car value)) + (if (and (consp cell) + (consp (car cell)) + (setq ret (condition-case nil + (find-char cell) + (error nil)))) + (progn + (setq rest cell + al nil + cal nil) + (while rest + (setq key (car (car rest))) + (if (find-charset key) + (setq cal (cons key cal)) + (setq al (cons key al))) + (setq rest (cdr rest))) + (if separator + (insert lbs)) + (insert-char-attributes ret + readable + al ; cal + nil 'for-sub-node) + (setq separator lbs)) + (setq ret (prin1-to-string cell)) + (if separator + (if (< (+ (current-column) + (length ret) + (length separator)) + 76) + (insert separator) + (insert lbs))) + (insert ret) + (setq separator " ")) + (setq value (cdr value))) + (insert ")") + (insert line-breaking)) + (t + (insert (format "(%-18s" name)) + (setq ret (prin1-to-string value)) + (unless (< (+ (current-column) + (length ret) + 3) + 76) (insert line-breaking)) - (t - (insert (format "(%-18s" name)) - (setq ret (prin1-to-string value)) - (unless (< (+ (current-column) - (length ret) - 3) - 76) - (insert line-breaking)) - (insert " . " ret ")" line-breaking) - ;; (insert (format "(%-18s . %S)%s" - ;; name value - ;; line-breaking)) - ) - )) + (insert " . " ret ")" line-breaking) + ;; (insert (format "(%-18s . %S)%s" + ;; name value + ;; line-breaking)) + ) + )) (setq attributes (cdr attributes))) (insert ")")))