ids-read.el

   1 ;;; ids-read.el --- Reader for IDS-* files
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2020, 2021 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: IDS, IDC, Ideographs, UCS, Unicode
   7
   8 ;; This file is a part of IDS.
   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 'ids)
  28
  29 ;;;###autoload
  30 (defun ids-read-buffer (buffer &optional simplify soft)
  31   (interactive "bBuffer = \nP")
  32   (save-excursion
  33     (set-buffer buffer)
  34     (goto-char (point-min))
  35     (let (line chs ids apparent-ids code char u-char structure)
  36       (while (not (eobp))
  37         (unless (looking-at ";")
  38           (setq line
  39                 (split-string
  40                  (buffer-substring (point-at-bol)(point-at-eol))
  41                  "\t"))
  42           (setq chs (car line)
  43                 ids (nth 2 line)
  44                 apparent-ids (nth 3 line)
  45                 u-char nil)
  46           (setq apparent-ids
  47                 (if (and apparent-ids
  48                          (string-match "^@apparent=" apparent-ids))
  49                     (substring apparent-ids (match-end 0))))
  50           (setq char
  51                 (cond
  52                  ((string-match "U[-+]\\([0-9A-F]+\\)" chs)
  53                   (setq code (string-to-int (match-string 1 chs) 16))
  54                   (setq u-char (decode-char '=ucs@unicode code))
  55                   (decode-char 'ucs code))
  56                  ((string-match "J90-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)"
  57                                 chs)
  58                   (decode-char 'japanese-jisx0208-1990
  59                                (string-to-int (match-string 1 chs) 16)))
  60                  ((string-match
  61                    "C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)"
  62                    chs)
  63                   (decode-char
  64                    (intern
  65                     (concat "chinese-cns11643-" (match-string 1 chs)))
  66                    (string-to-int (match-string 2 chs) 16)))
  67                  ((string-match "CDP-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)"
  68                                 chs)
  69                   (decode-char '=big5-cdp
  70                                (string-to-int (match-string 1 chs) 16)))
  71                  ((string-match
  72                    "HZK\\([0-9][0-9]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\)"
  73                    chs)
  74                   (decode-char (intern
  75                                 (format "=hanziku-%d"
  76                                         (string-to-int (match-string 1 chs))))
  77                                (string-to-int (match-string 2 chs) 16)))
  78                  ((string-match "M-\\([0-9]+\\)'" chs)
  79                   (setq code (string-to-int (match-string 1 chs)))
  80                   (map-char-attribute
  81                    (lambda (key val)
  82                      (if (and (eq (car val) code)
  83                               (eq (nth 1 val) 1)
  84                               (null (nthcdr 2 val)))
  85                          key))
  86                    'morohashi-daikanwa))
  87                  ((string-match "M-\\([0-9]+\\)\"" chs)
  88                   (setq code (string-to-int (match-string 1 chs)))
  89                   (map-char-attribute
  90                    (lambda (key val)
  91                      (if (and (eq (car val) code)
  92                               (eq (nth 1 val) 2)
  93                               (null (nthcdr 2 val)))
  94                          key))
  95                    'morohashi-daikanwa))
  96                  ((string-match "M-\\([0-9]+\\)" chs)
  97                   (decode-char 'ideograph-daikanwa
  98                                (string-to-int (match-string 1 chs))))
  99                  ((string-match "MH-\\([0-9]+\\)" chs)
 100                   (setq code (string-to-int (match-string 1 chs)))
 101                   (map-char-attribute
 102                    (lambda (key val)
 103                      (if (and (eq (car val) 'ho)
 104                               (eq (nth 1 val) code)
 105                               (null (nthcdr 2 val)))
 106                          key))
 107                    'morohashi-daikanwa))
 108                  ((string-match "CB\\([0-9]+\\)" chs)
 109                   (decode-char 'ideograph-cbeta
 110                                (string-to-int (match-string 1 chs))))
 111                  ((string-match "SW-JIGUGE-\\([0-9]+\\)" chs)
 112                   (decode-char '=shuowen-jiguge
 113                                (string-to-int (match-string 1 chs))))
 114                  ))
 115           (when char
 116             (when (and (>= (length ids) 3)
 117                        (not (string-match "\\?" ids))
 118                        (consp (setq structure (ids-parse-string ids simplify))))
 119               (when (or (not soft)
 120                         (null
 121                          (get-char-attribute char 'ideographic-structure)))
 122                 (put-char-attribute char
 123                                     'ideographic-structure
 124                                     (cdr (car structure))))
 125               (when (and u-char
 126                          (not (eq char u-char))
 127                          (or (not soft)
 128                              (null
 129                               (get-char-attribute
 130                                u-char 'ideographic-structure))))
 131                 (put-char-attribute
 132                  u-char 'ideographic-structure
 133                  (ideographic-structure-convert-to-domain
 134                   (cdr (car structure)) 'unicode))))
 135             (when (and (>= (length apparent-ids) 3)
 136                        (consp (setq structure
 137                                     (ids-parse-string apparent-ids simplify))))
 138               (when (or (not soft)
 139                         (null
 140                          (get-char-attribute char 'ideographic-structure@apparent)))
 141                 (put-char-attribute char
 142                                     'ideographic-structure@apparent
 143                                     (cdr (car structure)))))
 144             )
 145           )
 146         (forward-line)
 147         ))))
 148
 149 ;;;###autoload
 150 (defun ids-read-file (file &optional simplify soft)
 151   (interactive "fIDS file = \nP")
 152   (with-temp-buffer
 153     (insert-file-contents file)
 154     (ids-read-buffer (current-buffer) simplify soft)))
 155
 156
 157 ;;; @ End.
 158 ;;;
 159
 160 (provide 'ids-read)
 161
 162 ;;; ids-read.el ends here