From f095e5d08dc4e5af4e9382e5e83434465c72bd5a Mon Sep 17 00:00:00 2001 From: tomo Date: Thu, 12 Oct 2006 06:00:23 +0000 Subject: [PATCH] New file. --- cbeta.el | 240 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 240 insertions(+) create mode 100644 cbeta.el diff --git a/cbeta.el b/cbeta.el new file mode 100644 index 0000000..7abea03 --- /dev/null +++ b/cbeta.el @@ -0,0 +1,240 @@ +;;; cbeta.el --- Parser for CBETA Ideographs representation. + +;; Copyright (C) 2001,2002 MORIOKA Tomohiko + +;; Author: MORIOKA Tomohiko +;; 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 -- 1.7.10.4