1 ;;; cbeta.el --- Parser for CBETA Ideographs representation.
3 ;; Copyright (C) 2001,2002 MORIOKA Tomohiko
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: CBETA, IDS, Ideographs, UCS, Unicode
8 ;; This file is a part of Tomoyo-Tools.
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.
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.
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.
29 (defvar cbeta-replacement-char-alist
30 (list '(?\u2502 . ?\u4E28)
32 (cons ?\u2524 (decode-char '=gt-k 00153))
33 (cons ?\u3026 (decode-char 'japanese-jisx0208 #x5035))
42 (defun cbeta-parse-element (string simplify)
43 (let ((chr (aref string 0))
46 (if (> (length string) 1)
47 (let* ((ret (cbeta-parse-1 (substring string 1) simplify))
51 (eq (aref str 0) ?\)))
53 (if (> (length str) 1)
54 (substring str 1)))))))
58 (cons (if (setq ret (assq chr cbeta-replacement-char-alist))
61 (if (> (length string) 1)
62 (substring string 1)))))))
64 (defun cbeta-parse-component (string simplify)
65 (let ((ret (cbeta-parse-1 string simplify))
70 (setq rret (ideographic-structure-find-char
71 (cdr (assq 'ideographic-structure (car ret))))))
75 (defun cbeta-parse-horizontal (l-chr string simplify)
76 (let ((ret (cbeta-parse-component string simplify))
81 (setq rc (ideographic-structure-find-char
82 (cdr (assq 'ideographic-structure l-chr)))))
85 (list 'ideographic-structure
86 ;; '(:cdp-combinator 1 :char #x2FF0)
91 (defun cbeta-parse-vertical (u-chr string simplify)
92 (let ((ret (cbeta-parse-component string simplify))
97 (setq rc (ideographic-structure-find-char
98 (cdr (assq 'ideographic-structure u-chr)))))
101 (list 'ideographic-structure
102 ;; '(:cdp-combinator 2 :char #x2FF1)
107 (defun cbeta-parse-other (u-chr string simplify)
108 (let ((ret (cbeta-parse-component string simplify))
113 (setq rc (ideographic-structure-find-char
114 (cdr (assq 'ideographic-structure u-chr)))))
117 (list 'ideographic-structure
118 (cond ((memq u-chr '(?\u56D7))
120 ((memq u-chr '(?\u51E0))
122 ((memq u-chr '(?\u51F5))
124 ((memq u-chr '(?\u531A))
126 ((memq u-chr '(?\u5382 ?\u5C38))
133 (defun cbeta-substitute-char (s-chr old-chr new-chr)
135 (if (characterp s-chr)
136 (get-char-attribute s-chr 'ideographic-structure)
137 (cdr (assq 'ideographic-structure s-chr))))
141 (setq component (car structure)
142 structure (cdr structure))
143 (cond ((equal component old-chr)
144 (setq ret (nconc (nreverse dest)
145 (cons new-chr structure)))
148 (list (cons 'ideographic-structure ret))
150 ((setq ret (cbeta-substitute-char component old-chr new-chr))
151 (setq ret (nconc (nreverse dest)
152 (cons ret structure)))
155 (list (cons 'ideographic-structure ret))
158 (setq dest (cons component dest))))))))
160 (defun cbeta-delete-char (s-chr d-chr)
162 (if (characterp s-chr)
163 (get-char-attribute s-chr 'ideographic-structure)
164 (cdr (assq 'ideographic-structure s-chr))))
168 (setq component (car structure)
169 structure (cdr structure))
170 (cond ((equal component d-chr)
171 (setq ret (nconc (nreverse dest) structure))
174 (list (cons 'ideographic-structure ret))
176 ((setq ret (cbeta-delete-char component d-chr))
177 (setq ret (nconc (nreverse dest)
178 (cons ret structure)))
181 (list (cons 'ideographic-structure ret))
184 (setq dest (cons component dest))))))))
186 (defun cbeta-parse-substitution (s-chr string simplify)
187 (let ((ret (cbeta-parse-1 string simplify))
190 (setq old-chr (car ret)
195 (setq str (substring str 1))
196 (setq ret (cbeta-parse-1 str simplify))
198 (setq new-chr (car ret)
200 (when (setq ret (cbeta-substitute-char s-chr old-chr new-chr))
203 (defun cbeta-parse-elimination (s-chr string simplify)
204 (let ((ret (cbeta-parse-1 string simplify))
207 (setq old-chr (car ret)
209 (when (setq ret (cbeta-delete-char s-chr old-chr))
212 (defun cbeta-parse-1 (string simplify)
213 (let ((ret (cbeta-parse-element string simplify))
220 (setq op (aref str 0))
222 (setq str (substring str 1)))
224 (cbeta-parse-horizontal c1 str simplify))
226 (cbeta-parse-vertical c1 str simplify))
228 (cbeta-parse-other c1 str simplify))
230 (or (cbeta-parse-substitution c1 str simplify)
231 (cbeta-parse-elimination c1 str simplify)))))
240 ;;; cbeta.el ends here