1 ;;; ids-rw.el --- Rewriting utility for ideographic-structure.
3 ;; Copyright (C) 2006 MORIOKA Tomohiko
5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
6 ;; Keywords: IDS, TRS, IDC, Ideographs, UCS, Unicode
8 ;; This file is a part of IDS.
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 (defun ideographic-structure-unify-char (structure pattern &optional env)
28 (if (char-ref-p structure)
29 (setq structure (plist-get structure :char)))
31 ((eq structure pattern)
37 (let ((ret (assq pattern env)))
39 (if (eq structure (cdr ret))
41 (cons (cons pattern structure)
44 (defun ideographic-structure-unify-unit (structure pattern &optional env)
45 (or (ideographic-structure-unify-char structure pattern env)
46 (let (prest srest ret)
51 (cdr (assq 'ideographic-structure structure))
52 (char-feature structure 'ideographic-structure)))
55 (setq srest structure)
58 (cond ((consp pattern)
59 (cdr (assq 'ideographic-structure pattern))
62 (char-feature pattern 'ideographic-structure)
69 (if (not (setq env (ideographic-structure-unify-unit
70 (car srest) (car prest) env)))
72 (setq prest (cdr prest)
77 (defun ideographic-structure-apply-to-term (term env)
81 (if (setq ret (assq term env))
85 (cond ((setq ret (assq 'ideographic-structure term))
93 (cons (ideographic-structure-apply-to-term
96 (setq rest (cdr rest)))
97 (list (cons 'ideographic-structure (nreverse dest)))
102 (defun ideographic-structure-rewrite (structure
105 (if (setq env (ideographic-structure-unify-unit structure pattern env))
106 (ideographic-structure-apply-to-term replacement env)
107 (let (srest cell ret dest)
109 (if (consp structure)
110 (cdr (assq 'ideographic-structure structure))
111 (char-feature structure 'ideographic-structure)))
112 (setq structure ret))
113 (when (consp structure)
114 (setq srest (cdr structure))
117 (if (setq ret (ideographic-structure-rewrite
122 (setq dest (cons (car srest) dest)
124 (cons (car structure)
125 (append (nreverse (cons ret dest))
129 (defun ideographic-structure-rewrite-by-rules (structure rules)
136 (setq rule (car rest))
137 (if (setq ret (ideographic-structure-rewrite structure
141 (setq rest (cdr rest))))
142 (if (equal ret structure)
144 (setq structure ret)))))
148 (defun ideographic-structure-compact (structure)
149 (let ((rest structure)
153 (setq cell (car rest))
156 (cond ((setq ret (assq 'ideographic-structure cell))
163 (if (setq ret (ideographic-structure-find-char sub))
165 (list (cons 'ideographic-structure sub))))
167 (setq dest (cons cell dest)))
176 ;;; ids-rw.el ends here