CEQUAL takes a list of graphs, and compares them for deep equality. Unlike EQUAL, it works even in the presence of circularity. CEQUAL can be used on any data structure for which one has a deep and a shallow equality predicates, and a list of accessors to the children. These default to values appropriate for the comparison of cons.
Also provided are wrappers for the special cases of comparing any number of conses (CONS-EQUAL)and comparing any 2 graphs (CEQUAL2).
Example:
CL-USER> (cons-cequal '#1=(a #1# a #1# . #1#)
'#2=(a #2# . #2#))
T
Looking for comments, etc. (apologies to anyone stuck at 80 columns).
Paul Khuong
(x-posted to c.l.l, but the post seems to not want to show up today)
cequal.lisp:
;License: Modified BSD License
;Copyright (c) 2005, Paul-Virak Khuong
; All rights reserved.
;
;
;Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
;
;Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
;Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
;Neither the name of the Million Monkey Enterprises nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defun map-to-end (fn &rest lists)
"Like mapcar, but iterates until *all* the lists
are empty (defaults to nil)."
(labels ((inner (lists acc)
(if (every #'null lists)
(nreverse acc)
(inner (mapcar #'cdr lists)
(cons (apply fn (mapcar #'car lists))
acc)))))
(inner lists nil)))
(defun cequal (trees &key (shallow-test #'eq)
(deep-test #'equal)
(accessors (list #'car #'cdr)))
"Circularity-aware deep equality test. Works on arbitrary
Data structures, only need to specify shallow-test
(used to set the test used for a quick escape),
deep-test (used to test atoms for equality)
and accessors (used to traverse the structures).
Takes a list of trees as the input. Defaults to comparing
cons."
(labels ((inner (trees trees-cyclep trees-acc)
"Inner test. Recurses through the accessors to go down the tree.
Keeps a trail as it goes down to make sure it's not going where
it's already gone."
(let ((trees-cyclep (map-to-end (lambda (tree tree-acc tree-cyclep) ;;Whether the corresponding path is
(or tree-cyclep ;;proven circular (1st tree -> 1st cell)
(member tree tree-acc :test shallow-test))) ;;or the current cell is in our
trees trees-acc trees-cyclep)) ;;path -> circular.
(trees-acc (map-to-end (lambda (tree tree-acc) ;;Save the path.
(cons tree tree-acc))
trees trees-acc)))
(cond ((every (lambda (x)
(funcall shallow-test (first trees) ;;shallow-test tests for object identity
x)) ;;If all the same object, then we can exit early.
(rest trees))
t)
((every #'identity trees-cyclep) t) ;;if all cyclic and not proven unequal yet, then equal
((every #'atom trees) ;;all atoms, can just go and use deep-equality test.
(every (lambda (x)
(funcall deep-test x (first trees))) ;;are they all deep-equal?
(rest trees)))
((some #'atom trees) ;;at least one is an atom, and at least one isn't. Not all the same.
nil)
((notany #'atom trees);;none atoms. (already known, but wth)
(every (lambda (accessor) ;;go down the tree w/ each accessor.
(funcall #'inner (mapcar accessor trees)
trees-cyclep trees-acc))
accessors)))))) ;;Only all equal if all the corresponding children are.
(inner trees nil nil)))
(defun cequal2 (tree1 tree2 &key (shallow-test #'eq)
(deep-test #'equal)
(accessors (list #'car #'cdr)))
"Handler for the case where we have only 2 trees to compare."
(cequal `(,tree1 ,tree2) :shallow-test shallow-test
:deep-test deep-test
:accessors accessors))
(defun cons-cequal (&rest trees)
"Handler for n cons."
(cequal trees))

;License: Modified BSD License
;Copyright (c) 2005, Paul-Virak Khuong
; All rights reserved.
;
;
;Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
;
;Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
;Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
;Neither the name of the Million Monkey Enterprises nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defun cequal (trees &key (shallow-test #'eq)
(deep-test #'equal)
(accessors (list #'car #'cdr)))
"Circularity-aware deep equality test. Works on arbitrary
Data structures, only need to specify shallow-test
(used to set the test used for a quick escape),
deep-test (used to test atoms for equality)
and accessors (used to traverse the structures).
Takes a list of trees as the input. Defaults to comparing
cons."
(labels ((inner (trees trees-cyclep trees-acc)
"Inner test. Recurses through the accessors to go down the tree.
Keeps a trail as it goes down to make sure it's not going where
it's already gone."
(let ((trees-cyclep (mapcar (lambda (tree tree-acc tree-cyclep) ;;Whether the corresponding path is
(or tree-cyclep ;;proven circular (1st tree -> 1st cell)
(member tree tree-acc :test shallow-test))) ;;or the current cell is in our
trees trees-acc trees-cyclep)) ;;path -> circular.
(trees-acc (mapcar (lambda (tree tree-acc) ;;Save the path.
(cons tree tree-acc))
trees trees-acc)))
(cond ((every (lambda (x)
(funcall shallow-test (first trees) ;;shallow-test tests for object identity
x)) ;;If all the same object, then we can exit early.
(rest trees))
t)
((every #'identity trees-cyclep) t) ;;if all cyclic and not proven unequal yet, then equal
((every #'atom trees) ;;all atoms, can just go and use deep-equality test.
(every (lambda (x)
(funcall deep-test x (first trees))) ;;are they all deep-equal?
(rest trees)))
((some #'atom trees) ;;at least one is an atom, and at least one isn't. Not all the same.
nil)
((notany #'atom trees);;none atoms. (already known, but wth)
(every (lambda (accessor) ;;go down the tree w/ each accessor.
(funcall #'inner (mapcar accessor trees)
trees-cyclep trees-acc))
accessors)))))) ;;Only all equal if all the corresponding children are.
(inner trees (make-list (length trees) :initial-element nil)
(make-list (length trees) :initial-element nil))))
(defun cequal2 (tree1 tree2 &key (shallow-test #'eq)
(deep-test #'equal)
(accessors (list #'car #'cdr)))
"Handler for the case where we have only 2 trees to compare."
(cequal `(,tree1 ,tree2) :shallow-test shallow-test
:deep-test deep-test
:accessors accessors))
(defun cons-cequal (&rest trees)
"Handler for n cons."
(cequal trees))

;License: Modified BSD License
;Copyright (c) 2005, Paul-Virak Khuong
; All rights reserved.
;
;
;Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
;
;Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
;Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
;Neither the name of the Million Monkey Enterprises nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
;
;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defun cequal (trees &key (shallow-test #'eq)
(deep-test #'equal)
(accessors (list #'car #'cdr)))
"Circularity-aware deep equality test. Works on arbitrary
Data structures, only need to specify shallow-test
(used to set the test used for a quick escape),
deep-test (used to test atoms for equality)
and accessors (used to traverse the structures).
Takes a list of trees as the input. Defaults to comparing
cons."
(labels ((inner (trees trees-cyclep trees-acc)
"Inner test. Recurses through the accessors to go down the tree.
Keeps a trail as it goes down to make sure it's not going where
it's already gone.
trees is a list of graphs to check for equality.
trees-cyclep is a list of boolean. If the first tree in trees
is known to be circular, the first boolean in trees-cyclep is true,
NIL otherwise, and so on.
trees-acc accumulates the trail of the nodes we've been through
for each tree in trees. Again, the first stack corresponds to the
first tree in trees, etc."
(let ((trees-cyclep (mapcar (lambda (tree tree-acc tree-cyclep) ;;Whether the corresponding path is
(or tree-cyclep ;;proven circular (1st tree -> 1st cell)
(member tree tree-acc :test shallow-test))) ;;or the current cell is in our
trees trees-acc trees-cyclep)) ;;path -> circular.
(trees-acc (mapcar (lambda (tree tree-acc) ;;Save the path.
(cons tree tree-acc))
trees trees-acc)))
(cond ((every (lambda (x)
(funcall shallow-test (first trees) ;;shallow-test tests for object identity
x)) ;;If all the same object, then we can exit early.
(rest trees))
t)
((every #'identity trees-cyclep) t) ;;if all cyclic and not proven unequal yet, then equal
((every #'atom trees) ;;all atoms, can just go and use deep-equality test.
(every (lambda (x)
(funcall deep-test x (first trees))) ;;are they all deep-equal?
(rest trees)))
((some #'atom trees) ;;at least one is an atom, and at least one isn't. Not all the same.
nil)
((notany #'atom trees);;none atoms. (already known, but wth)
(every (lambda (accessor) ;;go down the tree w/ each accessor.
(inner (mapcar accessor trees)
trees-cyclep trees-acc))
accessors)))))) ;;Only all equal if all the corresponding children are.
(inner trees (make-list (length trees) :initial-element nil)
(make-list (length trees) :initial-element nil))))
(defun cequal2 (tree1 tree2 &key (shallow-test #'eq)
(deep-test #'equal)
(accessors (list #'car #'cdr)))
"Handler for the case where we have only 2 trees to compare."
(cequal `(,tree1 ,tree2) :shallow-test shallow-test
:deep-test deep-test
:accessors accessors))
(defun cons-cequal (&rest trees)
"Handler for n cons."
(cequal trees))