From c0004da163b4baa7115b2e4f1c63de65af2d89d0 Mon Sep 17 00:00:00 2001 From: "Thomas M. Hermann" Date: Fri, 6 Mar 2009 03:56:19 +0000 Subject: [PATCH] [project @ Organized the code into separate files.] Moved the package definition to defpackage.lisp and the floating point related functions to floating-point.lisp. This was motivated by the desire to track any changes made to the original LISP-UNIT by the author. By separating additional functionality into other files, it will be easier to identify differences in lisp-unit.lisp. --- defpackage.lisp | 24 ++++++++ floating-point.lisp | 141 ++++++++++++++++++++++++++++++++++++++++++++ lisp-unit.asd | 66 +++++++-------------- lisp-unit.lisp | 166 +--------------------------------------------------- 4 files changed, 187 insertions(+), 210 deletions(-) create mode 100644 defpackage.lisp create mode 100644 floating-point.lisp rewrite lisp-unit.asd (81%) diff --git a/defpackage.lisp b/defpackage.lisp new file mode 100644 index 0000000..198c995 --- /dev/null +++ b/defpackage.lisp @@ -0,0 +1,24 @@ +;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Packages +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(common-lisp:defpackage #:lisp-unit + (:use #:common-lisp) + (:export #:define-test #:run-all-tests #:run-tests + #:assert-eq #:assert-eql #:assert-equal #:assert-equalp + #:assert-error #:assert-expands #:assert-false + #:assert-equality #:assert-prints #:assert-true + #:get-test-code #:get-tests + #:remove-all-tests #:remove-tests + #:logically-equal #:set-equal + #:float-equal #:complex-equal #:number-equal + #:array-equal + #:significant-figures-equal + #:3-sigfig-equal #:4-sigfig-equal + #:5-sigfig-equal #:6-sigfig-equal + #:use-debugger + #:with-test-listener)) + +(pushnew :lisp-unit common-lisp:*features*) diff --git a/floating-point.lisp b/floating-point.lisp new file mode 100644 index 0000000..0a2c6ec --- /dev/null +++ b/floating-point.lisp @@ -0,0 +1,141 @@ +;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;; References +;;;; [NumLinAlg] James W. Demmel "Applied Numerical Linear Algebra", +;;;; Society for Industrial and Applied Mathematics, 1997 +;;;; ISBN: 0-89871-389-7 + +(common-lisp:in-package :lisp-unit) + +;;; (ROUNDOFF-ERROR x y) => number +;;; Return the error delta between the exact and approximate floating +;;; point value. +;;; Equation 1.1 in NumLinAlg +(defun roundoff-error (exact approximate) + "Returned the error delta between the exact and approximate floating +point value." + (abs (if (or (= 0.0 exact) (= 0.0 approximate)) + (+ exact approximate) + (- (/ approximate exact) 1.0)))) + +;;; (FLOAT-EQUAL float1 float2 &optional epsilon) => true or false +;;; Return true if the absolute difference between float1 and float2 +;;; 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) + "Return true if the absolute difference between float1 and float2 is +less than some epsilon." + (and + (floatp float1) + (floatp float2) + (cond + ((and (zerop float1) (zerop float2))) + (epsilon + (> epsilon (roundoff-error float1 float2))) + ((and (typep float1 'double-float) (typep float2 'double-float)) + (> (* 2.0 double-float-epsilon) (roundoff-error float1 float2))) + ((or (typep float1 'single-float) (typep float2 'single-float)) + (> (* 2.0 single-float-epsilon) (roundoff-error float1 float2))) + (t nil)))) + +;;; (COMPLEX-EQUAL complex1 complex2 &optional epsilon) => true or false +;;; Return true if the absolute difference of the real components and +;;; the absolute difference of the imaginary components is less then +;;; 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) + "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)) + (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) + "Return true if the numbers are equal using the appropriate +comparison." + (cond + ((and (floatp number1) (floatp number2)) + (float-equal number1 number2 epsilon)) + ((and (typep number1 '(complex float)) (typep number2 '(complex float))) + (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 &key (test #'number-equal)) + "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 :test test)) + (lambda (index) + (funcall test + (apply #'aref array1 index (reverse indices)) + (apply #'aref array2 index (reverse indices))))))) + (do ((index 0 (1+ index)) + (result t (funcall update-result index))) + ((or (not result) (>= index rank)) result)))) + +;;; (ARRAY-EQUAL array1 array2) => true or false +;;; Return true of the elements of the array are equal. +(defun array-equal (array1 array2 &key (test #'number-equal)) + "Return true if the elements of the array are equal." + (when (equal (array-dimensions array1) (array-dimensions array2)) + (element-equal array1 array2 nil (array-dimensions array1) :test test))) + +;;; (NORMALIZE-FLOAT significand &optional exponent) => significand,exponent +(defun normalize-float (significand &optional (exponent 0)) + "Return the normalized floating point number and exponent." + (cond + ((zerop significand) + (values significand 0)) + ((>= (abs significand) 10) + (normalize-float (/ significand 10.0) (1+ exponent))) + ((< (abs significand) 1) + (normalize-float (* significand 10.0) (1- exponent))) + (t (values significand exponent)))) + +;;; (SIGNIFICANT-FIGURES-EQUAL float1 float2 significant-figures) => true or false +(defun significant-figures-equal (float1 float2 significant-figures) + "Return true if the floating point numbers have equal significant +figures." + (let ((delta (* (float 5 float1) (expt (float 10 float2) (- significant-figures))))) + (if (or (zerop float1) (zerop float2)) + (< (abs (+ float1 float2)) delta) + (multiple-value-bind (sig1 exp1) (normalize-float float1) + (multiple-value-bind (sig2 exp2) (normalize-float float2) + (and (= exp1 exp2) + (< (abs (- sig1 sig2)) delta))))))) + +(defun 2-sigfig-equal (float1 float2) + "Return true if the floats are equal to 2 significant figures." + (significant-figures-equal float1 float2 2)) + +(defun 3-sigfig-equal (float1 float2) + "Return true if the floats are equal to 3 significant figures." + (significant-figures-equal float1 float2 3)) + +(defun 4-sigfig-equal (float1 float2) + "Return true if the floats are equal to 4 significant figures." + (significant-figures-equal float1 float2 4)) + +(defun 5-sigfig-equal (float1 float2) + "Return true if the floats are equal to 5 significant figures." + (significant-figures-equal float1 float2 5)) + +(defun 6-sigfig-equal (float1 float2) + "Return true if the floats are equal to 6 significant figures." + (significant-figures-equal float1 float2 6)) diff --git a/lisp-unit.asd b/lisp-unit.asd dissimilarity index 81% index dc2d017..1254908 100644 --- a/lisp-unit.asd +++ b/lisp-unit.asd @@ -1,45 +1,21 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- -;;;; -;;;; lisp-unit -;;;; -;;;; Copyright (c) 2007, Thomas M. Hermann -;;;; All rights reserved. -;;;; -;;;; Redistribution and use in source and binary forms, with or without -;;;; modification, are permitted provided that the following conditions are -;;;; met: -;;;; -;;;; o Redistributions of source code must retain the above copyright -;;;; notice, this list of conditions and the following disclaimer. -;;;; o 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. -;;;; o The names of the contributors may not 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. -;;;; - -(common-lisp:defpackage #:lisp-unit-system - (:use #:common-lisp #:asdf)) - -(common-lisp:in-package #:lisp-unit-system) - -(defsystem :lisp-unit - :description "Common Lisp library that supports unit testing." - :version "Draft" - :author "Christopher K. Riesbeck " - :license "MIT" - :components ((:file "lisp-unit"))) +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- +;;;; +;;;; lisp-unit +;;;; + +(common-lisp:defpackage #:lisp-unit-system + (:use #:common-lisp #:asdf)) + +(common-lisp:in-package #:lisp-unit-system) + +(defsystem :lisp-unit + :description "Common Lisp library that supports unit testing." + :version "Draft" + :author "Christopher K. Riesbeck " + :license "MIT" + :components ((:file "defpackage") + (:file "lisp-unit" + :depends-on ("defpackage")) + (:file "floating-point" + :depends-on ("defpackage" + "lisp-unit")))) diff --git a/lisp-unit.lisp b/lisp-unit.lisp index 32dfb18..fa7098c 100644 --- a/lisp-unit.lisp +++ b/lisp-unit.lisp @@ -94,31 +94,7 @@ For more information, see lisp-unit.html. |# -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Packages -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(cl:defpackage #:lisp-unit - (:use #:common-lisp) - (:export #:define-test #:run-all-tests #:run-tests - #:assert-eq #:assert-eql #:assert-equal #:assert-equalp - #:assert-error #:assert-expands #:assert-false - #:assert-equality #:assert-prints #:assert-true - #:get-test-code #:get-tests - #:remove-all-tests #:remove-tests - #:logically-equal #:set-equal - #:float-equal #:complex-equal #:number-equal - #:array-equal - #:significant-figures-equal - #:3-sigfig-equal #:4-sigfig-equal - #:5-sigfig-equal #:6-sigfig-equal - #:use-debugger - #:with-test-listener) - ) - -(in-package #:lisp-unit) - -(pushnew :lisp-unit *features*) +(common-lisp:in-package #:lisp-unit) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Globals @@ -430,143 +406,3 @@ For more information, see lisp-unit.html. (listp l2) (subsetp l1 l2 :test test) (subsetp l2 l1 :test test))) - -;;; (ROUNDOFF-ERROR x y) => number -;;; Return the error delta between the exact and approximate floating -;;; point value. -;;; Equation 1.1 in NumLinAlg -(defun roundoff-error (exact approximate) - "Returned the error delta between the exact and approximate floating -point value." - (abs (if (or (= 0.0 exact) (= 0.0 approximate)) - (+ exact approximate) - (- (/ approximate exact) 1.0)))) - -;;; (FLOAT-EQUAL float1 float2 &optional epsilon) => true or false -;;; Return true if the absolute difference between float1 and float2 -;;; 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) - "Return true if the absolute difference between float1 and float2 is -less than some epsilon." - (and - (floatp float1) - (floatp float2) - (cond - ((and (zerop float1) (zerop float2))) - (epsilon - (> epsilon (roundoff-error float1 float2))) - ((and (typep float1 'double-float) (typep float2 'double-float)) - (> (* 2.0 double-float-epsilon) (roundoff-error float1 float2))) - ((or (typep float1 'single-float) (typep float2 'single-float)) - (> (* 2.0 single-float-epsilon) (roundoff-error float1 float2))) - (t nil)))) - -;;; (COMPLEX-EQUAL complex1 complex2 &optional epsilon) => true or false -;;; Return true if the absolute difference of the real components and -;;; the absolute difference of the imaginary components is less then -;;; 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) - "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)) - (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) - "Return true if the numbers are equal using the appropriate -comparison." - (cond - ((and (floatp number1) (floatp number2)) - (float-equal number1 number2 epsilon)) - ((and (typep number1 '(complex float)) (typep number2 '(complex float))) - (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 &key (test #'number-equal)) - "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 :test test)) - (lambda (index) - (funcall test - (apply #'aref array1 index (reverse indices)) - (apply #'aref array2 index (reverse indices))))))) - (do ((index 0 (1+ index)) - (result t (funcall update-result index))) - ((or (not result) (>= index rank)) result)))) - -;;; (ARRAY-EQUAL array1 array2) => true or false -;;; Return true of the elements of the array are equal. -(defun array-equal (array1 array2 &key (test #'number-equal)) - "Return true if the elements of the array are equal." - (when (equal (array-dimensions array1) (array-dimensions array2)) - (element-equal array1 array2 nil (array-dimensions array1) :test test))) - -;;; (NORMALIZE-FLOAT significand &optional exponent) => significand,exponent -(defun normalize-float (significand &optional (exponent 0)) - "Return the normalized floating point number and exponent." - (cond - ((zerop significand) - (values significand 0)) - ((>= (abs significand) 10) - (normalize-float (/ significand 10.0) (1+ exponent))) - ((< (abs significand) 1) - (normalize-float (* significand 10.0) (1- exponent))) - (t (values significand exponent)))) - -;;; (SIGNIFICANT-FIGURES-EQUAL float1 float2 significant-figures) => true or false -(defun significant-figures-equal (float1 float2 significant-figures) - "Return true if the floating point numbers have equal significant -figures." - (let ((delta (* (float 5 float1) (expt (float 10 float2) (- significant-figures))))) - (if (or (zerop float1) (zerop float2)) - (< (abs (+ float1 float2)) delta) - (multiple-value-bind (sig1 exp1) (normalize-float float1) - (multiple-value-bind (sig2 exp2) (normalize-float float2) - (and (= exp1 exp2) - (< (abs (- sig1 sig2)) delta))))))) - -(defun 2-sigfig-equal (float1 float2) - "Return true if the floats are equal to 2 significant figures." - (significant-figures-equal float1 float2 2)) - -(defun 3-sigfig-equal (float1 float2) - "Return true if the floats are equal to 3 significant figures." - (significant-figures-equal float1 float2 3)) - -(defun 4-sigfig-equal (float1 float2) - "Return true if the floats are equal to 4 significant figures." - (significant-figures-equal float1 float2 4)) - -(defun 5-sigfig-equal (float1 float2) - "Return true if the floats are equal to 5 significant figures." - (significant-figures-equal float1 float2 5)) - -(defun 6-sigfig-equal (float1 float2) - "Return true if the floats are equal to 6 significant figures." - (significant-figures-equal float1 float2 6)) - -;;;; References -;;;; [NumLinAlg] James W. Demmel "Applied Numerical Linear Algebra", -;;;; Society for Industrial and Applied Mathematics, 1997 -;;;; ISBN: 0-89871-389-7 - -(provide "lisp-unit") -- 2.11.4.GIT