isd-turtle.el

   1 ;;; isd-turtle.el --- Utility to dump ideographic-structure as Turtle files
   2
   3 ;; Copyright (C) 2017 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: Ideographic Structures (漢字構造、解字), IDS, CHISE, RDF, Turtle
   7
   8 ;; This file is a part of CHISE-ISD (Ideographic Structure Database).
   9
  10 ;; This program 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 ;; This program is distributed in the hope that it will be useful, but
  16 ;; 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 this program; 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 'cwiki-common)
  28
  29 (defvar isd-url-prefix "http://rdf.chise.org/data/")
  30
  31 (setq est-coded-charset-priority-list
  32   '(; =ucs
  33     =mj
  34     =adobe-japan1
  35     =ucs@iso
  36     =jis-x0208 =jis-x0208@1990
  37     =jis-x0213-1
  38     =jis-x0213-1@2000 =jis-x0213-1@2004
  39     =jis-x0213-2
  40     =jis-x0212
  41     =gt
  42     =hanyo-denshi/tk
  43     =ucs-itaiji-001
  44     =ucs-itaiji-002
  45     =ucs-itaiji-003
  46     =ucs-itaiji-005
  47     =ucs-itaiji-006
  48     =ucs-itaiji-084
  49     =ucs-var-001
  50     =ucs-var-002
  51     =ucs-var-004
  52     =cns11643-1 =cns11643-2 =cns11643-3
  53     =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
  54     =gb2312
  55     =big5-cdp
  56     =gt-k
  57     =ucs@unicode
  58     =ucs@JP/hanazono
  59     =gb12345
  60     =zinbun-oracle =>zinbun-oracle
  61     =daikanwa
  62     =ruimoku-v6
  63     =cbeta =jef-china3
  64     =>jis-x0208 =>jis-x0213-1
  65     =>jis-x0208@1997
  66     =>ucs@iwds-1
  67     =>ucs@component
  68     =>iwds-1
  69     =>ucs@iso
  70     =>ucs@unicode
  71     =+>ucs@iso =+>ucs@unicode
  72     =>ucs@jis =>ucs@cns =>ucs@ks
  73     =>>ucs@iso =>>ucs@unicode
  74     =>>ucs@jis =>>ucs@cns =>>ucs@ks
  75     ==mj
  76     =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2
  77     =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2
  78     =+>jis-x0208@1978
  79     =>>gt
  80     =+>adobe-japan1
  81     =>>adobe-japan1
  82     =jis-x0208@1983 =jis-x0208@1978
  83     =>ucs-itaiji-001
  84     =>ucs-itaiji-002
  85     =>ucs-itaiji-005
  86     ==ucs@unicode
  87     ==>ucs@bucs
  88     =big5
  89     =>cbeta
  90     ))
  91
  92 (defvar isd-turtle-ccs-list nil)
  93
  94 (defun charset-code-point-format-spec (ccs)
  95   (cond ((memq ccs '(=ucs))
  96          "0x%04X")
  97         ((memq ccs '(=gt
  98                      =gt-k =daikanwa =adobe-japan1
  99                      =cbeta =zinbun-oracle))
 100          "%05d")
 101         ((memq ccs '(=hanyo-denshi/ks
 102                      =koseki =mj))
 103          "%06d")
 104         ((memq ccs '(=hanyo-denshi/tk ==hanyo-denshi/tk))
 105          "%08d")
 106         (t
 107          "0x%X")))
 108
 109 (defun isd-turtle-uri-encode-feature-name (feature-name)
 110   (cond
 111    ((eq '=ucs feature-name)
 112     "a.ucs")
 113    ((eq '==>ucs@bucs feature-name)
 114     "bucs")
 115    (t
 116     (mapconcat (lambda (c)
 117                  (if (eq c ?@)
 118                      "_"
 119                    (char-to-string c)))
 120                (www-uri-encode-feature-name feature-name)
 121                ""))))
 122
 123 (defun isd-turtle-format-ccs-code-point (ccs code-point)
 124   (unless (memq ccs isd-turtle-ccs-list)
 125     (setq isd-turtle-ccs-list (cons ccs isd-turtle-ccs-list)))
 126   (format "%s:%s"
 127           (isd-turtle-uri-encode-feature-name ccs)
 128           (format (charset-code-point-format-spec ccs)
 129                   code-point)))
 130
 131 (defun isd-turtle-encode-char (object)
 132   (let ((ccs-list est-coded-charset-priority-list)
 133         ccs ret)
 134     (if (setq ret (encode-char object '=ucs))
 135         (isd-turtle-format-ccs-code-point '=ucs ret)
 136       (while (and ccs-list
 137                   (setq ccs (pop ccs-list))
 138                   (not (setq ret (encode-char object ccs 'defined-only)))))
 139       (cond (ret
 140              (isd-turtle-format-ccs-code-point ccs ret)
 141              )
 142             ((and (setq ccs (car (split-char object)))
 143                   (setq ret (encode-char object ccs)))
 144              (isd-turtle-format-ccs-code-point ccs ret)
 145              )
 146             (t
 147              (format (if est-hide-cgi-mode
 148                          "system-char-id=0x%X"
 149                        "system-char-id:0x%X")
 150                      (encode-char object 'system-char-id))
 151              )))))
 152
 153 (defun isd-turtle-format-component (component separator level)
 154   (cond ((characterp component)
 155          (format "%s %c # %c"
 156                  (isd-turtle-encode-char component)
 157                  separator
 158                  component)
 159          )
 160         ((consp component)
 161          (let ((ret (find-char component)))
 162            (cond (ret
 163                   (format "%s %c # %c"
 164                           (isd-turtle-encode-char ret) separator ret))
 165                  ((setq ret (assq 'ideographic-structure component))
 166                   (if (eq separator ?\;)
 167                       (format "%s ;"
 168                               (isd-turtle-format-char nil nil (cdr ret) (1+ level)))
 169                     (isd-turtle-format-char nil nil (cdr ret) (1+ level)))))))))
 170
 171 (defun isd-turtle-format-char (ccs code-point &optional ids-list level)
 172   (unless level
 173     (setq level 0))
 174   (let ((indent (make-string (* level 4) ?\ ))
 175         char
 176         idc
 177         p1 p2 p3
 178         c1 c2 c3
 179         ret)
 180     (unless ids-list
 181       (if (and ccs code-point
 182                (setq char (decode-char ccs code-point)))
 183           (setq ids-list (get-char-attribute char 'ideographic-structure))))
 184     (setq idc (car ids-list))
 185     (setq c1 (nth 1 ids-list)
 186           c2 (nth 2 ids-list)
 187           c3 (nth 3 ids-list))
 188     (if (char-ref-p idc)
 189         (setq idc (plist-get idc :char)))
 190     (if (and (consp idc)
 191              (setq ret (find-char idc)))
 192         (setq idc ret))
 193     (if (and (consp c1)
 194              (setq ret (find-char c1)))
 195         (setq c1 ret))
 196     (if (and (consp c2)
 197              (setq ret (find-char c2)))
 198         (setq c2 ret))
 199     (if (and (consp c3)
 200              (setq ret (find-char c3)))
 201         (setq c3 ret))
 202     (cond
 203      ((eq idc ?\u2FF0) ; ⿰
 204       (setq p1 'left
 205             p2 'right)
 206       )
 207      ((eq idc ?⿱)
 208       (setq p1 'above
 209             p2 'below)
 210       )
 211      ((eq idc ?⿲)
 212       (setq p1 'left
 213             p2 'middle
 214             p3 'right)
 215       )
 216      ((eq idc ?⿳)
 217       (setq p1 'above
 218             p2 'middle
 219             p3 'below)
 220       )
 221      ((memq idc '(?⿴ ?⿵ ?⿶ ?⿷ ?⿸ ?⿹ ?⿺))
 222       (setq p1 'surround
 223             p2 'filling)
 224       )
 225      ((eq idc ?⿻)
 226       (setq p1 'underlying
 227             p2 'overlaying)
 228       ))
 229     (cond
 230      (p3
 231       (format "%s
 232 %s    :structure [ a idc:%c ;
 233 %s        :%-8s %s
 234 %s        :%-8s %s
 235 %s        :%-8s %s
 236 %s    ]%s"
 237               (if (and ccs code-point)
 238                   (format "%s   # %c"
 239                           (isd-turtle-format-ccs-code-point ccs code-point)
 240                           char)
 241                 "[")
 242               indent idc
 243               indent p1 (isd-turtle-format-component c1 ?\; (1+ level))
 244               indent p2 (isd-turtle-format-component c2 ?\; (1+ level))
 245               indent p3 (isd-turtle-format-component c3 ?\  (1+ level))
 246               indent
 247               (if (null char)
 248                   (format "\n%s]"
 249                           indent)
 250                 ""))
 251       )
 252      (idc
 253       (format "%s
 254 %s    :structure [ a idc:%c ;
 255 %s        :%-8s %s
 256 %s        :%-8s %s
 257 %s    ]%s"
 258               (if (and ccs code-point)
 259                   (format "%s   # %c"
 260                           (isd-turtle-format-ccs-code-point ccs code-point)
 261                           char)
 262                 "[")
 263               indent idc
 264               indent p1 (isd-turtle-format-component c1 ?\; (1+ level))
 265               indent p2 (isd-turtle-format-component c2 ?\  (1+ level))
 266               indent
 267               (if (null char)
 268                   (format "\n%s]"
 269                           indent)
 270                 ""))))
 271     ))
 272
 273 (defun isd-turtle-insert-char (ccs code-point)
 274   (let ((ret (isd-turtle-format-char ccs code-point)))
 275     (when ret
 276       (insert ret)
 277       (insert " .\n"))))
 278
 279 (defun isd-turtle-insert-ccs-ranges (ccs &rest ranges)
 280   (let (range code max-code)
 281     (while ranges
 282       (setq range (car ranges))
 283       (cond ((consp range)
 284              (setq code (car range)
 285                    max-code (cdr range))
 286              (while (<= code max-code)
 287                (isd-turtle-insert-char ccs code)
 288                (setq code (1+ code)))
 289              )
 290             ((integerp range)
 291              (isd-turtle-insert-char ccs range)
 292              )
 293             (t (error 'wrong-type-argument range)))
 294       (setq ranges (cdr ranges)))))
 295
 296 (defun isd-turtle-dump-range (file path func &rest args)
 297   (with-temp-buffer
 298     (let ((coding-system-for-write 'utf-8-mcs-er)
 299           isd-turtle-ccs-list)
 300       (if (file-directory-p path)
 301           (setq path (expand-file-name file path)))
 302       (apply func args)
 303       (goto-char (point-min))
 304       (dolist (ccs (sort isd-turtle-ccs-list
 305                          #'char-attribute-name<))
 306         (insert (format "@prefix %s: <%s%s=> .\n"
 307                         (isd-turtle-uri-encode-feature-name ccs)
 308                         "http://www.chise.org/est/view/character/"
 309                         (www-uri-encode-feature-name ccs))))
 310       (insert "\n")
 311       (goto-char (point-min))
 312       (insert "# -*- coding: utf-8-mcs-er -*-\n")
 313       (insert "@prefix : <http://rdf.chise.org/rdf/property/character/isd/> .
 314 @prefix idc: <http://rdf.chise.org/rdf/type/character/idc/> .\n")
 315       (write-region (point-min)(point-max) path))))
 316
 317 ;;;###autoload
 318 (defun isd-turtle-dump-ucs-basic (filename)
 319   (interactive "Fdump ISD-UCS-Basic : ")
 320   (isd-turtle-dump-range "ISD-UCS-Basic.ttl" filename
 321                          #'isd-turtle-insert-ccs-ranges
 322                          '=ucs '(#x4E00 . #x9FA5)))
 323
 324 ;;;###autoload
 325 (defun isd-turtle-dump-ucs-ext-a (filename)
 326   (interactive "Fdump ISD-UCS-Ext-A : ")
 327   (isd-turtle-dump-range "ISD-UCS-Ext-A.ttl" filename
 328                          #'isd-turtle-insert-ccs-ranges
 329                          '=ucs '(#x3400 . #x4DB5) #xFA1F #xFA23))
 330
 331 ;;;###autoload
 332 (defun isd-turtle-dump-ucs-ext-b-1 (filename)
 333   (interactive "Fdump IDS-UCS-Ext-B-1 : ")
 334   (isd-turtle-dump-range "ISD-UCS-Ext-B-1.ttl" filename
 335                          #'isd-turtle-insert-ccs-ranges
 336                          'ucs '(#x20000 . #x21FFF)))
 337
 338 ;;;###autoload
 339 (defun isd-turtle-dump-ucs-ext-b-2 (filename)
 340   (interactive "Fdump IDS-UCS-Ext-B-2 : ")
 341   (isd-turtle-dump-range "ISD-UCS-Ext-B-2.ttl" filename
 342                          #'isd-turtle-insert-ccs-ranges
 343                          'ucs '(#x22000 . #x23FFF)))
 344
 345 ;;;###autoload
 346 (defun isd-turtle-dump-ucs-ext-b-3 (filename)
 347   (interactive "Fdump IDS-UCS-Ext-B-3 : ")
 348   (isd-turtle-dump-range "ISD-UCS-Ext-B-3.ttl" filename
 349                          #'isd-turtle-insert-ccs-ranges
 350                          'ucs '(#x24000 . #x25FFF)))
 351
 352 ;;;###autoload
 353 (defun isd-turtle-dump-ucs-ext-b-4 (filename)
 354   (interactive "Fdump IDS-UCS-Ext-B-4 : ")
 355   (isd-turtle-dump-range "ISD-UCS-Ext-B-4.ttl" filename
 356                          #'isd-turtle-insert-ccs-ranges
 357                          'ucs '(#x26000 . #x27FFF)))
 358
 359 ;;;###autoload
 360 (defun isd-turtle-dump-ucs-ext-b-5 (filename)
 361   (interactive "Fdump IDS-UCS-Ext-B-5 : ")
 362   (isd-turtle-dump-range "ISD-UCS-Ext-B-5.ttl" filename
 363                          #'isd-turtle-insert-ccs-ranges
 364                          'ucs '(#x28000 . #x29FFF)))
 365
 366 ;;;###autoload
 367 (defun isd-turtle-dump-ucs-ext-b-6 (filename)
 368   (interactive "Fdump IDS-UCS-Ext-B-6 : ")
 369   (isd-turtle-dump-range "ISD-UCS-Ext-B-6.ttl" filename
 370                          #'isd-turtle-insert-ccs-ranges
 371                          'ucs '(#x2A000 . #x2A6D6)))
 372
 373 ;;;###autoload
 374 (defun isd-turtle-dump-ucs-ext-c (filename)
 375   (interactive "Fdump IDS-UCS-Ext-C : ")
 376   (isd-turtle-dump-range "ISD-UCS-Ext-C.ttl" filename
 377                          #'isd-turtle-insert-ccs-ranges
 378                          'ucs '(#x2A700 . #x2B734)))
 379
 380 ;;;###autoload
 381 (defun isd-turtle-dump-ucs-ext-d (filename)
 382   (interactive "Fdump IDS-UCS-Ext-D : ")
 383   (isd-turtle-dump-range "ISD-UCS-Ext-D.ttl" filename
 384                          #'isd-turtle-insert-ccs-ranges
 385                          'ucs '(#x2B740 . #x2B81D)))
 386
 387 ;;;###autoload
 388 (defun isd-turtle-dump-ucs-ext-e (filename)
 389   (interactive "Fdump IDS-UCS-Ext-E : ")
 390   (isd-turtle-dump-range "ISD-UCS-Ext-E.ttl" filename
 391                          #'isd-turtle-insert-ccs-ranges
 392                          'ucs '(#x2B820 . #x2CEA1)))
 393
 394 ;;;###autoload
 395 (defun isd-turtle-dump-mj-0 (filename)
 396   (interactive "Fdump ISD-MJ-0 : ")
 397   (isd-turtle-dump-range "ISD-MJ-0.ttl" filename
 398                          #'isd-turtle-insert-ccs-ranges
 399                          '=mj '(1 . 9999)))
 400
 401 ;;;###autoload
 402 (defun isd-turtle-dump-mj-1 (filename)
 403   (interactive "Fdump ISD-MJ-1 : ")
 404   (isd-turtle-dump-range "ISD-MJ-1.ttl" filename
 405                          #'isd-turtle-insert-ccs-ranges
 406                          '=mj '(10000 . 19999)))
 407
 408 ;;;###autoload
 409 (defun isd-turtle-dump-mj-2 (filename)
 410   (interactive "Fdump ISD-MJ-2 : ")
 411   (isd-turtle-dump-range "ISD-MJ-2.ttl" filename
 412                          #'isd-turtle-insert-ccs-ranges
 413                          '=mj '(20000 . 29999)))
 414
 415 ;;;###autoload
 416 (defun isd-turtle-dump-mj-3 (filename)
 417   (interactive "Fdump ISD-MJ-3 : ")
 418   (isd-turtle-dump-range "ISD-MJ-3.ttl" filename
 419                          #'isd-turtle-insert-ccs-ranges
 420                          '=mj '(30000 . 39999)))
 421
 422 ;;;###autoload
 423 (defun isd-turtle-dump-mj-4 (filename)
 424   (interactive "Fdump ISD-MJ-4 : ")
 425   (isd-turtle-dump-range "ISD-MJ-4.ttl" filename
 426                          #'isd-turtle-insert-ccs-ranges
 427                          '=mj '(40000 . 49999)))
 428
 429 ;;;###autoload
 430 (defun isd-turtle-dump-mj-5 (filename)
 431   (interactive "Fdump ISD-MJ-5 : ")
 432   (isd-turtle-dump-range "ISD-MJ-5.ttl" filename
 433                          #'isd-turtle-insert-ccs-ranges
 434                          '=mj '(50000 . 59999)))
 435
 436 ;;;###autoload
 437 (defun isd-turtle-dump-mj-6 (filename)
 438   (interactive "Fdump ISD-MJ-6 : ")
 439   (isd-turtle-dump-range "ISD-MJ-6.ttl" filename
 440                          #'isd-turtle-insert-ccs-ranges
 441                          '=mj '(60000 . 69999)))
 442
 443 ;;;###autoload
 444 (defun isd-turtle-dump-all (directory)
 445   (interactive "DISD directory : ")
 446   (isd-turtle-dump-ucs-basic directory)
 447   (isd-turtle-dump-ucs-ext-a directory)
 448   (isd-turtle-dump-ucs-ext-b-1 directory)
 449   (isd-turtle-dump-ucs-ext-b-2 directory)
 450   (isd-turtle-dump-ucs-ext-b-3 directory)
 451   (isd-turtle-dump-ucs-ext-b-4 directory)
 452   (isd-turtle-dump-ucs-ext-b-5 directory)
 453   (isd-turtle-dump-ucs-ext-b-6 directory)
 454   (isd-turtle-dump-ucs-ext-c directory)
 455   (isd-turtle-dump-ucs-ext-d directory)
 456   (isd-turtle-dump-ucs-ext-e directory)
 457   (isd-turtle-dump-mj-0 directory)
 458   (isd-turtle-dump-mj-1 directory)
 459   (isd-turtle-dump-mj-2 directory)
 460   (isd-turtle-dump-mj-3 directory)
 461   (isd-turtle-dump-mj-4 directory)
 462   (isd-turtle-dump-mj-5 directory)
 463   (isd-turtle-dump-mj-6 directory)
 464   )
 465
 466
 467 ;;; @ End.
 468 ;;;
 469
 470 (provide 'isd-turtle)
 471
 472 ;;; isd-turtle.el ends here