From 8f59cd56540bb3699c80c141f30968cb0126ce04 Mon Sep 17 00:00:00 2001 From: Owen Rodley Date: Sat, 18 May 2013 16:26:27 +1200 Subject: [PATCH] Add TEST-NOT keyword argument to TREE-EQUAL --- src/list.lisp | 17 +++++++++++------ tests/list.lisp | 6 ++++-- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/src/list.lisp b/src/list.lisp index d4439dd..96a3594 100644 --- a/src/list.lisp +++ b/src/list.lisp @@ -136,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))) diff --git a/tests/list.lisp b/tests/list.lisp index 7ce643e..075a657 100644 --- a/tests/list.lisp +++ b/tests/list.lisp @@ -120,9 +120,11 @@ ; TREE-EQUAL (test (tree-equal '(1 2 3) '(1 2 3))) +(test (not (tree-equal '(1 2 3) '(3 2 1)))) (test (tree-equal '(1 (2 (3 4) 5) 6) '(1 (2 (3 4) 5) 6))) -(test (tree-equal (cons 1 2) (cons 2 3) - :test (lambda (a b) (not (= a b))))) +(test (tree-equal (cons 1 2) (cons 2 3) :test (lambda (a b) (not (= a b))))) +(test (tree-equal '(1 . 2) '(2 . 1) :test-not #'eql)) +(test (not (tree-equal '(1 . 2) '(1 . 2) :test-not #'eql))) ; FIRST to TENTH (let ((nums '(1 2 3 4 5 6 7 8 9 10))) -- 1.7.10.4