Add ASSOC{-IF{-NOT}}, COMPLEMENT, CONSTANTLY, COPY-TREE, IDENTITY, RASSOC{-IF{-NOT}}, and {N}SUBLIS.

1 files changed, 56 insertions, 0 deletions

diff --git a/list-functions-2.lisp b/list-functions-2.lisp
new file mode 100644
index 0000000..2e73a46
--- /dev/null
+++ b/list-functions-2.lisp
@@ -0,0 +1,56 @@
+(defun copy-tree (tree)
+  (typecase tree
+    (cons (cons (copy-tree (car cons)) (copy-tree (cdr cons))))
+    (t tree)))
+
+
+(defun assoc (item alist &key key test test-not)
+  (setq test (or test (if test-not
+                          (complement test-not)
+                          (function eql))))
+  (assoc-if (lambda (x) (funcall test x item))
+            alist
+            :key key))
+
+(defun assoc-if (predicate alist &key key)
+  (setq key (or key (function identity)))
+  (cond ((endp alist) nil)
+        ((funcall predicate (funcall key (caar alist)))
+         (car alist))
+        (t (assoc-if predicate (cdr alist) :key key))))
+
+(defun assoc-if-not (predicate alist &key key)
+  (assoc-if (complement predicate) alist :key key))
+
+
+(defun rassoc (item alist &key key test test-not)
+  (setq test (or test (if test-not
+                          (complement test-not)
+                          (function eql))))
+  (rassoc-if (lambda (x) (funcall test x item))
+             alist
+             :key key))
+
+(defun rassoc-if (predicate alist &key key)
+  (setq key (or key (function identity))
+  (cond ((endp alist) nil)
+        ((funcall predicate (funcall key (cdar alist)))
+         (car alist))
+        (t (assoc-if predicate (cdr alist) :key key)))))
+
+(defun rassoc-if-not (predicate alist &key key)
+  (rassoc-if (complement predicate) alist :key key))
+
+
+(defun sublis (alist tree &key key test test-not)
+  (let ((ass (assoc (funcall key tree) :test test :test-not test-not)))
+    (if ass
+        (cdr assoc)
+        (typecase tree
+          (cons
+           (cons (sublis alist (car tree) :key key :test test :test-not test-not)
+                 (sublis alist (cdr tree) :key key :test test :test-not test-not)))
+          (t tree)))))
+
+(defun nsublis (alist tree &key key test test-not)
+  (sublvs alist tree :key key :test test :test-not test-not))