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-var-001
  48     =cns11643-1 =cns11643-2 =cns11643-3
  49     =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
  50     =gb2312
  51     =big5-cdp
  52     =gt-k
  53     =ucs@unicode
  54     =ucs@JP/hanazono
  55     =gb12345
  56     =zinbun-oracle =>zinbun-oracle
  57     =daikanwa
  58     =ruimoku-v6
  59     =cbeta =jef-china3
  60     =>jis-x0208 =>jis-x0213-1
  61     =>jis-x0208@1997
  62     =>ucs@iwds-1
  63     =>ucs@component
  64     =>iwds-1
  65     =>ucs@iso
  66     =>ucs@unicode
  67     =+>ucs@iso =+>ucs@unicode
  68     =>ucs@jis =>ucs@cns =>ucs@ks
  69     =>>ucs@iso =>>ucs@unicode
  70     =>>ucs@jis =>>ucs@cns =>>ucs@ks
  71     ==mj
  72     =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2
  73     =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2
  74     =+>jis-x0208@1978
  75     =>>gt
  76     =+>adobe-japan1
  77     =>>adobe-japan1
  78     =jis-x0208@1983 =jis-x0208@1978
  79     =>ucs-itaiji-005
  80     ==ucs@unicode
  81     ==>ucs@bucs
  82     =big5
  83     =>cbeta
  84     ))
  85
  86 (defvar isd-turtle-ccs-list nil)
  87
  88 (defun charset-code-point-format-spec (ccs)
  89   (cond ((memq ccs '(=ucs))
  90          "0x%04X")
  91         ((memq ccs '(=gt
  92                      =gt-k =daikanwa =adobe-japan1
  93                      =cbeta =zinbun-oracle))
  94          "%05d")
  95         ((memq ccs '(=hanyo-denshi/ks
  96                      =koseki =mj))
  97          "%06d")
  98         ((memq ccs '(=hanyo-denshi/tk ==hanyo-denshi/tk))
  99          "%08d")
 100         (t
 101          "0x%X")))
 102
 103 (defun isd-turtle-uri-encode-feature-name (feature-name)
 104   (cond
 105    ((eq '=ucs feature-name)
 106     "a.ucs")
 107    ((eq '==>ucs@bucs feature-name)
 108     "bucs")
 109    (t
 110     (mapconcat (lambda (c)
 111                  (if (eq c ?@)
 112                      "_"
 113                    (char-to-string c)))
 114                (www-uri-encode-feature-name feature-name)
 115                ""))))
 116
 117 (defun isd-turtle-format-ccs-code-point (ccs code-point)
 118   (unless (memq ccs isd-turtle-ccs-list)
 119     (setq isd-turtle-ccs-list (cons ccs isd-turtle-ccs-list)))
 120   (format "%s:%s"
 121           (isd-turtle-uri-encode-feature-name ccs)
 122           (format (charset-code-point-format-spec ccs)
 123                   code-point)))
 124
 125 (defun isd-turtle-encode-char (object)
 126   (let ((ccs-list est-coded-charset-priority-list)
 127         ccs ret)
 128     (if (setq ret (encode-char object '=ucs))
 129         (isd-turtle-format-ccs-code-point '=ucs ret)
 130       (while (and ccs-list
 131                   (setq ccs (pop ccs-list))
 132                   (not (setq ret (encode-char object ccs 'defined-only)))))
 133       (cond (ret
 134              (isd-turtle-format-ccs-code-point ccs ret)
 135              )
 136             ((and (setq ccs (car (split-char object)))
 137                   (setq ret (encode-char object ccs)))
 138              (isd-turtle-format-ccs-code-point ccs ret)
 139              )
 140             (t
 141              (format (if est-hide-cgi-mode
 142                          "system-char-id=0x%X"
 143                        "system-char-id:0x%X")
 144                      (encode-char object 'system-char-id))
 145              )))))
 146
 147 (defun isd-turtle-format-component (component separator level)
 148   (cond ((characterp component)
 149          (format "%s %c # %c"
 150                  (isd-turtle-encode-char component)
 151                  separator
 152                  component)
 153          )
 154         ((consp component)
 155          (let ((ret (find-char component)))
 156            (cond (ret
 157                   (format "%s %c # %c"
 158                           (isd-turtle-encode-char ret) separator ret))
 159                  ((setq ret (assq 'ideographic-structure component))
 160                   (if (eq separator ?\;)
 161                       (format "%s ;"
 162                               (isd-turtle-format-char nil nil (cdr ret) (1+ level)))
 163                     (isd-turtle-format-char nil nil (cdr ret) (1+ level)))))))))
 164
 165 (defun isd-turtle-format-char (ccs code-point &optional ids-list level)
 166   (unless level
 167     (setq level 0))
 168   (let ((indent (make-string (* level 4) ?\ ))
 169         char
 170         idc
 171         p1 p2 p3
 172         c1 c2 c3
 173         ret)
 174     (unless ids-list
 175       (if (and ccs code-point
 176                (setq char (decode-char ccs code-point)))
 177           (setq ids-list (get-char-attribute char 'ideographic-structure))))
 178     (setq idc (car ids-list))
 179     (setq c1 (nth 1 ids-list)
 180           c2 (nth 2 ids-list)
 181           c3 (nth 3 ids-list))
 182     (if (char-ref-p idc)
 183         (setq idc (plist-get idc :char)))
 184     (if (and (consp idc)
 185              (setq ret (find-char idc)))
 186         (setq idc ret))
 187     (if (and (consp c1)
 188              (setq ret (find-char c1)))
 189         (setq c1 ret))
 190     (if (and (consp c2)
 191              (setq ret (find-char c2)))
 192         (setq c2 ret))
 193     (if (and (consp c3)
 194              (setq ret (find-char c3)))
 195         (setq c3 ret))
 196     (cond
 197      ((eq idc ?\u2FF0) ; ⿰
 198       (setq p1 'left
 199             p2 'right)
 200       )
 201      ((eq idc ?⿱)
 202       (setq p1 'above
 203             p2 'below)
 204       )
 205      ((eq idc ?⿲)
 206       (setq p1 'left
 207             p2 'middle
 208             p3 'right)
 209       )
 210      ((eq idc ?⿳)
 211       (setq p1 'above
 212             p2 'middle
 213             p3 'below)
 214       )
 215      ((memq idc '(?⿴ ?⿵ ?⿶ ?⿷ ?⿸ ?⿹ ?⿺))
 216       (setq p1 'surround
 217             p2 'filling)
 218       )
 219      ((eq idc ?⿻)
 220       (setq p1 'underlying
 221             p2 'overlaying)
 222       ))
 223     (cond
 224      (p3
 225       (format "%s
 226 %s    :structure [ a idc:%c ;
 227 %s        :%-8s %s
 228 %s        :%-8s %s
 229 %s        :%-8s %s
 230 %s    ]%s"
 231               (if (and ccs code-point)
 232                   (format "%s   # %c"
 233                           (isd-turtle-format-ccs-code-point ccs code-point)
 234                           char)
 235                 "[")
 236               indent idc
 237               indent p1 (isd-turtle-format-component c1 ?\; (1+ level))
 238               indent p2 (isd-turtle-format-component c2 ?\; (1+ level))
 239               indent p3 (isd-turtle-format-component c3 ?\  (1+ level))
 240               indent
 241               (if (null char)
 242                   (format "\n%s]"
 243                           indent)
 244                 ""))
 245       )
 246      (idc
 247       (format "%s
 248 %s    :structure [ a idc:%c ;
 249 %s        :%-8s %s
 250 %s        :%-8s %s
 251 %s    ]%s"
 252               (if (and ccs code-point)
 253                   (format "%s   # %c"
 254                           (isd-turtle-format-ccs-code-point ccs code-point)
 255                           char)
 256                 "[")
 257               indent idc
 258               indent p1 (isd-turtle-format-component c1 ?\; (1+ level))
 259               indent p2 (isd-turtle-format-component c2 ?\  (1+ level))
 260               indent
 261               (if (null char)
 262                   (format "\n%s]"
 263                           indent)
 264                 ""))))
 265     ))
 266
 267 (defun isd-turtle-insert-char (ccs code-point)
 268   (let ((ret (isd-turtle-format-char ccs code-point)))
 269     (when ret
 270       (insert ret)
 271       (insert " .\n"))))
 272
 273 (defun isd-turtle-insert-ccs-ranges (ccs &rest ranges)
 274   (let (range code max-code)
 275     (while ranges
 276       (setq range (car ranges))
 277       (cond ((consp range)
 278              (setq code (car range)
 279                    max-code (cdr range))
 280              (while (<= code max-code)
 281                (isd-turtle-insert-char ccs code)
 282                (setq code (1+ code)))
 283              )
 284             ((integerp range)
 285              (isd-turtle-insert-char ccs range)
 286              )
 287             (t (error 'wrong-type-argument range)))
 288       (setq ranges (cdr ranges)))))
 289
 290 (defun isd-turtle-dump-range (file path func &rest args)
 291   (with-temp-buffer
 292     (let ((coding-system-for-write 'utf-8-mcs-er)
 293           isd-turtle-ccs-list)
 294       (if (file-directory-p path)
 295           (setq path (expand-file-name file path)))
 296       (apply func args)
 297       (goto-char (point-min))
 298       (dolist (ccs (sort isd-turtle-ccs-list
 299                          #'char-attribute-name<))
 300         (insert (format "@prefix %s: <%s%s=> .\n"
 301                         (isd-turtle-uri-encode-feature-name ccs)
 302                         "http://www.chise.org/est/view/character/"
 303                         (www-uri-encode-feature-name ccs))))
 304       (insert "\n")
 305       (goto-char (point-min))
 306       (insert "# -*- coding: utf-8-mcs-er -*-\n")
 307       (insert "@prefix : <http://rdf.chise.org/rdf/property/character/isd/> .
 308 @prefix idc: <http://rdf.chise.org/rdf/type/character/idc/> .\n")
 309       (write-region (point-min)(point-max) path))))
 310
 311 ;;;###autoload
 312 (defun isd-turtle-dump-ucs-basic (filename)
 313   (interactive "Fdump ISD-UCS-Basic : ")
 314   (isd-turtle-dump-range "ISD-UCS-Basic.ttl" filename
 315                          #'isd-turtle-insert-ccs-ranges
 316                          '=ucs '(#x4E00 . #x9FA5)))
 317
 318 ;;;###autoload
 319 (defun isd-turtle-dump-ucs-ext-a (filename)
 320   (interactive "Fdump ISD-UCS-Ext-A : ")
 321   (isd-turtle-dump-range "ISD-UCS-Ext-A.ttl" filename
 322                          #'isd-turtle-insert-ccs-ranges
 323                          '=ucs '(#x3400 . #x4DB5) #xFA1F #xFA23))
 324
 325 ;;;###autoload
 326 (defun isd-turtle-dump-mj-0 (filename)
 327   (interactive "Fdump ISD-MJ-0 : ")
 328   (isd-turtle-dump-range "ISD-MJ-0.ttl" filename
 329                          #'isd-turtle-insert-ccs-ranges
 330                          '=mj '(1 . 9999)))
 331
 332 ;;;###autoload
 333 (defun isd-turtle-dump-mj-1 (filename)
 334   (interactive "Fdump ISD-MJ-1 : ")
 335   (isd-turtle-dump-range "ISD-MJ-1.ttl" filename
 336                          #'isd-turtle-insert-ccs-ranges
 337                          '=mj '(10000 . 19999)))
 338
 339 ;;;###autoload
 340 (defun isd-turtle-dump-mj-2 (filename)
 341   (interactive "Fdump ISD-MJ-2 : ")
 342   (isd-turtle-dump-range "ISD-MJ-2.ttl" filename
 343                          #'isd-turtle-insert-ccs-ranges
 344                          '=mj '(20000 . 29999)))
 345
 346 ;;;###autoload
 347 (defun isd-turtle-dump-mj-3 (filename)
 348   (interactive "Fdump ISD-MJ-3 : ")
 349   (isd-turtle-dump-range "ISD-MJ-3.ttl" filename
 350                          #'isd-turtle-insert-ccs-ranges
 351                          '=mj '(30000 . 39999)))
 352
 353 ;;;###autoload
 354 (defun isd-turtle-dump-mj-4 (filename)
 355   (interactive "Fdump ISD-MJ-4 : ")
 356   (isd-turtle-dump-range "ISD-MJ-4.ttl" filename
 357                          #'isd-turtle-insert-ccs-ranges
 358                          '=mj '(40000 . 49999)))
 359
 360 ;;;###autoload
 361 (defun isd-turtle-dump-mj-5 (filename)
 362   (interactive "Fdump ISD-MJ-5 : ")
 363   (isd-turtle-dump-range "ISD-MJ-5.ttl" filename
 364                          #'isd-turtle-insert-ccs-ranges
 365                          '=mj '(50000 . 59999)))
 366
 367 ;;;###autoload
 368 (defun isd-turtle-dump-mj-6 (filename)
 369   (interactive "Fdump ISD-MJ-6 : ")
 370   (isd-turtle-dump-range "ISD-MJ-6.ttl" filename
 371                          #'isd-turtle-insert-ccs-ranges
 372                          '=mj '(60000 . 69999)))
 373
 374
 375 ;;; @ End.
 376 ;;;
 377
 378 (provide 'isd-turtle)
 379
 380 ;;; isd-turtle.el ends here