idc.el

   1 (defun idc-parse-terminal (string)
   2   (if (>= (length string) 1)
   3       (let* ((chr (aref string 0))
   4              (ucs (get-char-attribute chr 'ucs))
   5              big5)
   6         (unless (and ucs (<= #x2FF0 ucs)(<= ucs #x2FFF))
   7           (if (and ucs (<= #xE000 ucs)(<= ucs #xF8FF)
   8                    (setq big5 (get-char-attribute chr 'chinese-big5)))
   9               (setq chr (decode-char 'chinese-big5-cdp big5)))
  10           (cons chr
  11                 (substring string 1))))))
  12
  13 (defun idc-parse-op-2 (string)
  14   (if (>= (length string) 1)
  15       (let* ((chr (aref string 0))
  16              (ucs (get-char-attribute chr 'ucs)))
  17         (if (or (eq ucs #x2FF0)
  18                 (eq ucs #x2FF1)
  19                 (and (<= #x2FF4 ucs)(<= ucs #x2FFB)))
  20             (cons chr
  21                   (substring string 1))))))
  22
  23 (defun idc-parse-op-3 (string)
  24   (if (>= (length string) 1)
  25       (let ((chr (aref string 0)))
  26         (if (memq chr '(?\u2FF2 ?\u2FF3))
  27             (cons chr
  28                   (substring string 1))))))
  29
  30 (defun idc-parse-component (string)
  31   (let ((ret (idc-parse-element string))
  32         rret)
  33     (when ret
  34       (if (and (listp (car ret))
  35                (setq rret (ideographic-structure-find-char
  36                            (cdr (assq 'ideographic-structure (car ret))))))
  37           (cons rret (cdr ret))
  38         ret))))
  39
  40 (defun idc-parse-element (string)
  41   (let (ret op arg1 arg2 arg3)
  42     (cond ((idc-parse-terminal string))
  43           ((setq ret (idc-parse-op-2 string))
  44            (setq op (car ret))
  45            (when (setq ret (idc-parse-component (cdr ret)))
  46              (setq arg1 (car ret))
  47              (when (setq ret (idc-parse-component (cdr ret)))
  48                (setq arg2 (car ret))
  49                (cons (list (list 'ideographic-structure op arg1 arg2))
  50                      (cdr ret)))))
  51           ((setq ret (idc-parse-op-3 string))
  52            (setq op (car ret))
  53            (when (setq ret (idc-parse-component (cdr ret)))
  54              (setq arg1 (car ret))
  55              (when (setq ret (idc-parse-component (cdr ret)))
  56                (setq arg2 (car ret))
  57                (when (setq ret (idc-parse-component (cdr ret)))
  58                  (setq arg3 (car ret))
  59                  (cons (list (list 'ideographic-structure op arg1 arg2 arg3))
  60                        (cdr ret)))))))))
  61
  62 ;;;###autoload
  63 (defun idc-parse-string (string)
  64   (let ((ret (idc-parse-element string)))
  65     (if (= (length (cdr ret)) 0)
  66         (car ret))))
  67
  68
  69 (require 'idc-util)
  70
  71 ;;;###autoload
  72 (defun idc-read-buffer (buffer)
  73   (with-current-buffer buffer
  74     (goto-char (point-min))
  75     (let (ucs
  76           radical seq ret
  77           char struct
  78           morohashi m-chr)
  79       (while (re-search-forward
  80               "^U\\+\\([0-9A-F]+\\)\t\\([0-9]+\\)\t[^\t]+\t\\([^\t\n]+\\)"
  81               nil t)
  82         (setq ucs (string-to-int (match-string 1) 16)
  83               radical (string-to-int (match-string 2))
  84               seq (match-string 3))
  85         (setq ret (idc-parse-string seq))
  86         (when (and (consp ret)
  87                    (consp
  88                     (setq struct (cdr (assq 'ideographic-structure ret)))))
  89           (setq char (decode-char 'ucs ucs))
  90           (unless (get-char-attribute char 'ideograph-daikanwa)
  91             (when (and (setq morohashi
  92                              (get-char-attribute char 'morohashi-daikanwa))
  93                        (>= (length morohashi) 3))
  94               (setq m-chr
  95                     (if (= (nth 1 morohashi) 0)
  96                         (decode-char 'ideograph-daikanwa
  97                                      (setq morohashi (car morohashi)))
  98                       (setq morohashi (list (car morohashi)
  99                                             (nth 1 morohashi)))
 100                       (map-char-attribute (lambda (char val)
 101                                             (if (equal morohashi val)
 102                                                 char))
 103                                           'morohashi-daikanwa)))
 104               (put-char-attribute
 105                m-chr
 106                'ideographic-structure
 107                (ideographic-structure-convert-to-daikanwa struct))))
 108           (put-char-attribute char 'ideographic-structure struct)
 109           (dolist (ref (union
 110                         (get-char-attribute char '->same-ideograph)
 111                         (get-char-attribute char '->identical)))
 112             (if (setq ret
 113                       (cond ((characterp ref) ref)
 114                             ((char-ref-p ref)
 115                              (find-char (plist-get ref :char)))
 116                             (t
 117                              (find-char ref))))
 118                 (put-char-attribute ret 'ideographic-structure struct)))
 119           )))))
 120
 121 ;; (idc-read-buffer "IDDef1.txt")