cbeta.el

   1 ;;; cbeta.el --- Parser for CBETA Ideographs representation.
   2
   3 ;; Copyright (C) 2001,2002,2006 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: CBETA, IDS, Ideographs, UCS, Unicode
   7
   8 ;; This file is a part of the CHISE-IDS package.
   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 (defvar cbeta-replacement-char-alist
  28   (list '(?\u2502 . ?\u4E28)
  29         '(?\u251C . ?\u2E8A)
  30         (cons ?\u2524 (decode-char '=gt-k 00153))
  31         (cons ?\u3026 (decode-char 'japanese-jisx0208 #x5035))
  32         '(?\u3039 . ?\u8279)
  33         '(?\u3106 . ?\u6535)
  34         '(?\u3113 . ?\u37A2)
  35         '(?\u3117 . ?\u5369)
  36         '(?\u3128 . ?\u3405)
  37         '(?\u3120 . ?\u5E7A)
  38         ))
  39
  40 (defun cbeta-parse-element (string simplify)
  41   (let ((chr (aref string 0))
  42         ret)
  43     (cond ((eq chr ?\()
  44            (if (> (length string) 1)
  45                (let* ((ret (cbeta-parse-1 (substring string 1) simplify))
  46                       (str (cdr ret)))
  47                  (if (and str
  48                           (>= (length str) 1)
  49                           (eq (aref str 0) ?\)))
  50                      (cons (car ret)
  51                            (if (> (length str) 1)
  52                                (substring str 1)))))))
  53           ((eq chr ?\))
  54            nil)
  55           (t
  56            (cons (if (setq ret (assq chr cbeta-replacement-char-alist))
  57                      (cdr ret)
  58                    chr)
  59                  (if (> (length string) 1)
  60                      (substring string 1)))))))
  61
  62 (defun cbeta-parse-component (string simplify)
  63   (let ((ret (cbeta-parse-1 string simplify))
  64         rret)
  65     (when ret
  66       (if (and simplify
  67                (listp (car ret))
  68                (setq rret (ideographic-structure-find-char
  69                            (cdr (assq 'ideographic-structure (car ret))))))
  70           (cons rret (cdr ret))
  71         ret))))
  72
  73 (defun cbeta-parse-horizontal (l-chr string simplify)
  74   (let ((ret (cbeta-parse-component string simplify))
  75         rc)
  76     (when ret
  77       (if (and simplify
  78                (listp l-chr)
  79                (setq rc (ideographic-structure-find-char
  80                          (cdr (assq 'ideographic-structure l-chr)))))
  81           (setq l-chr rc))
  82       (cons (list
  83              (list 'ideographic-structure
  84                    ;; '(:cdp-combinator 1 :char #x2FF0)
  85                    ?\u2FF0
  86                    l-chr (car ret)))
  87             (cdr ret)))))
  88
  89 (defun cbeta-parse-vertical (u-chr string simplify)
  90   (let ((ret (cbeta-parse-component string simplify))
  91         rc)
  92     (when ret
  93       (if (and simplify
  94                (listp u-chr)
  95                (setq rc (ideographic-structure-find-char
  96                          (cdr (assq 'ideographic-structure u-chr)))))
  97           (setq u-chr rc))
  98       (cons (list
  99              (list 'ideographic-structure
 100                    ;; '(:cdp-combinator 2 :char #x2FF1)
 101                    ?\u2FF1
 102                    u-chr (car ret)))
 103             (cdr ret)))))
 104
 105 (defun cbeta-parse-other (u-chr string simplify)
 106   (let ((ret (cbeta-parse-component string simplify))
 107         rc)
 108     (when ret
 109       (if (and simplify
 110                (listp u-chr)
 111                (setq rc (ideographic-structure-find-char
 112                          (cdr (assq 'ideographic-structure u-chr)))))
 113           (setq u-chr rc))
 114       (cons (list
 115              (list 'ideographic-structure
 116                    (cond ((memq u-chr '(?\u56D7))
 117                           ?\u2FF4)
 118                          ((memq u-chr '(?\u51E0))
 119                           ?\u2FF5)
 120                          ((memq u-chr '(?\u51F5))
 121                           ?\u2FF6)
 122                          ((memq u-chr '(?\u531A))
 123                           ?\u2FF7)
 124                          ((memq u-chr '(?\u5382 ?\u5C38))
 125                           ?\u2FF8)
 126                          (t
 127                           ?\u2FFB))
 128                    u-chr (car ret)))
 129             (cdr ret)))))
 130
 131 (defun cbeta-substitute-char (s-chr old-chr new-chr)
 132   (let ((structure
 133          (if (characterp s-chr)
 134              (get-char-attribute s-chr 'ideographic-structure)
 135            (cdr (assq 'ideographic-structure s-chr))))
 136         component dest ret)
 137     (catch 'tag
 138       (while structure
 139         (setq component (car structure)
 140               structure (cdr structure))
 141         (cond ((equal component old-chr)
 142                (setq ret (nconc (nreverse dest)
 143                                 (cons new-chr structure)))
 144                (throw 'tag
 145                       (if (cdr (cdr ret))
 146                           (list (cons 'ideographic-structure ret))
 147                         (car (cdr ret)))))
 148               ((setq ret (cbeta-substitute-char component old-chr new-chr))
 149                (setq ret (nconc (nreverse dest)
 150                                 (cons ret structure)))
 151                (throw 'tag
 152                       (if (cdr (cdr ret))
 153                           (list (cons 'ideographic-structure ret))
 154                         (car (cdr ret)))))
 155               (t
 156                (setq dest (cons component dest))))))))
 157
 158 (defun cbeta-delete-char (s-chr d-chr)
 159   (let ((structure
 160          (if (characterp s-chr)
 161              (get-char-attribute s-chr 'ideographic-structure)
 162            (cdr (assq 'ideographic-structure s-chr))))
 163         component dest ret)
 164     (catch 'tag
 165       (while structure
 166         (setq component (car structure)
 167               structure (cdr structure))
 168         (cond ((equal component d-chr)
 169                (setq ret (nconc (nreverse dest) structure))
 170                (throw 'tag
 171                       (if (cdr (cdr ret))
 172                           (list (cons 'ideographic-structure ret))
 173                         (car (cdr ret)))))
 174               ((setq ret (cbeta-delete-char component d-chr))
 175                (setq ret (nconc (nreverse dest)
 176                                 (cons ret structure)))
 177                (throw 'tag
 178                       (if (cdr (cdr ret))
 179                           (list (cons 'ideographic-structure ret))
 180                         (car (cdr ret)))))
 181               (t
 182                (setq dest (cons component dest))))))))
 183
 184 (defun cbeta-parse-substitution (s-chr string simplify)
 185   (let ((ret (cbeta-parse-1 string simplify))
 186         old-chr new-chr str)
 187     (when ret
 188       (setq old-chr (car ret)
 189             str (cdr ret))
 190       (when (and str
 191                  (eq (aref str 0) ?+)
 192                  (>= (length str) 2))
 193         (setq str (substring str 1))
 194         (setq ret (cbeta-parse-1 str simplify))
 195         (when ret
 196           (setq new-chr (car ret)
 197                 str (cdr ret))
 198           (when (setq ret (cbeta-substitute-char s-chr old-chr new-chr))
 199             (cons ret str)))))))
 200
 201 (defun cbeta-parse-elimination (s-chr string simplify)
 202   (let ((ret (cbeta-parse-1 string simplify))
 203         old-chr str)
 204     (when ret
 205       (setq old-chr (car ret)
 206             str (cdr ret))
 207       (when (setq ret (cbeta-delete-char s-chr old-chr))
 208         (cons ret str)))))
 209
 210 (defun cbeta-parse-1 (string simplify)
 211   (let ((ret (cbeta-parse-element string simplify))
 212         c1 str
 213         op)
 214     (when ret
 215       (setq c1 (car ret)
 216             str (cdr ret))
 217       (or (if (and str
 218                    (setq op (aref str 0))
 219                    (> (length str) 1)
 220                    (setq str (substring str 1)))
 221               (cond ((eq op ?*)
 222                      (cbeta-parse-horizontal c1 str simplify))
 223                     ((eq op ?/)
 224                      (cbeta-parse-vertical c1 str simplify))
 225                     ((eq op ?@)
 226                      (cbeta-parse-other c1 str simplify))
 227                     ((eq op ?-)
 228                      (or (cbeta-parse-substitution c1 str simplify)
 229                          (cbeta-parse-elimination c1 str simplify)))))
 230           ret))))
 231
 232
 233 ;;; @ End.
 234 ;;;
 235
 236 (provide 'cbeta)
 237
 238 ;;; cbeta.el ends here