Sync up with the current environment.
[chise/chiset.git] / char-db-turtle.el
1 ;;; char-db-turtle.el --- Character Database utility -*- coding: utf-8-er; -*-
2
3 ;; Copyright (C) 2017 MORIOKA Tomohiko.
4
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: CHISE, Character Database, RDF, Turtle, ISO/IEC 10646, UCS, Unicode, MULE.
7
8 ;; This file is part of CHISET (CHISE/Turtle).
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 'char-db-util)
28 (require 'cwiki-common)
29 (require 'isd-turtle)
30 (require 'ideograph-util)
31
32 (setq est-coded-charset-priority-list
33   '(; =ucs
34     =mj
35     =adobe-japan1-0
36     =adobe-japan1-1
37     =adobe-japan1-2
38     =adobe-japan1-3
39     =adobe-japan1-4
40     =adobe-japan1-5
41     =adobe-japan1-6
42     =ucs@iso
43     =jis-x0208 =jis-x0208@1990
44     =jis-x0213-1
45     =jis-x0213-1@2000 =jis-x0213-1@2004
46     =jis-x0213-2
47     =jis-x0212
48     =gt
49     =hanyo-denshi/ks
50     =hanyo-denshi/tk
51     =ucs-itaiji-001
52     =ucs-itaiji-002
53     =ucs-itaiji-003
54     =ucs-itaiji-004
55     =ucs-itaiji-005
56     =ucs-itaiji-006
57     =ucs-itaiji-007
58     =ucs-itaiji-009
59     =ucs-itaiji-084
60     =ucs-var-001
61     =ucs-var-002
62     =ucs-var-003
63     =ucs-var-004
64     =cns11643-1 =cns11643-2 =cns11643-3
65     =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
66     =gb2312
67     =big5-cdp
68     =ks-x1001
69     =gt-k
70     =ucs@unicode
71     =ucs@JP/hanazono
72     =gb12345
73     =ucs@cns
74     =ucs@gb
75     =zinbun-oracle =>zinbun-oracle
76     =daikanwa
77     =ruimoku-v6
78     =cbeta =jef-china3
79     =daikanwa/+2p
80     =+>ucs@iso =+>ucs@unicode
81     =+>ucs@jis
82     =+>ucs@cns
83     =+>ucs@ks
84     =+>ucs@jis/1990
85     =>mj
86     =>jis-x0208 =>jis-x0213-1
87     =>jis-x0208@1997
88     =>ucs@iwds-1
89     =>ucs@component
90     =>iwds-1
91     =>ucs@iso
92     =>ucs@unicode
93     =>ucs@jis =>ucs@cns =>ucs@ks
94     =>gt
95     =>gt-k
96     =>>ucs@iso =>>ucs@unicode
97     =>>ucs@jis =>>ucs@cns =>>ucs@ks
98     =>>gt-k
99     =>>hanyo-denshi/ks
100     ==mj
101     ==ucs@iso
102     ==ucs@unicode
103     ==adobe-japan1-0
104     ==adobe-japan1-1
105     ==adobe-japan1-2
106     ==adobe-japan1-3
107     ==adobe-japan1-4
108     ==adobe-japan1-5
109     ==adobe-japan1-6
110     ==ks-x1001
111     ==hanyo-denshi/ks
112     ==hanyo-denshi/tk
113     ==ucs@jis
114     ==gt
115     ==cns11643-1 ==cns11643-2 ==cns11643-3
116     ==cns11643-4 ==cns11643-5 ==cns11643-6 ==cns11643-7
117     ==jis-x0212
118     ==ucs@cns
119     ==koseki
120     ==daikanwa
121     ==gt-k
122     ==ucs@gb
123     ==ucs-itaiji-003
124     ==ucs@JP/hanazono
125     ==daikanwa/+2p
126     =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2
127     =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2
128     =+>hanyo-denshi/jt
129     =+>jis-x0208@1978
130     =>>gt
131     =+>adobe-japan1
132     =>>adobe-japan1
133     =jis-x0208@1983 =jis-x0208@1978
134     =>ucs-itaiji-001
135     =>ucs-itaiji-002
136     =>ucs-itaiji-005
137     ==>ucs@bucs
138     =big5
139     =>cbeta
140     ===mj
141     ===ucs@iso
142     ===ucs@unicode
143     ===hanyo-denshi/ks
144     ===ks-x1001
145     ===gt
146     ===gt-k
147     ===ucs@ks
148     ===ucs@gb
149     =shinjigen
150     =shinjigen@rev
151     =shinjigen@1ed
152     =shinjigen/+p@rev
153     ==shinjigen
154     ==shinjigen@rev
155     ==daikanwa/+p
156     ==shinjigen@1ed
157     ===daikanwa/+p
158     =>daikanwa/ho
159     ===daikanwa/ho
160     ))
161
162 (defvar chise-turtle-ccs-prefix-alist nil)
163
164 (defun charset-code-point-format-spec (ccs)
165   (cond ((memq ccs '(=ucs))
166          "0x%04X")
167         (t
168          (let ((ccs-name (symbol-name ccs)))
169            (cond
170             ((string-match
171               "\\(shinjigen\\|daikanwa/ho\\|=>iwds-1\\)"
172               ccs-name)
173              "%04d")
174             ((string-match
175               "\\(gt\\|daikanwa\\|adobe-japan1\\|cbeta\\|zinbun-oracle\\|hng\\)"
176               ccs-name)
177              "%05d")
178             ((string-match "\\(hanyo-denshi/ks\\|koseki\\|mj\\)" ccs-name)
179              "%06d")
180             ((string-match "hanyo-denshi/tk" ccs-name)
181              "%08d")
182             (t
183              "0x%X"))))))
184
185 (defun chise-turtle-uri-decode-feature-name (uri-feature)
186   (cond ((string= "a.ucs" uri-feature)
187          '=ucs)
188         ((string= "a.big5" uri-feature)
189          '=big5)
190         (t
191          (www-uri-decode-feature-name uri-feature))))
192
193 (defun chise-turtle-uri-encode-ccs-name (feature-name)
194   (cond
195    ((eq '=ucs feature-name)
196     "a.ucs")
197    ((eq '=big5 feature-name)
198     "a.big5")
199    ((eq '==>ucs@bucs feature-name)
200     "bucs")
201    (t
202     (mapconcat (lambda (c)
203                  (cond
204                   ((eq c ?@)
205                    "_")
206                   ((eq c ?+)
207                    "._.")
208                   ((eq c ?=)
209                    ".:.")
210                   (t
211                    (char-to-string c))))
212                (www-uri-encode-feature-name feature-name)
213                ""))))
214
215 (defun chise-turtle-uri-encode-feature-name (feature-name)
216   (cond
217    ((eq '->subsumptive feature-name)
218     ":subsume")
219    ((eq '<-denotational feature-name)
220     ":denotation-of")
221    ((eq '<-formed feature-name)
222     ":form-of")
223    ((eq 'hanyu-dazidian feature-name)
224     "ideo:hanyu-dazidian")
225    (t
226     (concat ":" (chise-turtle-uri-encode-ccs-name feature-name)))))
227
228 (defun chise-turtle-format-ccs-code-point (ccs code-point)
229   (let ((ccs-uri (chise-turtle-uri-encode-ccs-name ccs)))
230     (unless (assoc ccs-uri chise-turtle-ccs-prefix-alist)
231       (setq chise-turtle-ccs-prefix-alist
232             (cons (cons ccs-uri ccs)
233                   chise-turtle-ccs-prefix-alist)))
234     (format "%s:%s"
235             ccs-uri
236             (format (charset-code-point-format-spec ccs)
237                     code-point))))
238
239 (defun chise-turtle-encode-char (object)
240   (let ((ccs-list est-coded-charset-priority-list)
241         ccs ret ret2)
242     (if (setq ret (encode-char object '=ucs))
243         (chise-turtle-format-ccs-code-point '=ucs ret)
244       (while (and ccs-list
245                   (setq ccs (pop ccs-list))
246                   (not (setq ret (encode-char object ccs 'defined-only)))))
247       (cond (ret
248              (chise-turtle-format-ccs-code-point ccs ret)
249              )
250             ((and (setq ccs (car (split-char object)))
251                   (setq ret (encode-char object ccs)))
252              (chise-turtle-format-ccs-code-point ccs ret)
253              )
254             ((setq ret (get-char-attribute object 'ideographic-combination))
255              (format "ideocomb:%s"
256                      (mapconcat (lambda (cell)
257                                   (cond ((characterp cell)
258                                          (char-to-string cell)
259                                          )
260                                         ((setq ret2 (find-char cell))
261                                          (char-to-string ret2)
262                                          )
263                                         (t
264                                          (format "%S" cell)
265                                          )))
266                                 ret ""))
267              )
268             (t
269              (format (if est-hide-cgi-mode
270                          "system-char-id=0x%X"
271                        "system-char-id:0x%X")
272                      (encode-char object 'system-char-id))
273              )))))
274
275 (defun chise-split-feature-name (feature-name)
276   (let (base domain number meta)
277     (setq feature-name (symbol-name feature-name))
278     (if (string-match ".\\*." feature-name)
279         (setq meta (intern
280                     (format ":%s" (substring feature-name (1- (match-end 0)))))
281               feature-name (substring feature-name 0 (1+ (match-beginning 0)))))
282     (if (string-match "\\$_\\([0-9]+\\)$" feature-name)
283         (setq number (car (read-from-string (match-string 1 feature-name)))
284               feature-name (substring feature-name 0 (match-beginning 0))))
285     (if (string-match "@" feature-name)
286         (setq domain (car (read-from-string (substring feature-name (match-end 0))))
287               base (intern (substring feature-name 0 (match-beginning 0))))
288       (setq base (intern feature-name)))
289     (list base domain number meta)))
290
291 (defun chise-compose-feature-name (base domain number meta)
292   (let ((name (if domain
293                   (format "%s@%s" base domain)
294                 (symbol-name base))))
295     (if number
296         (setq name (format "%s$_%d" name number)))
297     (if meta
298         (setq name (format "%s*%s" name
299                            (substring (symbol-name meta) 1))))
300     (intern name)))
301
302 (defvar chise-feature-name-base-metadata-alist nil)
303
304 (defun chise-update-feature-name-base-metadata-alist ()
305   (interactive)
306   (let (base domain number metadata
307              bcell dcell ncell ret)
308     (setq chise-feature-name-base-metadata-alist nil)
309     (dolist (fname (sort (char-attribute-list)
310                          #'char-attribute-name<))
311       (setq ret (chise-split-feature-name fname)
312             base (car ret)
313             domain (nth 1 ret)
314             number (nth 2 ret)
315             metadata (nth 3 ret))
316       (when metadata
317         (if (setq bcell (assq base chise-feature-name-base-metadata-alist))
318             (if (setq dcell (assq domain (cdr bcell)))
319                 (if (setq ncell (assq number (cdr dcell)))
320                     (unless (memq metadata (cdr ncell))
321                       (setcdr ncell (nconc (cdr ncell)
322                                            (list metadata))))
323                   (setcdr dcell (cons (list number metadata)
324                                       (cdr dcell))))
325               (setcdr bcell (cons (list domain (list number metadata))
326                                   (cdr bcell))))
327           (setq chise-feature-name-base-metadata-alist
328                 (cons (list base (list domain (list number metadata)))
329                       chise-feature-name-base-metadata-alist))
330           )))))
331
332 (chise-update-feature-name-base-metadata-alist)
333
334 (defun chise-get-char-attribute-with-metadata (character feature-name-base domain)
335   (let ((value (get-char-attribute
336                 character
337                 (chise-compose-feature-name feature-name-base domain nil nil)
338                 '*feature-value-is-empty*))
339         dcell
340         base-metadata metadata
341         ret m i rest dest)
342     (unless (eq value '*feature-value-is-empty*)
343       (cond
344        ((and (setq ret (assq feature-name-base
345                              chise-feature-name-base-metadata-alist))
346              (setq dcell (assq domain (cdr ret))))
347         (if (setq ret (assq nil (cdr dcell)))
348             (dolist (bmn (cdr ret))
349               (when (setq m (get-char-attribute
350                              character
351                              (chise-compose-feature-name
352                               feature-name-base domain nil bmn)))
353                 (setq base-metadata
354                       (list* bmn m base-metadata)))))
355         (setq i 1
356               rest value)
357         (while (consp rest)
358           (setq dest
359                 (cons (cond
360                        ((setq ret (assq i (cdr dcell)))
361                         (setq metadata nil)
362                         (dolist (mn (cdr ret))
363                           (when (setq m (get-char-attribute
364                                          character
365                                          (chise-compose-feature-name
366                                           feature-name-base domain i mn)))
367                             (setq metadata (list* mn m metadata))))
368                         (if metadata
369                             (list* :target (car rest) metadata)
370                           (car rest))
371                         )
372                        (t (car rest)))
373                       dest))
374           (setq i (1+ i)
375                 rest (cdr rest)))
376         (list (nconc (nreverse dest) rest)
377               base-metadata)
378         )
379        (t (list value nil)))
380       )))
381           
382 (defun chise-split-ccs-name (ccs)
383   (cond ((eq ccs '=ucs)
384          '(ucs abstract-character nil)
385          )
386         ((eq ccs '=big5)
387          '(big5 abstract-character nil)
388          )
389         (t
390          (setq ccs (symbol-name ccs))
391          (let (ret)
392            (if (string-match "^\\(=[=+>]*\\)\\([^=>@*]+\\)@?" ccs)
393                (list (intern (match-string 2 ccs))
394                      (chise-decode-ccs-prefix (match-string 1 ccs))
395                      (if (string= (setq ret (substring ccs (match-end 0))) "")
396                          nil
397                        (intern ret))))
398            ))))
399
400 (defun chise-decode-ccs-prefix (ccs)
401   (or (cdr (assoc ccs '(("==>" . super-abstract-character)
402                         ("=>"  . abstract-character)
403                         ("=+>" . unified-glyph)
404                         ("="   . abstract-glyph)
405                         ("=>>" . detailed-glyph)
406                         ("=="  . abstract-glyph-form)
407                         ("===" . glyph-image))))
408       'character))
409
410 (defun chise-turtle-uri-split-ccs (uri-ccs)
411   (cond
412    ((string-match "^a2\\." uri-ccs)
413     (cons ":super-abstract-character"
414           (substring uri-ccs (match-end 0)))
415     )
416    ((string-match "^a\\." uri-ccs)
417     (cons ":abstract-character"
418           (substring uri-ccs (match-end 0)))
419     )
420    ((string-match "^o\\." uri-ccs)
421     (cons ":unified-glyph"
422           (substring uri-ccs (match-end 0)))
423     )
424    ((string-match "^rep\\." uri-ccs)
425     (cons ":abstract-glyph"
426           (substring uri-ccs (match-end 0)))
427     )
428    ((string-match "^g\\." uri-ccs)
429     (cons ":detailed-glyph"
430           (substring uri-ccs (match-end 0)))
431     )
432    ((string-match "^g2\\." uri-ccs)
433     (cons ":abstract-glyph-form"
434           (substring uri-ccs (match-end 0)))
435     )
436    ((string-match "^gi\\." uri-ccs)
437     (cons ":abstract-glyph-form"
438           (substring uri-ccs (match-end 0)))
439     )
440    ((string-match "^repi\\." uri-ccs)
441     (cons ":glyph-image"
442           (substring uri-ccs (match-end 0)))
443     )
444    (t (cons ":character" uri-ccs))))
445
446 (defun char-db-turtle-insert-relation-feature (char name value line-breaking
447                                                     ccss readable)
448   (insert (format "    %s%s        "
449                   (chise-turtle-uri-encode-feature-name name)
450                   line-breaking))
451   (char-db-turtle-insert-relations value readable)
452   (insert " ;")
453   )
454
455 (defun char-db-turtle-insert-metadata (name value)
456   (let (col indent)
457     (insert (format "%-7s " name))
458     (cond
459      ((or (eq name :sources)
460           (eq name :denied))
461       (setq col (current-column))
462       (setq indent (make-string col ?\ ))
463       (insert (format "chisebib:%s"
464                       (chise-turtle-uri-encode-ccs-name (car value))))
465       (dolist (source (cdr value))
466         (insert (format " ,\n%schisebib:%s" indent
467                         (chise-turtle-uri-encode-ccs-name source))))
468       nil)
469      (t
470       (insert (format "%S" value))
471       nil))))
472
473 (defun char-db-turtle-insert-radical (radical-number)
474   (insert (format "        %3d ; # %c"
475                   radical-number
476                   (ideographic-radical radical-number)))
477   'with-separator)
478
479 (defun char-db-turtle-insert-list (value &optional readable)
480   (let (lbs separator rest cell al cal key ret)
481     (insert "( ")
482     (setq lbs (concat "\n" (make-string (current-column) ?\ ))
483           separator nil)
484     (while (consp value)
485       (setq cell (car value))
486       (if (and (consp cell)
487                (consp (car cell))
488                (setq ret (condition-case nil
489                              (find-char cell)
490                            (error nil))))
491           (progn
492             (setq rest cell
493                   al nil
494                   cal nil)
495             (while rest
496               (setq key (car (car rest)))
497               (if (find-charset key)
498                   (setq cal (cons key cal))
499                 (setq al (cons key al)))
500               (setq rest (cdr rest)))
501             (if separator
502                 (insert lbs))
503             (char-db-turtle-insert-char-features ret
504                                                  readable
505                                                  al
506                                                  nil 'for-sub-node)
507             (setq separator lbs))
508         (setq ret (prin1-to-string cell))
509         (if separator
510             (if (< (+ (current-column)
511                       (length ret)
512                       (length separator))
513                    76)
514                 (insert separator)
515               (insert lbs)))
516         (insert ret)
517         (setq separator " "))
518       (setq value (cdr value)))
519     (insert " ) ;")
520     'with-separator))
521
522 (defun char-db-turtle-insert-source-list (value &optional readable)
523   (let (lbs separator rest cell al cal key ret)
524     (setq lbs (concat " ,\n" (make-string (current-column) ?\ ))
525           separator nil)
526     (while (consp value)
527       (setq cell (car value))
528       (if (and (consp cell)
529                (consp (car cell))
530                (setq ret (condition-case nil
531                              (find-char cell)
532                            (error nil))))
533           (progn
534             (setq rest cell
535                   al nil
536                   cal nil)
537             (while rest
538               (setq key (car (car rest)))
539               (if (find-charset key)
540                   (setq cal (cons key cal))
541                 (setq al (cons key al)))
542               (setq rest (cdr rest)))
543             (if separator
544                 (insert lbs))
545             (char-db-turtle-insert-char-features ret
546                                                  readable
547                                                  al
548                                                  nil 'for-sub-node)
549             (setq separator lbs))
550         (setq ret (prin1-to-string cell))
551         (if separator
552             (if (< (+ (current-column)
553                       (length ret)
554                       (length separator))
555                    76)
556                 (insert separator)
557               (insert lbs)))
558         (if (string-match "=" ret)
559             (insert (format "%s:%s"
560                             (substring ret 0 (match-beginning 0))
561                             (substring ret (match-end 0))))
562           (insert (format "chisebib:%s" ret)))
563         (setq separator " , "))
564       (setq value (cdr value)))
565     (insert " ;")
566     'with-separator))
567
568 (defun char-db-turtle-insert-relations (value &optional readable)
569   (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
570         separator cell)
571     (if (characterp value)
572         (setq value (list value)))
573     (while (consp value)
574       (setq cell (car value))
575       (if (integerp cell)
576           (setq cell (decode-char '=ucs cell)))
577       (if separator
578           (insert separator)
579         (setq separator (format " ,%s" lbs)))
580       (if (characterp cell)
581           (insert (format "%-20s" (chise-turtle-encode-char cell)))
582         (char-db-turtle-insert-char-ref cell '<-formed))
583       (setq value (cdr value)))
584     nil))
585
586 (defun char-db-turtle-insert-target-value (value feature-name-base &optional readable)
587   (cond ((eq feature-name-base 'ideographic-radical)
588          (char-db-turtle-insert-radical value)
589          )
590         ((or (eq feature-name-base 'ideographic-combination)
591              (eq feature-name-base '=decomposition)
592              (eq feature-name-base '<-formed)
593              (string-match "^\\(->\\|<-\\)[^*]*$" (symbol-name feature-name-base)))
594          (char-db-turtle-insert-relations value readable)
595          )
596         ((eq feature-name-base 'comment)
597          (insert (format "%S" value))
598          nil)
599         ((eq feature-name-base 'sources)
600          (char-db-turtle-insert-source-list value readable)
601          )
602         ((consp value)
603          (char-db-turtle-insert-list value readable)
604          )
605         (t
606          (insert (format " %-14s" value))
607          nil)))
608
609 (defun char-db-turtle-insert-feature-value (value metadata domain feature-name-base)
610   (let (indent0 indent rest mdname mdval lb)
611     (cond
612      ((or metadata domain)
613       (setq indent0 (make-string (current-column) ?\ ))
614       (insert "[ ")
615       (setq indent (make-string (current-column) ?\ ))
616       (when domain
617         (insert (format ":context domain:%-7s ;"
618                         (chise-turtle-uri-encode-ccs-name domain)))
619         (setq lb t))
620       (setq rest metadata)
621       (while rest
622         (setq mdname (pop rest)
623               mdval  (pop rest))
624         (if lb
625             (insert (format "\n%s" indent))
626           (setq lb t))
627         (unless (char-db-turtle-insert-metadata mdname mdval)
628           (insert " ;")))
629       (if lb
630           (insert (format "\n%s" indent)))
631       (insert ":target  ")
632       (if (char-db-turtle-insert-target-value value feature-name-base)
633           (insert (format "\n%s] ;" indent0))
634         (insert " ] ;"))
635       'with-separator)
636      (t
637       (char-db-turtle-insert-target-value value feature-name-base)
638       ))))
639
640 (defun char-db-turtle-insert-char-ref (char-ref feature-name-base)
641   (let (indent0 indent rest mdname mdval lb last-sep)
642     (setq indent0 (make-string (current-column) ?\ ))
643     (insert "[ ")
644     (setq indent (make-string (current-column) ?\ ))
645     (setq rest char-ref)
646     (while rest
647       (setq mdname (pop rest)
648             mdval  (pop rest))
649       (if lb
650           (insert (format "%s\n%s"
651                           (if last-sep
652                               ""
653                             " ;")
654                           indent))
655         (setq lb t))
656       (setq last-sep
657             (cond ((eq mdname :target)
658                    (insert ":target  ")
659                    (char-db-turtle-insert-target-value mdval feature-name-base)
660                      )
661                   (t
662                    (char-db-turtle-insert-metadata mdname mdval)))))
663     (if last-sep
664         (insert (format "\n%s]" indent0))
665       (insert " ]"))
666     nil))
667   
668 (defun char-db-turtle-insert-char-features (char
669                                             &optional readable attributes column
670                                             for-sub-node)
671   (unless column
672     (setq column (current-column)))
673   (let ((est-coded-charset-priority-list est-coded-charset-priority-list)
674         (est-view-url-prefix "http://chise.org/est/view")
675         id obj-id type domain
676         name value metadata
677         name-base name-domain
678         radical strokes
679         (line-breaking (concat "\n" (make-string column ?\ )))
680         line-separator
681         ret
682         skey
683         dest-ccss ; sources required-features
684         ccss eq-cpos-list
685         uri-ccs uri-cpos ccs-base children child-ccs-list col indent)
686     (let (atr-d)
687       (setq attributes
688             (sort (if attributes
689                       (if (consp attributes)
690                           (progn
691                             (dolist (name attributes)
692                               (unless (or (memq name char-db-ignored-attributes)
693                                           (string-match "\\*" (symbol-name name)))
694                                 (if (find-charset name)
695                                     (push name ccss))
696                                 (push name atr-d)))
697                             atr-d))
698                     (dolist (name (char-attribute-list))
699                       (unless (or (memq name char-db-ignored-attributes)
700                                   (string-match "\\*" (symbol-name name)))
701                         (if (find-charset name)
702                             (push name ccss))
703                         (push name atr-d)))
704                     atr-d)
705                   #'char-attribute-name<)))
706     (setq line-separator line-breaking)
707     (setq id (chise-turtle-encode-char char))
708     (setq obj-id (file-name-nondirectory id))
709     (string-match ":" obj-id)
710     (setq uri-ccs (substring obj-id 0 (match-beginning 0))
711           uri-cpos (substring obj-id (match-end 0)))
712     (insert (format "%s" obj-id))
713     (setq ret (assoc uri-ccs chise-turtle-ccs-prefix-alist))
714     (setq dest-ccss (list (cdr ret)))
715     (setq ret (chise-split-ccs-name (cdr ret)))
716     (setq ccs-base (car ret)
717           type (nth 1 ret)
718           domain (nth 2 ret))
719     (insert (format "%s    a chisegg:%s ;" line-separator type))
720     (insert (format "%s    :%s-of" line-breaking type))
721     (if (null domain)
722         (insert (format " %s:%s ;"
723                         (chise-turtle-uri-encode-ccs-name ccs-base) uri-cpos))
724       (insert " [ ")
725       (setq col (current-column))
726       (insert (format ":context domain:%-7s ;\n%s:target %7s:%-7s ] ;"
727                       (chise-turtle-uri-encode-ccs-name domain)
728                       (make-string col ?\ )
729                       (chise-turtle-uri-encode-ccs-name ccs-base) uri-cpos)))
730     (when (memq '<-subsumptive attributes)
731       (when (or readable (not for-sub-node))
732         (when (setq value (get-char-attribute char '<-subsumptive))
733           (insert line-separator)
734           (char-db-turtle-insert-relation-feature char '<-subsumptive value
735                                                   line-breaking
736                                                   ccss readable)
737           ))
738       (setq attributes (delq '<-subsumptive attributes))
739       )
740     (when (and (memq '<-denotational attributes)
741                (setq value (get-char-attribute char '<-denotational)))
742       (insert line-separator)
743       (char-db-turtle-insert-relation-feature char '<-denotational value
744                                             line-breaking
745                                             ccss readable)
746       (setq attributes (delq '<-denotational attributes)))
747     (when (and (memq '<-denotational@component attributes)
748                (setq value
749                      (get-char-attribute char '<-denotational@component)))
750       (insert line-separator)
751       (char-db-turtle-insert-relation-feature
752        char '<-denotational@component value
753        line-breaking
754        ccss readable)
755       (setq attributes (delq '<-denotational@component attributes)))
756     (when (and (memq 'name attributes)
757                (setq value (get-char-attribute char 'name)))
758       (insert (format "%s    " line-separator))
759       (insert (format
760                (if (> (+ (current-column) (length value)) 48)
761                    ":name %S ;"
762                  ":name                 %S ;")
763                value))
764       (setq attributes (delq 'name attributes))
765       )
766     (when (and (memq 'name* attributes)
767                (setq value (get-char-attribute char 'name*)))
768       (insert line-separator)
769       (insert (format
770                (if (> (+ (current-column) (length value)) 48)
771                    " \"name*\": %S"
772                  " \"name*\":                 %S")
773                value))
774       (setq attributes (delq 'name* attributes))
775       )
776     (when (and (memq 'script attributes)
777                (setq value (get-char-attribute char 'script)))
778       (insert (format "%s    :script\t\t  ( %s ) ;"
779                       line-separator
780                       (mapconcat (lambda (cell)
781                                    (format "script:%s" cell))
782                                  value " ")))
783       (setq attributes (delq 'script attributes))
784       )
785     ;; (dolist (name '(=>ucs =>ucs*))
786     ;;   (when (and (memq name attributes)
787     ;;              (setq value (get-char-attribute char name)))
788     ;;     (insert line-separator)
789     ;;     (insert (format " \"%-20s\":  #x%04X,\t\"_comment\": \"%c\""
790     ;;                     name value (decode-char '=ucs value)))
791     ;;     (setq attributes (delq name attributes))))
792     (when (and (memq '=>ucs attributes)
793                (setq value (get-char-attribute char '=>ucs)))
794       (insert (format "%s    :to.ucs\t\t  a.ucs:0x%04X ; # %c"
795                       line-separator value (decode-char '=ucs value)))
796       (setq attributes (delq '=>ucs attributes))
797       )
798     (when (setq value (get-char-attribute char '=>ucs*))
799       (insert (format "%s    :to.canonical-ucs\ta.ucs:0x%04X ; # %c"
800                       line-separator value (decode-char '=ucs value)))
801       (setq attributes (delq '=>ucs* attributes))
802       )
803     (dolist (name '(=>ucs@gb =>ucs@big5))
804       (when (and (memq name attributes)
805                  (setq value (get-char-attribute char name)))
806         (insert line-separator)
807         (insert (format " \"%-20s\":  #x%04X,\t\"_comment\": \"%c\"%s"
808                         name value
809                         (decode-char (intern
810                                       (concat "="
811                                               (substring
812                                                (symbol-name name) 2)))
813                                      value)
814                         line-breaking))
815         (setq attributes (delq name attributes))
816         ))
817     (when (and (memq 'general-category attributes)
818                (setq value (get-char-attribute char 'general-category)))
819       (insert (format "%s    :general-category     \"%s\" ; # %s"
820                       line-separator value
821                       (cond ((rassoc value unidata-normative-category-alist)
822                              "Normative Category")
823                             ((rassoc value unidata-informative-category-alist)
824                              "Informative Category")
825                             (t
826                              "Unknown Category"))))
827       (setq attributes (delq 'general-category attributes))
828       )
829     (when (and (memq 'bidi-category attributes)
830                (setq value (get-char-attribute char 'bidi-category)))
831       (insert (format "%s    :bidi-category        %S ;"
832                       line-separator
833                       value))
834       (setq attributes (delq 'bidi-category attributes))
835       )
836     (unless (or (not (memq 'mirrored attributes))
837                 (eq (setq value (get-char-attribute char 'mirrored 'empty))
838                     'empty))
839       (insert (format "%s    :mirrored             \"%s\" ;"
840                       line-separator
841                       value))
842       (setq attributes (delq 'mirrored attributes))
843       )
844     (cond
845      ((and (memq 'decimal-digit-value attributes)
846            (setq value (get-char-attribute char 'decimal-digit-value)))
847       (insert (format "%s    :decimal-digit-value  %2d ;"
848                       line-separator value))
849       (setq attributes (delq 'decimal-digit-value attributes))
850       (when (and (memq 'digit-value attributes)
851                  (setq value (get-char-attribute char 'digit-value)))
852         (insert (format "%s    :digit-value\t  %2d ;"
853                         line-separator value))
854         (setq attributes (delq 'digit-value attributes))
855         )
856       (when (and (memq 'numeric-value attributes)
857                  (setq value (get-char-attribute char 'numeric-value)))
858         (insert (format "%s    :numeric-value\t  %2d ;"
859                         line-separator value))
860         (setq attributes (delq 'numeric-value attributes))
861         )
862       )
863      (t
864       (when (and (memq 'digit-value attributes)
865                  (setq value (get-char-attribute char 'digit-value)))
866         (insert line-separator)
867         (insert (format "%s    :digit-value\t  %2d ;"
868                         line-separator value))
869         (setq attributes (delq 'digit-value attributes))
870         )
871       (when (and (memq 'numeric-value attributes)
872                  (setq value (get-char-attribute char 'numeric-value)))
873         (insert line-separator)
874         (insert (format "%s    :numeric-value\t  %2d ;"
875                         line-separator value))
876         (setq attributes (delq 'numeric-value attributes))
877         )))
878     (when (and (memq 'iso-10646-comment attributes)
879                (setq value (get-char-attribute char 'iso-10646-comment)))
880       (insert line-separator)
881       (insert (format "{\"iso-10646-comment\":\t %S}%s"
882                       value
883                       line-breaking))
884       (setq attributes (delq 'iso-10646-comment attributes))
885       )
886     (when (and (memq 'morohashi-daikanwa attributes)
887                (setq value (get-char-attribute char 'morohashi-daikanwa)))
888       (insert line-separator)
889       (insert (format "%s    :morohashi-daikanwa\t  %S ;"
890                       line-separator value))
891       (setq attributes (delq 'morohashi-daikanwa attributes))
892       )
893     (setq radical nil
894           strokes nil)
895     (when (and (memq 'ideographic-radical attributes)
896                (setq value (get-char-attribute char 'ideographic-radical)))
897       (setq radical value)
898       (insert (format "%s    ideo:radical         %3d ; # %c "
899                       line-separator
900                       radical
901                       (ideographic-radical radical)
902                       ))
903       (setq attributes (delq 'ideographic-radical attributes))
904       )
905     (when (and (memq 'shuowen-radical attributes)
906                (setq value (get-char-attribute char 'shuowen-radical)))
907       (insert line-separator)
908       (insert (format " \"shuowen-radical\":\t %S,\t\"_comment\": \"%c\""
909                       value
910                       (shuowen-radical value)))
911       (setq attributes (delq 'shuowen-radical attributes))
912       )
913     (let (key)
914       (dolist (domain
915                (append
916                 char-db-feature-domains
917                 (let (dest domain)
918                   (dolist (feature (char-attribute-list))
919                     (setq feature (symbol-name feature))
920                     (when (string-match
921                            "\\(radical\\|strokes\\)@\\([^@*]+\\)\\(\\*\\|$\\)"
922                            feature)
923                       (setq domain (intern (match-string 2 feature)))
924                      (unless (memq domain dest)
925                        (setq dest (cons domain dest)))))
926                   (sort dest #'string<))))
927         (setq key (intern (format "%s@%s" 'ideographic-radical domain)))
928         (when (and (memq key attributes)
929                    (setq value (get-char-attribute char key)))
930           (setq radical value)
931           (insert (format "%s    ideo:radical           "
932                           line-separator))
933           (char-db-turtle-insert-feature-value value nil domain 'ideographic-radical)
934           (setq attributes (delq key attributes))
935           )
936         (setq key (intern (format "%s@%s" 'ideographic-strokes domain)))
937         (when (and (memq key attributes)
938                    (setq value (get-char-attribute char key)))
939           (setq strokes value)
940           (insert (format "%s    ideo:strokes           [ "
941                           line-separator))
942           (setq col (current-column))
943           (setq indent (make-string col ?\ ))
944           (insert (format ":context domain:%-7s ;\n%s:target  %S"
945                           (chise-turtle-uri-encode-ccs-name domain)
946                           indent strokes))
947           (setq attributes (delq key attributes))
948           (setq skey (intern (format "%s*sources" key)))
949           (when (and (memq skey attributes)
950                      (setq value (get-char-attribute char skey)))
951             (insert (format " ;\n%s:sources (" indent))
952             (setq col (current-column))
953             (setq indent (make-string col ?\ ))
954             (insert (format " chisebib:%s" (car value)))
955             (dolist (cell (cdr value))
956               (insert (format "\n%s chisebib:%s" indent cell)))
957             (insert " )"))
958           (setq attributes (delq skey attributes))
959           (insert " ] ;")
960           )
961         (setq key (intern (format "%s@%s" 'total-strokes domain)))
962         (when (and (memq key attributes)
963                    (setq value (get-char-attribute char key)))
964           (insert (format "%s    ideo:total-strokes     [ "
965                           line-separator))
966           (setq col (current-column))
967           (insert (format ":context domain:%-7s ;\n%s:target  %S"
968                           (chise-turtle-uri-encode-ccs-name domain)
969                           (make-string col ?\ )
970                           value))
971           (setq attributes (delq key attributes))
972           (setq skey (intern (format "%s*sources" key)))
973           (insert " ] ;")
974           )
975         (dolist (feature '(ideographic-radical
976                            ideographic-strokes
977                            total-strokes))
978           (setq key (intern (format "%s@%s*sources" feature domain)))
979           (when (and (memq key attributes)
980                      (setq value (get-char-attribute char key)))
981             (insert line-separator)
982             (insert (format " \"%s\":%s" key line-breaking))
983             (dolist (cell value)
984               (insert (format " %s" cell)))
985             (setq attributes (delq key attributes))
986             ))
987         ))
988     (when (and (memq 'ideographic-strokes attributes)
989                (setq value (get-char-attribute char 'ideographic-strokes)))
990       (setq strokes value)
991       (insert (format "%s    ideo:strokes          %2d ;"
992                       line-separator strokes))
993       (setq attributes (delq 'ideographic-strokes attributes))
994       )
995     (when (and (memq 'kangxi-radical attributes)
996                (setq value (get-char-attribute char 'kangxi-radical)))
997       (unless (eq value radical)
998         (insert line-separator)
999         (insert (format "{\"kangxi-radical\":\t%S},\t\"_comment\": \"%c\"%s"
1000                         value
1001                         (ideographic-radical value)
1002                         line-breaking))
1003         (or radical
1004             (setq radical value)))
1005       (setq attributes (delq 'kangxi-radical attributes))
1006       )
1007     (when (and (memq 'kangxi-strokes attributes)
1008                (setq value (get-char-attribute char 'kangxi-strokes)))
1009       (unless (eq value strokes)
1010         (insert line-separator)
1011         (insert (format "{\"kangxi-strokes\":\t%S}%s"
1012                         value
1013                         line-breaking))
1014         (or strokes
1015             (setq strokes value)))
1016       (setq attributes (delq 'kangxi-strokes attributes))
1017       )
1018     (when (and (memq 'japanese-strokes attributes)
1019                (setq value (get-char-attribute char 'japanese-strokes)))
1020       (unless (eq value strokes)
1021         (insert line-separator)
1022         (insert (format "{\"japanese-strokes\":\t%S}%s"
1023                         value
1024                         line-breaking))
1025         (or strokes
1026             (setq strokes value)))
1027       (setq attributes (delq 'japanese-strokes attributes))
1028       )
1029     (when (and (memq 'cns-radical attributes)
1030                (setq value (get-char-attribute char 'cns-radical)))
1031       (insert line-separator)
1032       (insert (format "{\"cns-radical\":\t%S},\t\"_comment\": \"%c\"%s"
1033                       value
1034                       (ideographic-radical value)
1035                       line-breaking))
1036       (setq attributes (delq 'cns-radical attributes))
1037       )
1038     (when (and (memq 'cns-strokes attributes)
1039                (setq value (get-char-attribute char 'cns-strokes)))
1040       (unless (eq value strokes)
1041         (insert line-separator)
1042         (insert (format "{\"cns-strokes\":\t%S}%s"
1043                         value
1044                         line-breaking))
1045         (or strokes
1046             (setq strokes value)))
1047       (setq attributes (delq 'cns-strokes attributes))
1048       )
1049     (when (and (memq 'total-strokes attributes)
1050                (setq value (get-char-attribute char 'total-strokes)))
1051       (insert (format "%s    ideo:total-strokes    %2d ;"
1052                       line-separator value))
1053       (setq attributes (delq 'total-strokes attributes))
1054       )
1055     (if (equal (get-char-attribute char '->titlecase)
1056                (get-char-attribute char '->uppercase))
1057         (setq attributes (delq '->titlecase attributes)))
1058     (unless readable
1059       (dolist (ignored '(composition
1060                          ->denotational <-subsumptive ->ucs-unified
1061                          ->ideographic-component-forms))
1062         (setq attributes (delq ignored attributes))))
1063     (while attributes
1064       (setq name (car attributes))
1065       (setq ret (chise-split-feature-name name))
1066       (setq name-base (car ret)
1067             name-domain (nth 1 ret))
1068       (when (setq value (chise-get-char-attribute-with-metadata
1069                          char name-base name-domain))
1070         (setq metadata (nth 1 value)
1071               value (car value))
1072         (cond ((setq ret (find-charset name))
1073                (setq name (charset-name ret))
1074                (when (not (memq name dest-ccss))
1075                  (setq dest-ccss (cons name dest-ccss))
1076                  (if (null value)
1077                      (insert (format "%s    :%-25s rdf:nil ;" line-separator
1078                                      (chise-turtle-uri-encode-ccs-name name)))
1079                    (setq ret (chise-turtle-format-ccs-code-point name value))
1080                    (insert (format "%s    :eq %-25s ; # %c" line-separator
1081                                    ret
1082                                    (char-db-decode-isolated-char name value)))
1083                    (setq eq-cpos-list (cons (list ret name value) eq-cpos-list))))
1084                (if (find-charset
1085                     (setq ret (if (eq name '=ucs)
1086                                   (if (< value #x10000)
1087                                       '==ucs@unicode
1088                                     '==ucs@iso)
1089                                 (intern (format "=%s" name)))))
1090                    (setq child-ccs-list (cons ret child-ccs-list)))
1091                )
1092               ((and
1093                 (not readable)
1094                 (not (eq name '->subsumptive))
1095                 (not (eq name '->uppercase))
1096                 (not (eq name '->lowercase))
1097                 (not (eq name '->titlecase))
1098                 (not (eq name '->canonical))
1099                 (not (eq name '->Bopomofo))
1100                 (not (eq name '->mistakable))
1101                 (not (eq name '->ideographic-variants))
1102                 (or (eq name '<-identical)
1103                     (eq name '<-uppercase)
1104                     (eq name '<-lowercase)
1105                     (eq name '<-titlecase)
1106                     (eq name '<-canonical)
1107                     (eq name '<-ideographic-variants)
1108                     ;; (eq name '<-synonyms)
1109                     (string-match "^<-synonyms" (symbol-name name))
1110                     (eq name '<-mistakable)
1111                     (when (string-match "^->" (symbol-name name))
1112                       (cond
1113                        ((string-match "^->fullwidth" (symbol-name name))
1114                         (not (and (consp value)
1115                                   (characterp (car value))
1116                                   (encode-char
1117                                    (car value) '=ucs 'defined-only)))
1118                         )
1119                        (t)))
1120                     ))
1121                )
1122               ((eq name 'ideographic-structure)
1123                (insert (isd-turtle-format-char nil nil value (/ column 4)
1124                                                'isd 'without-head-char))
1125                (insert " ;")
1126                )
1127               ((eq name '->subsumptive)
1128                (insert line-separator)
1129                (char-db-turtle-insert-relation-feature char name value
1130                                                        line-breaking
1131                                                        ccss readable)
1132                (setq children value)
1133                )
1134               (t
1135                (insert (format "%s    %-20s "
1136                                line-separator
1137                                (chise-turtle-uri-encode-feature-name name-base)))
1138                (unless (char-db-turtle-insert-feature-value
1139                         value metadata name-domain name-base)
1140                  (insert " ;"))
1141                )
1142               ))
1143       (setq attributes (cdr attributes)))
1144     (insert (format "%s    ." line-breaking))
1145     (dolist (eq-cpos (nreverse eq-cpos-list))
1146       (setq ret (chise-split-ccs-name (nth 1 eq-cpos)))
1147       (insert (format "%s    %s" line-breaking
1148                       (car eq-cpos)))
1149       (insert (format "%s        %25s" line-breaking
1150                       (format ":%s-of" (nth 1 ret))))
1151       (if (null (nth 2 ret))
1152           (insert (format " %14s:%-7s ."
1153                           (chise-turtle-uri-encode-ccs-name (car ret))
1154                           (nth 1 (split-string (car eq-cpos) ":"))))
1155         (insert " [ ")
1156         (setq col (current-column))
1157         (insert (format ":context domain:%-7s ;\n%s:target %7s:%-7s ] ."
1158                         (chise-turtle-uri-encode-ccs-name (nth 2 ret))
1159                         (make-string col ?\ )
1160                         (chise-turtle-uri-encode-ccs-name (car ret))
1161                         (nth 1 (split-string (car eq-cpos) ":"))))))
1162     (setq est-coded-charset-priority-list
1163           (append est-coded-charset-priority-list
1164                   (nreverse child-ccs-list)))
1165     (when children
1166       (dolist (child children)
1167         (insert (format "%s    " line-breaking))
1168         (char-db-turtle-insert-char-features child nil nil nil 'for-sub-node)))
1169     ))
1170
1171 (defun char-db-turtle-insert-char-data (char &optional readable attributes)
1172   (save-restriction
1173     (narrow-to-region (point)(point))
1174     (char-db-turtle-insert-char-features char readable attributes)
1175     (insert "\n\n")
1176     ))
1177
1178 (defun char-db-turtle-insert-prefix ()
1179   (let (base-ccs-list ret)
1180     (insert "@prefix rdf: <http://www.w3.org/1999/02/22-rdf-syntax-ns#> .
1181 @prefix : <http://rdf.chise.org/rdf/property/character/main/> .
1182 @prefix ideo: <http://rdf.chise.org/rdf/property/character/ideo/> .
1183 @prefix isd: <http://rdf.chise.org/rdf/property/character/isd/> .
1184 @prefix idc: <http://rdf.chise.org/rdf/type/character/idc/> .
1185 @prefix chisegg: <http://rdf.chise.org/rdf/type/character/ggg/> .
1186 @prefix domain: <http://rdf.chise.org/data/domain/> .
1187 @prefix script: <http://rdf.chise.org/data/script/> .
1188 @prefix ideocomb: <http://rdf.chise.org/data/character/ideo/combination/> .
1189 @prefix chisebib: <http://rdf.chise.org/data/bibliography/> .
1190 @prefix ruimoku: <http://www.chise.org/est/view/article@ruimoku/rep.id=/> .
1191 @prefix zob1959: <http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/> .
1192
1193 ")
1194     (dolist (cell (sort chise-turtle-ccs-prefix-alist
1195                         (lambda (a b)
1196                           (char-attribute-name< (cdr a)(cdr b)))))
1197       (insert (format "@prefix %s: <%s/%s=> .\n"
1198                       (car cell)
1199                       "http://www.chise.org/est/view/character"
1200                       (www-uri-encode-feature-name (cdr cell))))
1201       (setq ret (chise-split-ccs-name (cdr cell)))
1202       (unless (memq (car ret) base-ccs-list)
1203         (setq base-ccs-list (cons (car ret) base-ccs-list))))
1204     (insert "\n")
1205     (dolist (base-ccs (nreverse base-ccs-list))
1206       (insert (format "@prefix %s: <%s/%s/code-point/> .\n"
1207                       (chise-turtle-uri-encode-ccs-name base-ccs)
1208                       "http://rdf.chise.org/data/ccs"
1209                       (www-uri-encode-feature-name base-ccs))))))
1210
1211 (defun char-db-turtle-insert-ideograph-radical-char-data (radical)
1212   (let ((chars
1213          (sort (copy-list (aref ideograph-radical-chars-vector radical))
1214                (lambda (a b)
1215                  (ideograph-char< a b radical))))
1216         attributes)
1217     (dolist (name (char-attribute-list))
1218       (unless (memq name char-db-ignored-attributes)
1219         (push name attributes)
1220         ))
1221     (setq attributes (sort attributes #'char-attribute-name<))
1222     (aset ideograph-radical-chars-vector radical chars)
1223     (dolist (char chars)
1224       (when (not (some (lambda (atr)
1225                          (get-char-attribute char atr))
1226                        char-db-ignored-attributes))
1227         (char-db-turtle-insert-char-data char nil attributes)))
1228     ))
1229
1230 (defun char-db-turtle-write-ideograph-radical-char-data (radical file)
1231   (if (file-directory-p file)
1232       (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
1233                                 'name)))
1234         (if (string-match "KANGXI RADICAL " name)
1235             (setq name (capitalize (substring name (match-end 0)))))
1236         (setq name (mapconcat (lambda (char)
1237                                 (if (eq char ? )
1238                                     "-"
1239                                   (char-to-string char))) name ""))
1240         (setq file
1241               (expand-file-name
1242                (format "Ideograph-R%03d-%s.ttl" radical name)
1243                file))))
1244   (let (chise-turtle-ccs-prefix-alist)
1245     (with-temp-buffer
1246       (char-db-turtle-insert-ideograph-radical-char-data radical)
1247       (goto-char (point-min))
1248       (char-db-turtle-insert-prefix)
1249       (insert "\n")
1250       (goto-char (point-min))
1251       (insert (format "# -*- coding: %s -*-\n"
1252                       char-db-file-coding-system))
1253       (let ((coding-system-for-write char-db-file-coding-system))
1254         (write-region (point-min)(point-max) file)))))
1255
1256
1257 ;;; @ end
1258 ;;;
1259
1260 (provide 'char-db-turtle)
1261
1262 ;;; char-db-turtle.el ends here