augment.lisp 4.37 KB
Newer Older
Liam Healy's avatar
Liam Healy committed
1
2
;; Additional methods for lisp-unit
;; Liam Healy 2009-04-15 23:23:30EDT augment.lisp
3
;; Time-stamp: <2010-06-01 22:02:57EDT augment.lisp>
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;;
;; Copyright 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
Liam Healy's avatar
Liam Healy committed
20
21
22
23

(in-package :gsl)

(defmethod lisp-unit:numerical-equal
24
25
26
27
28
    ((result1 marray) (result2 marray) &key (test #'lisp-unit:number-equal))
  "Return true if the arrays are numerically equal according to :TEST."
  (when (equal (dimensions result1) (dimensions result2))
    (lisp-unit:numerical-equal (cl-array result1) (cl-array result2)
			       :test test)))
29
30
31
32
33
34
35
36
37

;;; See cdf/test.c
(defconstant +test-tol0+ (* 2 +dbl-epsilon+))
(defconstant +test-tol1+ (* 16 +dbl-epsilon+))
(defconstant +test-tol2+ (* 256 +dbl-epsilon+))
(defconstant +test-tol3+ (* 2048 +dbl-epsilon+))
(defconstant +test-tol4+ (* 16384 +dbl-epsilon+))
(defconstant +test-tol5+ (* 131072 +dbl-epsilon+))
(defconstant +test-tol6+ (* 1048576 +dbl-epsilon+))
38
(defconstant +test-sqrt-tol0+ (* 2 +sqrt-dbl-epsilon+))
39

40
41
42
43
44
45
;;; These are 1.0 if not "RELEASED"
(defconstant +test-sigma+ 1.5d0)
(defconstant +test-factor+ 100.0d0)

(defun sf-frac-diff (x1 x2)
  ;; After test_sf_frac_diff in specfunc/test_sf.c.
46
  (cond ((and (zerop x1) (zerop x2))
47
48
49
50
51
52
53
54
55
	 (coerce 0 (type-of x1)))
	((zerop x1)
	 (abs x2))
	((and (<= x1 most-positive-double-float)
	      (<= x2 most-positive-double-float)
	      (not (zerop (+ x1 x2))))
	 (abs (/ (- x1 x2) (+ x1 x2))))
	(t 1.0d0)))

56
57
(defun sf-check-single (result expected-value tolerance &optional error-estimate)
  "Check the result of a single value as in test_sf_check_result in specfunc/test_sf.c." 
58
59
60
  (or (eql result expected-value) ; catch expected inifinity/nan
      (let ((diff (abs (- result expected-value))))
	(and
61
	 (<= (sf-frac-diff expected-value result) (* +test-factor+ tolerance))
62
63
64
65
66
67
68
	 (if error-estimate
	     (and (not (minusp error-estimate)) ; redundant but signalled as separate error in C
		  (finitep error-estimate)
		  (<= diff (* 2 +test-sigma+ error-estimate)))
	     t)))))

(defun sf-check-results (result-list expected-value tolerance)
69
70
  "Check the results of multiple returns where each value may have an
   error estimate returned as well."
71
72
73
  ;; After test_sf_check_result in specfunc/test_sf.c.
  (when (atom expected-value)
    (setf expected-value (list expected-value)))
74
  (let ((errorsp (= (length result-list) (* 2 (length expected-value)))))
75
76
77
    ;; Error information is returned
    (loop for ind below (length expected-value)
       always
78
       (sf-check-single
79
80
81
	(elt result-list ind)
	(elt expected-value ind)
	tolerance
82
83
	(when errorsp
	  (elt result-list (+ ind (length expected-value))))))))
84

85
86
;; (assert-to-tolerance (tdist-P 0.0d0 1.0d0) 0.5d0 +test-tol6+)
(defmacro assert-to-tolerance (form expected-value tolerance)
87
  ;; Equivalent of TEST_SF.
88
89
90
  `(lisp-unit::assert-true
    (sf-check-results
     (multiple-value-list ,form) ,expected-value ,tolerance)))
91

92
  ;; and TEST_SF becomes assert-to-tolerance.
93
(defmacro assert-sf-scale (form expected-value scale result-tol &optional err-tol)
94
  ;; Equivalent of TEST_SF_E10.
95
96
97
98
99
100
101
102
103
104
105
106
  ;; Some of the tests in test_exp like gsl_sf_exp_mult_e10_e(1.0,
  ;; 1.0, &re) do a check of test_sf_frac_diff, then of the err, then
  ;; the scale (e10), then they (redundantly?) call test_sf_e10.
  ;; Others just call test_sf_e10.  This attempts to cover both cases.
  `(lisp-unit::assert-true
    (multiple-value-bind (val scale err)
	,form
      (and
       (sf-check-single val ,expected-value ,result-tol err)
       (= scale ,scale)
       ,(if err-tol `(<= err ,err-tol) t)))))

107
108
109
110
111
112
113
114
115
(defmacro assert-posinf (form)
  `(lisp-unit::assert-true
    (let ((val ,form))
      (and (infinityp val) (plusp val)))))

(defmacro assert-neginf (form)
  `(lisp-unit::assert-true
    (let ((val ,form))
      (and (infinityp val) (minusp val)))))