idc.el

   1 ;;; idc.el --- Parser and utility for Ideographic Description Sequence.
   2
   3 ;; Copyright (C) 2001 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: IDC, Ideographs, UCS, Unicode
   7
   8 ;; This file is a part of Tomoyo-Tools.
   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 ;;; Commentary:
  26
  27 ;; Ideographic Description Sequence is defined in ISO/IEC 10646-1:2000
  28 ;; Annex F.
  29
  30 ;;; Code:
  31
  32 (defun idc-parse-terminal (string)
  33   (if (>= (length string) 1)
  34       (let* ((chr (aref string 0))
  35              (ucs (get-char-attribute chr 'ucs))
  36              big5)
  37         (unless (and ucs (<= #x2FF0 ucs)(<= ucs #x2FFF))
  38           (if (and ucs (<= #xE000 ucs)(<= ucs #xF8FF)
  39                    (setq big5 (get-char-attribute chr 'chinese-big5)))
  40               (setq chr (decode-char 'chinese-big5-cdp big5)))
  41           (cons chr
  42                 (substring string 1))))))
  43
  44 (defun idc-parse-op-2 (string)
  45   (if (>= (length string) 1)
  46       (let* ((chr (aref string 0))
  47              (ucs (get-char-attribute chr 'ucs)))
  48         (if (or (eq ucs #x2FF0)
  49                 (eq ucs #x2FF1)
  50                 (and (<= #x2FF4 ucs)(<= ucs #x2FFB)))
  51             (cons chr
  52                   (substring string 1))))))
  53
  54 (defun idc-parse-op-3 (string)
  55   (if (>= (length string) 1)
  56       (let ((chr (aref string 0)))
  57         (if (memq chr '(?\u2FF2 ?\u2FF3))
  58             (cons chr
  59                   (substring string 1))))))
  60
  61 (defun idc-parse-component (string)
  62   (let ((ret (idc-parse-element string))
  63         rret)
  64     (when ret
  65       (if (and (listp (car ret))
  66                (setq rret (ideographic-structure-find-char
  67                            (cdr (assq 'ideographic-structure (car ret))))))
  68           (cons rret (cdr ret))
  69         ret))))
  70
  71 (defun idc-parse-element (string)
  72   (let (ret op arg1 arg2 arg3)
  73     (cond ((idc-parse-terminal string))
  74           ((setq ret (idc-parse-op-2 string))
  75            (setq op (car ret))
  76            (when (setq ret (idc-parse-component (cdr ret)))
  77              (setq arg1 (car ret))
  78              (when (setq ret (idc-parse-component (cdr ret)))
  79                (setq arg2 (car ret))
  80                (cons (list (list 'ideographic-structure op arg1 arg2))
  81                      (cdr ret)))))
  82           ((setq ret (idc-parse-op-3 string))
  83            (setq op (car ret))
  84            (when (setq ret (idc-parse-component (cdr ret)))
  85              (setq arg1 (car ret))
  86              (when (setq ret (idc-parse-component (cdr ret)))
  87                (setq arg2 (car ret))
  88                (when (setq ret (idc-parse-component (cdr ret)))
  89                  (setq arg3 (car ret))
  90                  (cons (list (list 'ideographic-structure op arg1 arg2 arg3))
  91                        (cdr ret)))))))))
  92
  93 ;;;###autoload
  94 (defun idc-parse-string (string)
  95   (let ((ret (idc-parse-element string)))
  96     (if (= (length (cdr ret)) 0)
  97         (car ret))))
  98
  99
 100 (require 'idc-util)
 101
 102 ;;;###autoload
 103 (defun idc-read-buffer (buffer)
 104   (with-current-buffer buffer
 105     (goto-char (point-min))
 106     (let (ucs
 107           radical seq ret
 108           char struct
 109           morohashi m-chr)
 110       (while (re-search-forward
 111               "^U\\+\\([0-9A-F]+\\)\t\\([0-9]+\\)\t[^\t]+\t\\([^\t\n]+\\)"
 112               nil t)
 113         (setq ucs (string-to-int (match-string 1) 16)
 114               radical (string-to-int (match-string 2))
 115               seq (match-string 3))
 116         (setq ret (idc-parse-string seq))
 117         (when (and (consp ret)
 118                    (consp
 119                     (setq struct (cdr (assq 'ideographic-structure ret)))))
 120           (setq char (decode-char 'ucs ucs))
 121           (unless (get-char-attribute char 'ideograph-daikanwa)
 122             (when (and (setq morohashi
 123                              (get-char-attribute char 'morohashi-daikanwa))
 124                        (>= (length morohashi) 3))
 125               (setq m-chr
 126                     (if (= (nth 1 morohashi) 0)
 127                         (decode-char 'ideograph-daikanwa
 128                                      (setq morohashi (car morohashi)))
 129                       (setq morohashi (list (car morohashi)
 130                                             (nth 1 morohashi)))
 131                       (map-char-attribute (lambda (char val)
 132                                             (if (equal morohashi val)
 133                                                 char))
 134                                           'morohashi-daikanwa)))
 135               (put-char-attribute
 136                m-chr
 137                'ideographic-structure
 138                (ideographic-structure-convert-to-daikanwa struct))))
 139           (put-char-attribute char 'ideographic-structure struct)
 140           (dolist (ref (union
 141                         (get-char-attribute char '->same-ideograph)
 142                         (get-char-attribute char '->identical)))
 143             (if (setq ret
 144                       (cond ((characterp ref) ref)
 145                             ((char-ref-p ref)
 146                              (find-char (plist-get ref :char)))
 147                             (t
 148                              (find-char ref))))
 149                 (put-char-attribute ret 'ideographic-structure struct)))
 150           )))))
 151
 152 ;; (idc-read-buffer "IDDef1.txt")
 153
 154 ;;; @ End.
 155 ;;;
 156
 157 (provide 'idc)
 158
 159 ;;; idc.el ends here