From 2e2b608c4f04f9a5591f354029c257453b6c31cf Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <matthias@benkard.de>
Date: Sun, 27 Jul 2008 18:55:03 +0200
Subject: Add ASSOC{-IF{-NOT}}, COMPLEMENT, CONSTANTLY, COPY-TREE, IDENTITY,
 RASSOC{-IF{-NOT}}, and {N}SUBLIS.

---
 list-functions-2.lisp | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 56 insertions(+)
 create mode 100644 list-functions-2.lisp

(limited to 'list-functions-2.lisp')

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))
-- 
cgit v1.2.3