From 6b1ca8628e9818fb891fcbef20d090ec244d3593 Mon Sep 17 00:00:00 2001
From: Alfredo Beaumont <alfredo.beaumont@gmail.com>
Date: Sun, 12 May 2013 13:46:49 +0200
Subject: [PATCH] Add support for SUBLIS function, including tests

---
 src/list.lisp     |   13 +++++++++++++
 src/toplevel.lisp |    2 +-
 tests/list.lisp   |   23 +++++++++++++++++++++++
 3 files changed, 37 insertions(+), 1 deletion(-)

diff --git a/src/list.lisp b/src/list.lisp
index 99e6e7a..45aee57 100644
--- a/src/list.lisp
+++ b/src/list.lisp
@@ -99,6 +99,19 @@
 (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))
+  (labels ((s (tree)
+             (when (and testp test-not-p)
+               (error "Both test and test-not are set"))
+             (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 copy-list (x)
   (mapcar #'identity x))
diff --git a/src/toplevel.lisp b/src/toplevel.lisp
index 0698a0b..0bd763f 100644
--- a/src/toplevel.lisp
+++ b/src/toplevel.lisp
@@ -73,7 +73,7 @@
           prog2 progn psetq push quote rassoc read-from-string remove remove-if
           remove-if-not return return-from revappend reverse rplaca rplacd
           second set setf setq seventh sixth some string string-upcase string=
-          stringp subseq subst symbol-function symbol-name symbol-package
+          stringp sublis subseq subst symbol-function symbol-name symbol-package
           symbol-plist symbol-value symbolp t tagbody tailp tenth third throw
           tree-equal truncate unless unwind-protect values values-list variable
           vector-push-extend warn when write-line write-string zerop))
diff --git a/tests/list.lisp b/tests/list.lisp
index 17c3863..f002e1e 100644
--- a/tests/list.lisp
+++ b/tests/list.lisp
@@ -70,6 +70,29 @@
 (test (equal (cdddar '((1 2 3 4))) '(4)))
 (test (equal (cddddr '(1 2 3 4 5)) '(5)))
 
+;; SUBLIS
+(test (equal (sublis '((x . 100) (z . zprime))
+                     '(plus x (minus g z x p) 4 . x))
+             '(PLUS 100 (MINUS G ZPRIME 100 P) 4 . 100)))
+(test (equal (sublis '(((+ x y) . (- x y)) ((- x y) . (+ x y)))
+                     '(* (/ (+ x y) (+ x p)) (- x y))
+                     :test #'equal)
+             '(* (/ (- X Y) (+ X P)) (+ X Y))))
+(let ((tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4))))))
+  (test (equal (sublis '((3 . "three")) tree1)
+               '(1 (1 2) ((1 2 "three")) (((1 2 "three" 4))))))
+  (test (equal (sublis '((t . "string"))
+                       (sublis '((1 . "") (4 . 44)) tree1)
+                       :key #'stringp)
+               '("string" ("string" 2) (("string" 2 3)) ((("string" 2 3 44))))))
+  (test (equal tree1 '(1 (1 2) ((1 2 3)) (((1 2 3 4)))))))
+(let ((tree2 '("one" ("one" "two") (("one" "Two" "three")))))
+  (test (equal (sublis '(("two" . 2)) tree2)
+               '("one" ("one" "two") (("one" "Two" "three")))))
+  (test (equal tree2 '("one" ("one" "two") (("one" "Two" "three")))))
+  (test (equal (sublis '(("two" . 2)) tree2 :test 'equal)
+               '("one" ("one" 2) (("one" "Two" "three"))))))
+
 ; COPY-TREE
 (test (let* ((foo (list '(1 2) '(3 4)))
              (bar (copy-tree foo)))
-- 
1.7.10.4