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