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