From: tomo <tomo>
Date: Wed, 5 Apr 2006 13:47:36 +0000 (+0000)
Subject: New file.
X-Git-Tag: chise-base-0_23~25
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=39a242a680933fa5d5e71c32fe47ff45a38aad50;p=chise%2Fids.git

New file.
---

diff --git a/ids-rw.el b/ids-rw.el
new file mode 100644
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