[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv16294

Modified Files:
	cons.lisp 
Log Message:
Added the subst family of functions.


--- /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2006/05/02 17:12:20	1.14
+++ /project/movitz/cvsroot/movitz/losp/muerte/cons.lisp	2006/05/02 20:01:01	1.15
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  8 15:25:45 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: cons.lisp,v 1.14 2006/05/02 17:12:20 ffjeld Exp $
+;;;; $Id: cons.lisp,v 1.15 2006/05/02 20:01:01 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -288,7 +288,7 @@
 		       ((atom subtree) subtree)
 		       (t (let ((car (s (car subtree)))
 				(cdr (s (cdr subtree))))
-			    (if (and (eq car (car subtreE))
+			    (if (and (eq car (car subtree))
 				     (eq cdr (cdr subtree)))
 				subtree
 			      (cons car cdr))))))))
@@ -310,7 +310,68 @@
 			     (if (setq temp (assoc (funcall key subtree) alist :test test))
 				 (setf (cdr last) (cdr temp))))
 			  (if (setq temp (assoc (funcall key subtree) alist :test test))
-			      (return (setf (Cdr last) (Cdr temp)))
+			      (return (setf (Cdr last) (cdr temp)))
 			    (setf (car subtree) (s (car subtree)))))
 			subtree))))
       (s tree))))
+
+(defun subst (new old tree &key key (test 'eql) test-not)
+  "=> new-tree"
+  (let ((test (if test-not (complement test-not) test))
+	(key (or key 'identity)))
+    (labels ((do-subst (subtree)
+	       (cond
+		((funcall test old (funcall key subtree))
+		 new)
+		((atom subtree)
+		 subtree)
+		(t (cons (do-subst (car subtree))
+			 (do-subst (cdr subtree)))))))
+      (do-subst tree))))
+
+(defun subst-if (new predicate tree &key key)
+  "=> new-tree"
+  (let ((key (or key 'identity)))
+    (labels ((do-subst (subtree)
+	       (cond
+		((funcall predicate (funcall key subtree))
+		 new)
+		((atom subtree)
+		 subtree)
+		(t (cons (do-subst (car subtree))
+			 (do-subst (cdr subtree)))))))
+      (do-subst tree))))
+
+(defun subst-if-not (new predicate tree &key key)
+  (subst-if new (complement predicate) tree :key key))
+
+(defun nsubst (new old tree &key key (test 'eql) test-not)
+  (let ((test (if test-not (complement test-not) test))
+	(key (or key 'identity)))
+    (labels ((do-subst (subtree)
+	       (cond
+		((funcall test old (funcall key subtree))
+		 new)
+		((atom subtree)
+		 subtree)
+		(t (setf (car subtree) (do-subst (car subtree))
+			 (cdr subtree) (do-subst (cdr subtree)))
+		   subtree))))
+      (do-subst tree))))
+
+(defun nsubst-if (new predicate tree &key key)
+  "=> new-tree"
+  (let ((key (or key 'identity)))
+    (labels ((do-subst (subtree)
+	       (cond
+		((funcall predicate (funcall key subtree))
+		 new)
+		((atom subtree)
+		 subtree)
+		(t (setf (car subtree) (do-subst (car subtree))
+			 (cdr subtree) (do-subst (cdr subtree)))
+		   subtree))))
+      (do-subst tree))))
+
+(defun nsubst-if-not (new predicate tree &key key)
+  (nsubst-if new (complement predicate) tree :key key))