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