1 ;;; cbeta.el --- Parser for CBETA Ideographs representation.
3 ;; Copyright (C) 2001,2002,2006 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 the CHISE-IDS package.
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.
27 (defvar cbeta-replacement-char-alist
28 (list '(?\u2502 . ?\u4E28)
30 (cons ?\u2524 (decode-char '=gt-k 00153))
31 (cons ?\u3026 (decode-char 'japanese-jisx0208 #x5035))
40 (defun cbeta-parse-element (string simplify)
41 (let ((chr (aref string 0))
44 (if (> (length string) 1)
45 (let* ((ret (cbeta-parse-1 (substring string 1) simplify))
49 (eq (aref str 0) ?\)))
51 (if (> (length str) 1)
52 (substring str 1)))))))
56 (cons (if (setq ret (assq chr cbeta-replacement-char-alist))
59 (if (> (length string) 1)
60 (substring string 1)))))))
62 (defun cbeta-parse-component (string simplify)
63 (let ((ret (cbeta-parse-1 string simplify))
68 (setq rret (ideographic-structure-find-char
69 (cdr (assq 'ideographic-structure (car ret))))))
73 (defun cbeta-parse-horizontal (l-chr string simplify)
74 (let ((ret (cbeta-parse-component string simplify))
79 (setq rc (ideographic-structure-find-char
80 (cdr (assq 'ideographic-structure l-chr)))))
83 (list 'ideographic-structure
84 ;; '(:cdp-combinator 1 :char #x2FF0)
89 (defun cbeta-parse-vertical (u-chr string simplify)
90 (let ((ret (cbeta-parse-component string simplify))
95 (setq rc (ideographic-structure-find-char
96 (cdr (assq 'ideographic-structure u-chr)))))
99 (list 'ideographic-structure
100 ;; '(:cdp-combinator 2 :char #x2FF1)
105 (defun cbeta-parse-other (u-chr string simplify)
106 (let ((ret (cbeta-parse-component string simplify))
111 (setq rc (ideographic-structure-find-char
112 (cdr (assq 'ideographic-structure u-chr)))))
115 (list 'ideographic-structure
116 (cond ((memq u-chr '(?\u56D7))
118 ((memq u-chr '(?\u51E0))
120 ((memq u-chr '(?\u51F5))
122 ((memq u-chr '(?\u531A))
124 ((memq u-chr '(?\u5382 ?\u5C38))
131 (defun cbeta-substitute-char (s-chr old-chr new-chr)
133 (if (characterp s-chr)
134 (get-char-attribute s-chr 'ideographic-structure)
135 (cdr (assq 'ideographic-structure s-chr))))
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)))
146 (list (cons 'ideographic-structure ret))
148 ((setq ret (cbeta-substitute-char component old-chr new-chr))
149 (setq ret (nconc (nreverse dest)
150 (cons ret structure)))
153 (list (cons 'ideographic-structure ret))
156 (setq dest (cons component dest))))))))
158 (defun cbeta-delete-char (s-chr d-chr)
160 (if (characterp s-chr)
161 (get-char-attribute s-chr 'ideographic-structure)
162 (cdr (assq 'ideographic-structure s-chr))))
166 (setq component (car structure)
167 structure (cdr structure))
168 (cond ((equal component d-chr)
169 (setq ret (nconc (nreverse dest) structure))
172 (list (cons 'ideographic-structure ret))
174 ((setq ret (cbeta-delete-char component d-chr))
175 (setq ret (nconc (nreverse dest)
176 (cons ret structure)))
179 (list (cons 'ideographic-structure ret))
182 (setq dest (cons component dest))))))))
184 (defun cbeta-parse-substitution (s-chr string simplify)
185 (let ((ret (cbeta-parse-1 string simplify))
188 (setq old-chr (car ret)
193 (setq str (substring str 1))
194 (setq ret (cbeta-parse-1 str simplify))
196 (setq new-chr (car ret)
198 (when (setq ret (cbeta-substitute-char s-chr old-chr new-chr))
201 (defun cbeta-parse-elimination (s-chr string simplify)
202 (let ((ret (cbeta-parse-1 string simplify))
205 (setq old-chr (car ret)
207 (when (setq ret (cbeta-delete-char s-chr old-chr))
210 (defun cbeta-parse-1 (string simplify)
211 (let ((ret (cbeta-parse-element string simplify))
218 (setq op (aref str 0))
220 (setq str (substring str 1)))
222 (cbeta-parse-horizontal c1 str simplify))
224 (cbeta-parse-vertical c1 str simplify))
226 (cbeta-parse-other c1 str simplify))
228 (or (cbeta-parse-substitution c1 str simplify)
229 (cbeta-parse-elimination c1 str simplify)))))
238 ;;; cbeta.el ends here