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