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.

---
 control-flow.lisp       | 10 +++++++++
 destructuring-bind.lisp |  2 +-
 init.lisp               |  2 ++
 list-functions-2.lisp   | 56 +++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 69 insertions(+), 1 deletion(-)
 create mode 100644 control-flow.lisp
 create mode 100644 list-functions-2.lisp

diff --git a/control-flow.lisp b/control-flow.lisp
new file mode 100644
index 0000000..0d380aa
--- /dev/null
+++ b/control-flow.lisp
@@ -0,0 +1,10 @@
+(defun identity (x)
+  x)
+
+(defun constantly (c)
+  (lambda (x)
+    (declare (ignore x))
+    c))
+
+(defun complement (function)
+  (lambda (x) (not (funcall function x))))
diff --git a/destructuring-bind.lisp b/destructuring-bind.lisp
index b819a16..1207649 100644
--- a/destructuring-bind.lisp
+++ b/destructuring-bind.lisp
@@ -89,7 +89,7 @@
                            (keyword-name
                             (if (and (consp head) (consp (car head)))
                                 (caar head)
-                                (intern (symbol-name var) '#:keyword))))
+                                (intern (symbol-name var) (find-package '#:keyword)))))
                       `(let* ((,sym ,expression)
                               (,value-sym (getf ,sym ,keyword-name ',missing))
                               ,@(cond ((atom head)
diff --git a/init.lisp b/init.lisp
index ab91247..241439f 100644
--- a/init.lisp
+++ b/init.lisp
@@ -5,4 +5,6 @@
 (load "destructuring-bind.lisp")
 (load "defun-1.lisp")
 (load "list-functions.lisp")
+(load "control-flow.lisp")
+(load "list-functions-2.lisp")
 (in-package :common-lisp-user)
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