From 19bafc2f50cecfcab8ab0aff2e9bfaf92864ec0c Mon Sep 17 00:00:00 2001 From: "Thomas M. Hermann" Date: Fri, 6 Mar 2009 15:36:43 +0000 Subject: [PATCH] [project @ Added a copyright statement and cleaned up comments.] --- floating-point.lisp | 82 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 33 deletions(-) diff --git a/floating-point.lisp b/floating-point.lisp index 7d447f7..1068b1c 100644 --- a/floating-point.lisp +++ b/floating-point.lisp @@ -1,5 +1,36 @@ -;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- - +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- +;;;; +;;;; Additional LISP-UNIT tests and assertions +;;;; +;;;; Copyright (c) 2009, 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. +;;;; ;;;; References ;;;; [NumLinAlg] James W. Demmel "Applied Numerical Linear Algebra", ;;;; Society for Industrial and Applied Mathematics, 1997 @@ -14,46 +45,33 @@ "Default to 4 significant figures.") ;;; (ROUNDOFF-ERROR x y) => number -;;; Return the error delta between the exact and approximate floating -;;; point value. -;;; [NumLinAlg] : Equation 1.1, pg. 12 (defun roundoff-error (exact approximate) "Return the error delta between the exact and approximate floating point value." + ;; [NumLinAlg] : Equation 1.1, pg. 12 (abs (if (or (zerop exact) (zerop 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 *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)))) + (when (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)))) (defmacro assert-float-equal (expected form &rest extras) (expand-assert :equal form form expected extras :test #'float-equal)) ;;; (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 *epsilon*)) "Return true if the absolute difference between Re(complex1), Re(complex2) and the absolute difference between Im(complex1), @@ -68,8 +86,6 @@ Im(complex2) is less than epsilon." (expand-assert :equal form form expected extras :test #'complex-equal)) ;;; (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 *epsilon*)) "Return true if the numbers are equal using the appropriate comparison." @@ -117,7 +133,6 @@ figures." :test (lambda (f1 f2) (sigfig-equal f1 f2 significant-figures)))) ;;; (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)) @@ -130,10 +145,11 @@ figures." :test `(lambda (a1 a2) (array-equal a1 a2 :test ,element-test)))) ;;; (NUMERICAL-EQUAL result1 result2) => true or false -;;; This is a universal wrapper function used by Liam Healy. It is -;;; implemented to support testing in GSLL. While the interface is -;;; identical to previous versions, the implementation details are -;;; slightly different to use the routines here. +;;; +;;; This is a universal wrapper created by Liam Healy. It is +;;; implemented to support testing in GSLL. The interface is expanded, +;;; but backwards compatible with previous versions. +;;; (defun numerical-equal (result1 result2 &key (test #'number-equal)) (cond ((and (numberp result1) (numberp result2)) -- 2.11.4.GIT