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