Add TEST-NOT keyword argument to TREE-EQUAL

[jscl.git] / src / list.lisp

diff --git a/src/list.lisp b/src/list.lisp
index d515e52..96a3594 100644 (file)
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -15,7 +15,7 @@
 
 ;;;; Various list functions
 
-(defun cons (x y ) (cons x y))
+(defun cons (x y) (cons x y))
 (defun consp (x) (consp x))
 
 (defun listp (x)
@@ -72,17 +72,16 @@
 (defun cadr (x) (car (cdr x)))
 (defun cdar (x) (cdr (car x)))
 (defun cddr (x) (cdr (cdr x)))
-(defun cadar (x) (car (cdr (car x))))
-(defun caddr (x) (car (cdr (cdr x))))
-(defun cdddr (x) (cdr (cdr (cdr x))))
-(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-
-(defun cadar  (x) (car (cdar  x)))
-(defun caaar  (x) (car (caar  x)))
-(defun caadr  (x) (car (cadr  x)))
-(defun cdaar  (x) (cdr (caar  x)))
-(defun cdadr  (x) (cdr (cadr  x)))
-(defun cddar  (x) (cdr (cdar  x)))
+
+(defun caaar (x) (car (caar x)))
+(defun caadr (x) (car (cadr x)))
+(defun cadar (x) (car (cdar x)))
+(defun caddr (x) (car (cddr x)))
+(defun cdaar (x) (cdr (caar x)))
+(defun cdadr (x) (cdr (cadr x)))
+(defun cddar (x) (cdr (cdar x)))
+(defun cdddr (x) (cdr (cddr x)))
+
 (defun caaaar (x) (car (caaar x)))
 (defun caaadr (x) (car (caadr x)))
 (defun caadar (x) (car (cadar x)))
@@ -90,6 +89,7 @@
 (defun cadaar (x) (car (cdaar x)))
 (defun cadadr (x) (car (cdadr x)))
 (defun caddar (x) (car (cddar x)))
+(defun cadddr (x) (car (cdddr x)))
 (defun cdaaar (x) (cdr (caaar x)))
 (defun cdaadr (x) (cdr (caadr x)))
 (defun cdadar (x) (cdr (cadar x)))
@@ -99,6 +99,33 @@
 (defun cdddar (x) (cdr (cddar x)))
 (defun cddddr (x) (cdr (cdddr x)))
 
+(defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql test-not-p))
+  (when (and testp test-not-p)
+    (error "Both test and test-not are set"))
+  (labels ((s (tree)
+             (let* ((key-val (if key (funcall key tree) tree))
+                    (replace (if test-not-p
+                                 (assoc key-val alist :test-not test-not)
+                                 (assoc key-val alist :test test)))
+                    (x (if replace (cdr replace) tree)))
+               (if (atom x)
+                   x
+                   (cons (s (car x)) (s (cdr x)))))))
+    (s tree)))
+
+(defun subst (new old tree &key key (test #'eql testp) (test-not #'eql test-not-p))
+  (labels ((s (x)
+             (cond ((satisfies-test-p old x :key key :test test :testp testp
+                                      :test-not test-not :test-not-p test-not-p)
+                    new)
+                   ((atom x) x)
+                   (t (let ((a (s (car x)))
+                            (b (s (cdr x))))
+                        (if (and (eq a (car x))
+                                 (eq b (cdr x)))
+                            x
+                            (cons a b)))))))
+    (s tree)))
 
 (defun copy-list (x)
   (mapcar #'identity x))
@@ -109,12 +136,17 @@
           (copy-tree (cdr tree)))
     tree))
 
-(defun tree-equal (tree1 tree2 &key (test #'eql))
-  (if (atom tree1)
-    (and (atom tree2) (funcall test tree1 tree2))
-    (and (consp tree2)
-         (tree-equal (car tree1) (car tree2) :test test)
-         (tree-equal (cdr tree1) (cdr tree2) :test test))))
+(defun tree-equal (tree1 tree2 &key (test #'eql testp)
+                         (test-not #'eql test-not-p))
+  (when (and testp test-not-p) (error "Both test and test-not are set"))
+  (let ((func (if test-not-p (complement test-not) test)))
+    (labels ((%tree-equal (tree1 tree2)
+               (if (atom tree1)
+                 (and (atom tree2) (funcall func tree1 tree2))
+                 (and (consp tree2)
+                      (%tree-equal (car tree1) (car tree2))
+                      (%tree-equal (cdr tree1) (cdr tree2))))))
+      (%tree-equal tree1 tree2))))
 
 (defun tailp (object list)
   (do ((tail list (cdr tail)))
@@ -122,15 +154,6 @@
     (when (eql tail object)
       (return-from tailp t))))
 
-(defun subst (new old tree &key (key #'identity) (test #'eql))
-  (cond 
-    ((funcall test (funcall key tree) (funcall key old))
-     new) 
-    ((consp tree)
-     (cons (subst new old (car tree) :key key :test test)
-           (subst new old (cdr tree) :key key :test test))) 
-    (t tree)))
-
 (defmacro pop (place)
   (multiple-value-bind (dummies vals newval setter getter)
     (get-setf-expansion place)