New file.

diff --git a/ids-rw.el b/ids-rw.el
new file mode 100644 (file)
index 0000000..0886949
--- /dev/null
+++ b/ids-rw.el
@@ -0,0 +1,176 @@
+;;; ids-rw.el --- Rewriting utility for ideographic-structure.
+
+;; Copyright (C) 2006 MORIOKA Tomohiko
+
+;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
+;; Keywords: IDS, TRS, IDC, Ideographs, UCS, Unicode
+
+;; This file is a part of IDS.
+
+;; 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:
+
+(defun ideographic-structure-unify-char (structure pattern &optional env)
+  (if (char-ref-p structure)
+      (setq structure (plist-get structure :char)))
+  (cond
+   ((eq structure pattern)
+    (or env t)
+    )
+   ((symbolp pattern)
+    (if (eq env t)
+       (setq env nil))
+    (let ((ret (assq pattern env)))
+      (if ret
+         (if (eq structure (cdr ret))
+             env)
+       (cons (cons pattern structure)
+             env))))))
+
+(defun ideographic-structure-unify-unit (structure pattern &optional env)
+  (or (ideographic-structure-unify-char structure pattern env)
+      (let (prest srest ret)
+       (if (and
+            (progn
+              (if (setq ret
+                        (if (consp structure)
+                            (cdr (assq 'ideographic-structure structure))
+                          (char-feature structure 'ideographic-structure)))
+                  (setq structure ret))
+              (consp structure))
+            (setq srest structure)
+            (progn
+              (if (setq ret
+                        (cond ((consp pattern)
+                               (cdr (assq 'ideographic-structure pattern))
+                               )
+                              ((characterp pattern)
+                               (char-feature pattern 'ideographic-structure)
+                               )))
+                  (setq pattern ret))
+              (consp pattern))
+            (setq prest pattern)
+            (catch 'tag
+              (while prest
+                (if (not (setq env (ideographic-structure-unify-unit
+                                    (car srest) (car prest) env)))
+                    (throw 'tag nil))
+                (setq prest (cdr prest)
+                      srest (cdr srest)))
+              t))
+           (or env t)))))
+
+(defun ideographic-structure-apply-to-term (term env)
+  (let (ret dest rest)
+    (cond
+     ((symbolp term)
+      (if (setq ret (assq term env))
+         (cdr ret)
+       term))
+     ((and (consp term)
+          (cond ((setq ret (assq 'ideographic-structure term))
+                 (setq rest (cdr ret))
+                 )
+                ((atom (car term))
+                 (setq rest term)
+                 )))
+      (while rest
+       (setq dest
+             (cons (ideographic-structure-apply-to-term
+                    (car rest) env)
+                   dest))
+       (setq rest (cdr rest)))
+      (list (cons 'ideographic-structure (nreverse dest)))
+      )
+     (t term))))
+
+;;;###autoload
+(defun ideographic-structure-rewrite (structure
+                                     pattern replacement
+                                     &optional env)
+  (if (setq env (ideographic-structure-unify-unit structure pattern env))
+      (ideographic-structure-apply-to-term replacement env)
+    (let (srest cell ret dest)
+      (if (setq ret
+               (if (consp structure)
+                   (cdr (assq 'ideographic-structure structure))
+                 (char-feature structure 'ideographic-structure)))
+         (setq structure ret))
+      (when (consp structure)
+       (setq srest (cdr structure))
+       (if (catch 'tag
+             (while srest
+               (if (setq ret (ideographic-structure-rewrite
+                              (car srest)
+                              pattern replacement
+                              env))
+                   (throw 'tag ret))
+               (setq dest (cons (car srest) dest)
+                     srest (cdr srest))))
+           (cons (car structure)
+                 (append (nreverse (cons ret dest))
+                         (cdr srest))))))))
+
+;;;###autoload
+(defun ideographic-structure-rewrite-by-rules (structure rules)
+  (let (rest rule ret)
+    (while
+       (progn
+         (setq rest rules)
+         (if (catch 'tag
+               (while rest
+                 (setq rule (car rest))
+                 (if (setq ret (ideographic-structure-rewrite structure
+                                                              (car rule)
+                                                              (cdr rule)))
+                     (throw 'tag ret))
+                 (setq rest (cdr rest))))
+             (if (equal ret structure)
+                 nil
+               (setq structure ret)))))
+    structure))
+
+;;;###autoload
+(defun ideographic-structure-compact (structure)
+  (let ((rest structure)
+       cell
+       ret dest sub)
+    (while rest
+      (setq cell (car rest))
+      (cond
+       ((and (consp cell)
+            (cond ((setq ret (assq 'ideographic-structure cell))
+                   (setq sub (cdr ret))
+                   )
+                  ((atom (car cell))
+                   (setq sub cell)
+                   )))
+       (setq cell
+             (if (setq ret (ideographic-structure-find-char sub))
+                 ret
+               (list (cons 'ideographic-structure sub))))
+       ))
+      (setq dest (cons cell dest)))
+    (nreverse dest)))
+                                              
+
+;;; @ End.
+;;;
+
+(provide 'ids-rw)
+
+;;; ids-rw.el ends here