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