From bd53a56fcde9c0e365e5935731abfcfb06b6c776 Mon Sep 17 00:00:00 2001
From: "Thomas M. Hermann" <tmh.public@gmail.com>
Date: Mon, 26 Jan 2009 15:28:50 +0000
Subject: [PATCH] [project @ Added ARRAY-EQUAL and supporting functions.]

Added a function, ARRAY-EQUAL, that will descend into 2 arrays and
checks each element for equality. Necessited 2 supporting
functions. The first function, DIMMENSIONS-EQUAL, returns true if the
arrays are of equal rank and equal dimension in each rank. The other
supporting function, ELEMENT-EQUAL, performs the actual work of the
testing each element of each array for equality.
---
 lisp-unit.lisp | 58 +++++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 43 insertions(+), 15 deletions(-)

diff --git a/lisp-unit.lisp b/lisp-unit.lisp
index 21e2ef4..2439071 100644
--- a/lisp-unit.lisp
+++ b/lisp-unit.lisp
@@ -108,6 +108,7 @@ For more information, see lisp-unit.html.
            #:remove-all-tests #:remove-tests
            #:logically-equal #:set-equal
 	   #:float-equal #:complex-equal #:number-equal
+	   #:array-equal
            #:use-debugger
            #:with-test-listener)
   )
@@ -442,7 +443,7 @@ point value."
 ;;; is less than epsilon. If an epsilon is not specified and either
 ;;; float1 or float2 is single precision, the single-float-epsilon is
 ;;; used.
-(defun float-equal (float1 float2 &optional (epsilon nil epsilonp))
+(defun float-equal (float1 float2 &optional epsilon)
   "Return true if the absolute difference between float1 and float2 is
 less than some epsilon."
   (and
@@ -450,7 +451,7 @@ less than some epsilon."
    (floatp float2)
    (cond
      ((and (zerop float1) (zerop float2)))
-     (epsilonp
+     (epsilon
       (> epsilon (roundoff-error float1 float2)))
      ((and (typep float1 'double-float) (typep float2 'double-float))
       (> (* 2.0 double-float-epsilon) (roundoff-error float1 float2)))
@@ -464,36 +465,63 @@ less than some epsilon."
 ;;; epsilon. If an epsilon is not specified and either complex1 or
 ;;; complex2 is (complex single-float), the single-float-epsilon is
 ;;; used.
-(defun complex-equal (complex1 complex2 &optional (epsilon nil epsilonp))
+(defun complex-equal (complex1 complex2 &optional epsilon)
   "Return true if the absolute difference between Re(complex1),
 Re(complex2) and the absolute difference between Im(complex1),
 Im(complex2) is less than epsilon."
   (and
    (typep complex1 '(complex float))
    (typep complex2 '(complex float))
-   (if epsilonp
-       (and (float-equal (realpart complex1) (realpart complex2) epsilon)
-            (float-equal (imagpart complex1) (imagpart complex2) epsilon))
-       (and (float-equal (realpart complex1) (realpart complex2))
-            (float-equal (imagpart complex1) (imagpart complex2))))))
+   (float-equal (realpart complex1) (realpart complex2) epsilon)
+   (float-equal (imagpart complex1) (imagpart complex2) epsilon)))
 
 ;;; (NUMBER-EQUAL number1 number2) => true or false
 ;;; Return true if the numbers are equal using the appropriate
 ;;; comparison.
-(defun number-equal (number1 number2 &optional (epsilon nil epsilonp))
+(defun number-equal (number1 number2 &optional epsilon)
   "Return true if the numbers are equal using the appropriate
 comparison."
   (cond
     ((and (floatp number1) (floatp number2))
-     (if epsilonp
-	 (float-equal number1 number2 epsilon)
-	 (float-equal number1 number2)))
+     (float-equal number1 number2 epsilon))
     ((and (typep number1 '(complex float)) (typep number2 '(complex float)))
-     (if epsilonp
-	 (complex-equal number1 number2 epsilon)
-	 (complex-equal number1 number2)))
+     (complex-equal number1 number2 epsilon))
     ((and (numberp number1) (numberp number2))
      (= number1 number2))
     (t (error "~A and ~A are not numbers." number1 number2))))
 
+;;; (ELEMENT-EQUAL array1 array2 indice dimensions) => true or false
+;;; A utility function for ARRAY-EQUAL.
+(defun element-equal (array1 array2 indices dimensions &optional epsilon)
+  "Return true if the index of array1 equals array2."
+  (let* ((rank (first dimensions))
+	 (remaining (rest dimensions))
+	 (update-result
+	  (if remaining
+	      (lambda (index)
+		(element-equal array1 array2
+			       (cons index indices) remaining epsilon))
+	      (lambda (index)
+		(number-equal (apply #'aref array1 index (reverse indices))
+			      (apply #'aref array2 index (reverse indices))
+			      epsilon)))))
+    (do ((index 0 (1+ index))
+	 (result t (funcall update-result index)))
+	((or (not result) (>= index rank)) result))))
+
+;;; (DIMENSIONS-EQUAL array1 array2) => true or false
+;;; A utility function for ARRAY-EQUAL
+(defun dimensions-equal (array1 array2)
+  "Return trun if ARRAY1 and ARRAY2 are equal dimensions."
+  (and
+   (= (array-rank array1) (array-rank array2))
+   (equal (array-dimensions array1) (array-dimensions array2))))
+
+;;; (ARRAY-EQUAL array1 array2) => true or false
+;;; Return true of the elements of the array are equal.
+(defun array-equal (array1 array2 &optional epsilon)
+  "Return true if the elements of the array are equal."
+  (when (dimensions-equal array1 array2)
+    (element-equal array1 array2 nil (array-dimensions array1) epsilon)))
+
 (provide "lisp-unit")
-- 
2.11.4.GIT