--- /dev/null
+;;; cbeta.el --- Parser for CBETA Ideographs representation.
+
+;; Copyright (C) 2001,2002 MORIOKA Tomohiko
+
+;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
+;; Keywords: CBETA, IDS, Ideographs, UCS, Unicode
+
+;; This file is a part of Tomoyo-Tools.
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+;; (require 'mojikyo)
+
+(defvar cbeta-replacement-char-alist
+ (list '(?\u2502 . ?\u4E28)
+ '(?\u251C . ?\u2E8A)
+ (cons ?\u2524 (decode-char '=gt-k 00153))
+ (cons ?\u3026 (decode-char 'japanese-jisx0208 #x5035))
+ '(?\u3039 . ?\u8279)
+ '(?\u3106 . ?\u6535)
+ '(?\u3113 . ?\u37A2)
+ '(?\u3117 . ?\u5369)
+ '(?\u3128 . ?\u3405)
+ '(?\u3120 . ?\u5E7A)
+ ))
+
+(defun cbeta-parse-element (string simplify)
+ (let ((chr (aref string 0))
+ ret)
+ (cond ((eq chr ?\()
+ (if (> (length string) 1)
+ (let* ((ret (cbeta-parse-1 (substring string 1) simplify))
+ (str (cdr ret)))
+ (if (and str
+ (>= (length str) 1)
+ (eq (aref str 0) ?\)))
+ (cons (car ret)
+ (if (> (length str) 1)
+ (substring str 1)))))))
+ ((eq chr ?\))
+ nil)
+ (t
+ (cons (if (setq ret (assq chr cbeta-replacement-char-alist))
+ (cdr ret)
+ chr)
+ (if (> (length string) 1)
+ (substring string 1)))))))
+
+(defun cbeta-parse-component (string simplify)
+ (let ((ret (cbeta-parse-1 string simplify))
+ rret)
+ (when ret
+ (if (and simplify
+ (listp (car ret))
+ (setq rret (ideographic-structure-find-char
+ (cdr (assq 'ideographic-structure (car ret))))))
+ (cons rret (cdr ret))
+ ret))))
+
+(defun cbeta-parse-horizontal (l-chr string simplify)
+ (let ((ret (cbeta-parse-component string simplify))
+ rc)
+ (when ret
+ (if (and simplify
+ (listp l-chr)
+ (setq rc (ideographic-structure-find-char
+ (cdr (assq 'ideographic-structure l-chr)))))
+ (setq l-chr rc))
+ (cons (list
+ (list 'ideographic-structure
+ ;; '(:cdp-combinator 1 :char #x2FF0)
+ ?\u2FF0
+ l-chr (car ret)))
+ (cdr ret)))))
+
+(defun cbeta-parse-vertical (u-chr string simplify)
+ (let ((ret (cbeta-parse-component string simplify))
+ rc)
+ (when ret
+ (if (and simplify
+ (listp u-chr)
+ (setq rc (ideographic-structure-find-char
+ (cdr (assq 'ideographic-structure u-chr)))))
+ (setq u-chr rc))
+ (cons (list
+ (list 'ideographic-structure
+ ;; '(:cdp-combinator 2 :char #x2FF1)
+ ?\u2FF1
+ u-chr (car ret)))
+ (cdr ret)))))
+
+(defun cbeta-parse-other (u-chr string simplify)
+ (let ((ret (cbeta-parse-component string simplify))
+ rc)
+ (when ret
+ (if (and simplify
+ (listp u-chr)
+ (setq rc (ideographic-structure-find-char
+ (cdr (assq 'ideographic-structure u-chr)))))
+ (setq u-chr rc))
+ (cons (list
+ (list 'ideographic-structure
+ (cond ((memq u-chr '(?\u56D7))
+ ?\u2FF4)
+ ((memq u-chr '(?\u51E0))
+ ?\u2FF5)
+ ((memq u-chr '(?\u51F5))
+ ?\u2FF6)
+ ((memq u-chr '(?\u531A))
+ ?\u2FF7)
+ ((memq u-chr '(?\u5382 ?\u5C38))
+ ?\u2FF8)
+ (t
+ ?\u2FFB))
+ u-chr (car ret)))
+ (cdr ret)))))
+
+(defun cbeta-substitute-char (s-chr old-chr new-chr)
+ (let ((structure
+ (if (characterp s-chr)
+ (get-char-attribute s-chr 'ideographic-structure)
+ (cdr (assq 'ideographic-structure s-chr))))
+ component dest ret)
+ (catch 'tag
+ (while structure
+ (setq component (car structure)
+ structure (cdr structure))
+ (cond ((equal component old-chr)
+ (setq ret (nconc (nreverse dest)
+ (cons new-chr structure)))
+ (throw 'tag
+ (if (cdr (cdr ret))
+ (list (cons 'ideographic-structure ret))
+ (car (cdr ret)))))
+ ((setq ret (cbeta-substitute-char component old-chr new-chr))
+ (setq ret (nconc (nreverse dest)
+ (cons ret structure)))
+ (throw 'tag
+ (if (cdr (cdr ret))
+ (list (cons 'ideographic-structure ret))
+ (car (cdr ret)))))
+ (t
+ (setq dest (cons component dest))))))))
+
+(defun cbeta-delete-char (s-chr d-chr)
+ (let ((structure
+ (if (characterp s-chr)
+ (get-char-attribute s-chr 'ideographic-structure)
+ (cdr (assq 'ideographic-structure s-chr))))
+ component dest ret)
+ (catch 'tag
+ (while structure
+ (setq component (car structure)
+ structure (cdr structure))
+ (cond ((equal component d-chr)
+ (setq ret (nconc (nreverse dest) structure))
+ (throw 'tag
+ (if (cdr (cdr ret))
+ (list (cons 'ideographic-structure ret))
+ (car (cdr ret)))))
+ ((setq ret (cbeta-delete-char component d-chr))
+ (setq ret (nconc (nreverse dest)
+ (cons ret structure)))
+ (throw 'tag
+ (if (cdr (cdr ret))
+ (list (cons 'ideographic-structure ret))
+ (car (cdr ret)))))
+ (t
+ (setq dest (cons component dest))))))))
+
+(defun cbeta-parse-substitution (s-chr string simplify)
+ (let ((ret (cbeta-parse-1 string simplify))
+ old-chr new-chr str)
+ (when ret
+ (setq old-chr (car ret)
+ str (cdr ret))
+ (when (and str
+ (eq (aref str 0) ?+)
+ (>= (length str) 2))
+ (setq str (substring str 1))
+ (setq ret (cbeta-parse-1 str simplify))
+ (when ret
+ (setq new-chr (car ret)
+ str (cdr ret))
+ (when (setq ret (cbeta-substitute-char s-chr old-chr new-chr))
+ (cons ret str)))))))
+
+(defun cbeta-parse-elimination (s-chr string simplify)
+ (let ((ret (cbeta-parse-1 string simplify))
+ old-chr str)
+ (when ret
+ (setq old-chr (car ret)
+ str (cdr ret))
+ (when (setq ret (cbeta-delete-char s-chr old-chr))
+ (cons ret str)))))
+
+(defun cbeta-parse-1 (string simplify)
+ (let ((ret (cbeta-parse-element string simplify))
+ c1 str
+ op)
+ (when ret
+ (setq c1 (car ret)
+ str (cdr ret))
+ (or (if (and str
+ (setq op (aref str 0))
+ (> (length str) 1)
+ (setq str (substring str 1)))
+ (cond ((eq op ?*)
+ (cbeta-parse-horizontal c1 str simplify))
+ ((eq op ?/)
+ (cbeta-parse-vertical c1 str simplify))
+ ((eq op ?@)
+ (cbeta-parse-other c1 str simplify))
+ ((eq op ?-)
+ (or (cbeta-parse-substitution c1 str simplify)
+ (cbeta-parse-elimination c1 str simplify)))))
+ ret))))
+
+
+;;; @ End.
+;;;
+
+(provide 'cbeta)
+
+;;; cbeta.el ends here
projects / chise / ids.git / commitdiff