diff --git a/calculus/monte-carlo.lisp b/calculus/monte-carlo.lisp index 5f53be64366490a6bb2cc216cfb30692522346b7..f649171598396051dccae8d0995cd74de90d97ff 100644 --- a/calculus/monte-carlo.lisp +++ b/calculus/monte-carlo.lisp @@ -1,6 +1,6 @@ ;; Monte Carlo Integration ;; Liam Healy Sat Feb 3 2007 - 17:42 -;; Time-stamp: <2009-01-19 16:30:06EST monte-carlo.lisp> +;; Time-stamp: <2009-01-24 12:58:12EST monte-carlo.lisp> ;; $Id$ (in-package :gsl) @@ -217,9 +217,9 @@ (dimensions sizet) (parameters :pointer)) -(export 'def-mc-function) -(defmacro def-mc-function (name dimensions) - `(def-single-function ,name :double :double monte-function +(export 'make-monte-carlo-function) +(defmacro make-monte-carlo-function (name dimensions) + `(make-single-function ,name :double :double monte-function ,dimensions nil nil)) ;;;;**************************************************************************** @@ -233,28 +233,29 @@ (* (/ (expt pi 3)) (/ (- 1 (* (cos x) (cos y) (cos z)))))) -(def-mc-function monte-carlo-g 3) +(defparameter *monte-carlo-g* + (make-monte-carlo-function monte-carlo-g 3)) (defun random-walk-plain-example (&optional (nsamples 500000)) (let ((ws (make-monte-carlo-plain 3)) (lower #m(0.0d0 0.0d0 0.0d0)) (upper (make-marray 'double-float :initial-contents (list pi pi pi))) (rng (make-random-number-generator *mt19937* 0))) - (monte-carlo-integrate-plain monte-carlo-g lower upper nsamples rng ws))) + (monte-carlo-integrate-plain *monte-carlo-g* lower upper nsamples rng ws))) (defun random-walk-miser-example (&optional (nsamples 500000)) (let ((ws (make-monte-carlo-miser 3)) (lower #m(0.0d0 0.0d0 0.0d0)) (upper (make-marray 'double-float :initial-contents (list pi pi pi))) (rng (make-random-number-generator *mt19937* 0))) - (monte-carlo-integrate-miser monte-carlo-g lower upper nsamples rng ws))) + (monte-carlo-integrate-miser *monte-carlo-g* lower upper nsamples rng ws))) (defun random-walk-vegas-example (&optional (nsamples 500000)) (let ((ws (make-monte-carlo-vegas 3)) (lower #m(0.0d0 0.0d0 0.0d0)) (upper (make-marray 'double-float :initial-contents (list pi pi pi))) (rng (make-random-number-generator *mt19937* 0))) - (monte-carlo-integrate-vegas monte-carlo-g lower upper nsamples rng ws))) + (monte-carlo-integrate-vegas *monte-carlo-g* lower upper nsamples rng ws))) (save-test monte-carlo (random-walk-plain-example) diff --git a/calculus/numerical-differentiation.lisp b/calculus/numerical-differentiation.lisp index 9d36533edeaf2621d7b76de14f0c2dc43deb5d67..54822fe6d23bc0310fbf11657446b637b42a217d 100644 --- a/calculus/numerical-differentiation.lisp +++ b/calculus/numerical-differentiation.lisp @@ -1,6 +1,6 @@ ;; Numerical differentiation. ;; Liam Healy Mon Nov 12 2007 - 22:07 -;; Time-stamp: <2008-11-15 22:31:32EST numerical-differentiation.lisp> +;; Time-stamp: <2009-01-24 14:57:26EST numerical-differentiation.lisp> ;; $Id$ (in-package :gsl) @@ -70,56 +70,35 @@ ;;; Examples from gsl-1.11/deriv/test.c -(defun-single deriv-f1 (x) (exp x)) +(defun deriv-f1 (x) (exp x)) (defun deriv-f1-d (x) (exp x)) -(defun-single deriv-f2 (x) (if (not (minusp x)) (expt x 3/2) 0.0d0)) +(defun deriv-f2 (x) (if (not (minusp x)) (expt x 3/2) 0.0d0)) (defun deriv-f2-d (x) (if (not (minusp x)) (* 3/2 (sqrt x)) 0.0d0)) -(defun-single deriv-f3 (x) (if (not (zerop x)) (sin (/ x)) 0.0d0)) +(defun deriv-f3 (x) (if (not (zerop x)) (sin (/ x)) 0.0d0)) (defun deriv-f3-d (x) (if (not (zerop x)) (/ (- (cos (/ x))) (expt x 2)) 0.0d0)) -(defun-single deriv-f4 (x) (exp (- (expt x 2)))) +(defun deriv-f4 (x) (exp (- (expt x 2)))) (defun deriv-f4-d (x) (* -2 x (exp (- (expt x 2))))) -(defun-single deriv-f5 (x) (expt x 2)) +(defun deriv-f5 (x) (expt x 2)) (defun deriv-f5-d (x) (* 2 x)) -(defun-single deriv-f6 (x) (/ x)) +(defun deriv-f6 (x) (/ x)) (defun deriv-f6-d (x) (- (expt x -2))) -(central-derivative deriv-f1 1.0d0 1.0d-4) -(forward-derivative deriv-f1 1.0d0 1.0d-4) -(backward-derivative deriv-f1 1.0d0 1.0d-4) -(central-derivative deriv-f2 0.1d0 1.0d-4) -(forward-derivative deriv-f2 0.1d0 1.0d-4) -(backward-derivative deriv-f2 0.1d0 1.0d-4) -(central-derivative deriv-f3 0.45d0 1.0d-4) -(forward-derivative deriv-f3 0.45d0 1.0d-4) -(backward-derivative deriv-f3 0.45d0 1.0d-4) -(central-derivative deriv-f4 0.5d0 1.0d-4) -(forward-derivative deriv-f4 0.5d0 1.0d-4) -(backward-derivative deriv-f4 0.5d0 1.0d-4) -(central-derivative deriv-f5 0.0d0 1.0d-4) -(forward-derivative deriv-f5 0.0d0 1.0d-4) -(backward-derivative deriv-f5 0.0d0 1.0d-4) -(central-derivative deriv-f6 10.0d0 1.0d-4) -(forward-derivative deriv-f6 10.0d0 1.0d-4) -(backward-derivative deriv-f6 10.0d0 1.0d-4) - (save-test numerical-differentiation - (central-derivative deriv-f1 1.0d0 1.0d-4) - (forward-derivative deriv-f1 1.0d0 1.0d-4) - (backward-derivative deriv-f1 1.0d0 1.0d-4) - (central-derivative deriv-f2 0.1d0 1.0d-4) - (forward-derivative deriv-f2 0.1d0 1.0d-4) - (backward-derivative deriv-f2 0.1d0 1.0d-4) - (central-derivative deriv-f3 0.45d0 1.0d-4) - (forward-derivative deriv-f3 0.45d0 1.0d-4) - (backward-derivative deriv-f3 0.45d0 1.0d-4) - (central-derivative deriv-f4 0.5d0 1.0d-4) - (forward-derivative deriv-f4 0.5d0 1.0d-4) - (backward-derivative deriv-f4 0.5d0 1.0d-4) - (central-derivative deriv-f5 0.0d0 1.0d-4) - (forward-derivative deriv-f5 0.0d0 1.0d-4) - (backward-derivative deriv-f5 0.0d0 1.0d-4) - (central-derivative deriv-f6 10.0d0 1.0d-4) - (forward-derivative deriv-f6 10.0d0 1.0d-4) - (backward-derivative deriv-f6 10.0d0 1.0d-4)) - - + (central-derivative (make-single-function deriv-f1) 1.0d0 1.0d-4) + (forward-derivative (make-single-function deriv-f1) 1.0d0 1.0d-4) + (backward-derivative (make-single-function deriv-f1) 1.0d0 1.0d-4) + (central-derivative (make-single-function deriv-f2) 0.1d0 1.0d-4) + (forward-derivative (make-single-function deriv-f2) 0.1d0 1.0d-4) + (backward-derivative (make-single-function deriv-f2) 0.1d0 1.0d-4) + (central-derivative (make-single-function deriv-f3) 0.45d0 1.0d-4) + (forward-derivative (make-single-function deriv-f3) 0.45d0 1.0d-4) + (backward-derivative (make-single-function deriv-f3) 0.45d0 1.0d-4) + (central-derivative (make-single-function deriv-f4) 0.5d0 1.0d-4) + (forward-derivative (make-single-function deriv-f4) 0.5d0 1.0d-4) + (backward-derivative (make-single-function deriv-f4) 0.5d0 1.0d-4) + (central-derivative (make-single-function deriv-f5) 0.0d0 1.0d-4) + (forward-derivative (make-single-function deriv-f5) 0.0d0 1.0d-4) + (backward-derivative (make-single-function deriv-f5) 0.0d0 1.0d-4) + (central-derivative (make-single-function deriv-f6) 10.0d0 1.0d-4) + (forward-derivative (make-single-function deriv-f6) 10.0d0 1.0d-4) + (backward-derivative(make-single-function deriv-f6) 10.0d0 1.0d-4)) diff --git a/calculus/numerical-integration.lisp b/calculus/numerical-integration.lisp index cbe6e737f88fe589c7127956014545257fc14a06..d98883852d5eec2b63369f19eb6366d452b5565e 100644 --- a/calculus/numerical-integration.lisp +++ b/calculus/numerical-integration.lisp @@ -1,6 +1,6 @@ ;; Numerical integration ;; Liam Healy, Wed Jul 5 2006 - 23:14 -;; Time-stamp: <2008-12-26 18:54:27EST numerical-integration.lisp> +;; Time-stamp: <2009-01-24 14:48:39EST numerical-integration.lisp> ;; $Id$ ;;; To do: QAWS, QAWO, QAWF, more tests @@ -206,18 +206,12 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(defun-single one-sine (x) (sin x)) - -#| -;;; Parameters may be defined through the lexical environment: -(let ((mult 2.0d0)) - (defun-single two-sine (x) (sin (* mult x)))) -|# +(defun one-sine (x) (sin x)) +(defparameter *one-sine* (make-single-function one-sine)) (save-test numerical-integration - (integration-qng one-sine 0.0d0 pi) + (integration-qng *one-sine* 0.0d0 pi) (let ((ws (make-integration-workspace 20))) - (integration-QAG one-sine 0.0d0 pi :gauss15 20 ws)) + (integration-QAG *one-sine* 0.0d0 pi :gauss15 20 ws)) (let ((ws (make-integration-workspace 20))) - (integration-QAG one-sine 0.0d0 pi :gauss15 50 ws))) - + (integration-QAG *one-sine* 0.0d0 pi :gauss15 50 ws))) diff --git a/chebyshev.lisp b/chebyshev.lisp index 2e5123c04259714d48c0cbcabbe398f921395038..8fde442b86740fbfaf3890a55b83b267e3e00930 100644 --- a/chebyshev.lisp +++ b/chebyshev.lisp @@ -1,6 +1,6 @@ ;; Chebyshev Approximations ;; Liam Healy Sat Nov 17 2007 - 20:36 -;; Time-stamp: <2008-12-26 18:21:11EST chebyshev.lisp> +;; Time-stamp: <2009-01-24 12:56:27EST chebyshev.lisp> ;; $Id$ (in-package :gsl) @@ -75,11 +75,13 @@ ;;; From Chap. 28.5, except I have set steps = 100 instead of 10000 ;;; to keep things sane. -(defun-single chebyshev-step (x) (if (< x 0.5d0) 0.25d0 0.75d0)) +(defun chebyshev-step (x) (if (< x 0.5d0) 0.25d0 0.75d0)) (defun chebyshev-table-example () (let ((steps 100)) - (let ((cheb (make-chebyshev 40 chebyshev-step 0.0d0 1.0d0))) + (let ((cheb + (make-chebyshev + 40 (make-single-function chebyshev-step) 0.0d0 1.0d0))) (dotimes (i steps) (let ((x (coerce (/ i steps) 'double-float))) (format t "~&~a ~a ~a ~a" @@ -90,9 +92,10 @@ (defun chebyshev-point-example (x) (check-type x double-float) - (let ((cheb (make-chebyshev 40 chebyshev-step 0.0d0 1.0d0)) - (deriv (make-chebyshev 40)) - (integ (make-chebyshev 40))) + (let ((cheb (make-chebyshev + 40 (make-single-function chebyshev-step) 0.0d0 1.0d0)) + (deriv (make-chebyshev 40)) + (integ (make-chebyshev 40))) (derivative-chebyshev deriv cheb) (integral-chebyshev integ cheb) (list diff --git a/documentation/index.html b/documentation/index.html index 324e8740b768d29389b450939e9c42d3a455fac5..97b536fb1f6a93d495bfd5ca837e0d3a6fc0c6e4 100644 --- a/documentation/index.html +++ b/documentation/index.html @@ -112,6 +112,7 @@ combination for which the following are supported:</p> version 0.10.0 or newer; callbacks and <code>foreign-funcall</code> must be supported </li> <li><a href="http://www.cliki.net/trivial-garbage">trivial-garbage</a> +<li><a href="http://common-lisp.net/project/cl-utilities/">cl-utilities</a> </li> <li><a href="http://www.cliki.net/asdf">ASDF</a></li></ul> @@ -150,10 +151,11 @@ Then in Lisp, load the system: <ul> <li><code>gsll get_git git://repo.or.cz/gsll.git</code></li> <li><code>trivial-garbage get_darcs http://common-lisp.net/~loliveira/darcs/trivial-garbage</code></li> + <li><code>cl-utilities get_cvs_clnet</code></li> </ul> <p>and add <ul> - <li><code>gsll cffi trivial-garbage</code></li> + <li><code>gsll cffi trivial-garbage cl-utilities</code></li> </ul> <p> to <code>dependencies</code> and execute @@ -163,7 +165,7 @@ from within the clbuild directory: </ul> <h3>With Debian or Ubuntu</h3> <ul> - <li><code>sudo aptitude install libgsl0-dev cl-cffi</code></li> + <li><code>sudo aptitude install libgsl0-dev cl-cffi cl-utilities</code></li> <li><code>git clone git://repo.or.cz/gsll.git</code></li> <li><code>darcs get http://common-lisp.net/~loliveira/darcs/trivial-garbage</code></li> <li><code>clc-register-user-package trivial-garbage/trivial-garbage.asd</code></li> @@ -358,7 +360,7 @@ and arrays used internally or for function return. <!-- Created: Feb 25 2005 --> <!-- hhmts start --> <small> -Time-stamp: <2009-01-20 22:50:29EST index.html> +Time-stamp: <2009-01-24 18:40:10EST index.html> </small> <!-- hhmts end --> </div> diff --git a/gsll.asd b/gsll.asd index 6e3f5a7939eb1a1e62dd15cb8a8201f75072a0ba..975c2a05b2bfa03bcda2ed9caccf2ba02db4a499 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2009-01-16 11:13:17EST gsll.asd> +;; Time-stamp: <2009-01-24 16:56:13EST gsll.asd> ;; $Id$ (asdf:defsystem "gsll" @@ -9,7 +9,7 @@ :version "0" :author "Liam M. Healy" :licence "LLGPL v3, FDL" - :depends-on (cffi trivial-garbage) + :depends-on (cffi trivial-garbage cl-utilities) :components ((:module init :components diff --git a/init/callback.lisp b/init/callback.lisp index b382d0c7f7a7a2a7d0b0bf829a83c6a62e534e4f..65af8a071047bbf333352ee171eff54db9d12a50 100644 --- a/init/callback.lisp +++ b/init/callback.lisp @@ -1,22 +1,21 @@ ;; Foreign callback functions. ;; Liam Healy -;; Time-stamp: <2009-01-22 22:36:00EST callback.lisp> +;; Time-stamp: <2009-01-24 18:17:53EST callback.lisp> ;; $Id$ (in-package :gsl) ;;; Callback functions are functions which are passed as data; to Lisp ;;; that means they are just functions, but C makes a distinction. -;;; They are needed by several GSL tasks. -;;; Functions that take one double-float and return one double-float -;;; and are defined using the gsl_function structure (see gsl_math.h) -;;; are called scalar functions. They are used in -;;; numerical-integration, numerical-differentiation, chebyshev and -;;; definitions to aid in creating and using them are provided here. -;;; The idea behind the definitions is that the boundary between the CL -;;; and C functions is a narrow as possible; #'defun-single is -;;; macro that allows one to define a function in Lisp and make -;;; use it in these GSL tasks. +;;; They are needed by several GSL tasks. Functions that take one +;;; double-float and return one double-float and are defined using the +;;; gsl_function structure (see gsl_math.h) are called scalar +;;; functions. They are used in numerical-integration, +;;; numerical-differentiation, chebyshev and definitions to aid in +;;; creating and using them are provided here. The idea behind the +;;; definitions is that they absorb us much of the definition overhead +;;; as possible so that the user just defines a CL function and calls +;;; a macro to generate something to pass to the GSL functions. ;;; Other GSL tasks make use of callback functions with different ;;; characteristics. Since they are specific to each of the tasks, @@ -33,8 +32,7 @@ ;;; right specification. (export - '(def-single-function undef-cbstruct defun-single - with-c-double with-c-doubles)) + '(make-single-function undef-cbstruct with-c-double with-c-doubles)) ;;;;**************************************************************************** ;;;; Setting slots @@ -161,7 +159,7 @@ (defmacro defmcallback (name &optional (return-type :double) (argument-types :double) - additional-argument-types marray) + additional-argument-types marray (function-name name)) "Define a callback function used by GSL; the GSL function will call it with an additional `parameters' argument that is ignored. the argument-types is a single type or list of types of the argument(s) @@ -185,7 +183,7 @@ ;; CL specials to do the same job. (declare (ignore params)) ,(callback-set-mvb - `(,name + `(,function-name ,@(append (embedded-clfunc-args atl cbargs marray) (embedded-clfunc-args aatl cbaddl marray))) @@ -209,34 +207,31 @@ This struct is bound to a CL special with the specified name. This macro can be used whenever a callback is defined and placed in a struct that has no other functions defined." - (let ((name - ;; Bind a CL special under this name to the C structure. - (if (listp functions) (first functions) functions)) + (let ((name (make-symbol "CBSTRUCT")) (fnlist ;; Make a list of (function slot-name ...) for each function. (if (listp functions) functions (list `,functions 'function)))) - `(progn - ;; Create the C structure and bind CL variable to it. - (defparameter ,name (cffi:foreign-alloc ',structure)) - ;; Set all the function slots. - ,@(loop for (fn slot-name) on fnlist by #'cddr collect + `(let ((,name (cffi:foreign-alloc ',structure))) + ;; Create the C structure and bind CL variable to it. + ;; Set all the function slots. + ,@(loop for (fn slot-name) on fnlist by #'cddr collect `(set-slot-function ,name ',structure ',slot-name ',fn)) - ;; Set the parameters. - (set-parameters ,name ',structure) - ;; Set any additional slots. - ,@(loop for slot in additional-slots - collect - `(set-structure-slot - ,name ',structure ',(first slot) ,(second slot)))))) + ;; Set the parameters. + (set-parameters ,name ',structure) + ;; Set any additional slots. + ,@(loop for slot in additional-slots + collect + `(set-structure-slot + ,name ',structure ',(first slot) ,(second slot))) + ,name))) -(defun undef-cbstruct (name) +(defun undef-cbstruct (object) "Free foreign callback function. It is not necessary to do this; think of the memory taken by an unused foreign function as much less than that used by an unused defun." - (cffi:foreign-free (symbol-value name)) - (makunbound name)) + (cffi:foreign-free object)) -(defmacro def-single-function +(defmacro make-single-function (name &optional (return-type :double) (argument-type :double) (structure 'gsl-function) @@ -247,23 +242,17 @@ This struct is bound to a CL special with the specified name. This macro can be used whenever a callback is defined and placed in a struct that has no other functions defined." - `(progn - (defmcallback ,name ,return-type - ,(if dimensions `((,argument-type ,dimensions)) argument-type) - ,(if dimensions-return `((:set ,argument-type ,dimensions-return))) - ,marray) - ,@(when - structure - `((defcbstruct ,name ,structure - ,(if dimensions `((dimensions ,dimensions)))))))) - -;;; Combine a defun and def-single-function in one: -(defmacro defun-single (name arglist &body body) - "Define a function of a scalar double-float argument returning - a double-float in CL and C." - `(progn - (defun ,name ,arglist ,@body) - (def-single-function ,name))) + ;; I don't think structure=nil is ever used, but it is permissible + (with-unique-names (cbsymb) + `(progn + (defmcallback ,cbsymb ,return-type + ,(if dimensions `((,argument-type ,dimensions)) argument-type) + ,(if dimensions-return `((:set ,argument-type ,dimensions-return))) + ,marray ,name) + ,@(when + structure + `((defcbstruct ,cbsymb ,structure + ,(if dimensions `((dimensions ,dimensions))))))))) ;;;;**************************************************************************** ;;;; Vector of doubles diff --git a/init/init.lisp b/init/init.lisp index 8076a1c3e2757f65a8e088382ff665982cd0abd8..6a59273a172f0be48654203f440ec7dd845133e4 100644 --- a/init/init.lisp +++ b/init/init.lisp @@ -1,6 +1,6 @@ ;; Load GSL ;; Liam Healy Sat Mar 4 2006 - 18:53 -;; Time-stamp: <2009-01-16 11:06:20EST init.lisp> +;; Time-stamp: <2009-01-24 18:07:19EST init.lisp> ;; $Id$ (defpackage gsll @@ -38,3 +38,16 @@ #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (pushnew :native *features*)) + +;;; CFFI currently doesn't allow uninterned callback names for CCL; +;;; patch here. + +#-openmcl (import 'cl-utilities:with-unique-names :gsll) + +#+openmcl +(defmacro gsll::with-unique-names ((&rest bindings) &body body) + `(cl-utilities:with-unique-names + (,@bindings) + (let ,(mapcar (lambda (symb) `(,symb (intern (symbol-name ,symb)))) + bindings) + ,@body))) diff --git a/ordinary-differential-equations/ode-example.lisp b/ordinary-differential-equations/ode-example.lisp index 95a354b747f80f06d04fca308ad388e9e6b31bfc..a4fa2871c9f36e6f27905b55b399101b081c0204 100644 --- a/ordinary-differential-equations/ode-example.lisp +++ b/ordinary-differential-equations/ode-example.lisp @@ -1,6 +1,6 @@ ;; Example ODE ;; Liam Healy Sat Sep 29 2007 - 17:49 -;; Time-stamp: <2009-01-18 18:29:53EST ode-example.lisp> +;; Time-stamp: <2009-01-24 14:34:20EST ode-example.lisp> ;; $Id$ ;;; van der Pol as given in Section 25.5 of the GSL manual. To @@ -24,8 +24,6 @@ (- (* -2 mu y0 y1) 1.0d0) (* -1 mu (- (* y0 y0) 1.0d0)))) -(def-ode-functions vanderpol vanderpol-jacobian 2) - (defparameter *max-iter* 2000) (defun integrate-vanderpol (max-time &optional (step-size 1.0d-6) (print-steps t)) @@ -38,7 +36,8 @@ (loop (when (or (>= (dcref time) max-time) (> iter *max-iter*)) (return (values (dcref time) dep0 dep1))) (apply-evolution - evolve control stepper vanderpol + evolve control stepper + (make-ode-functions vanderpol vanderpol-jacobian 2) time max-time step-size dependent) (incf iter) (when print-steps diff --git a/ordinary-differential-equations/ode-system.lisp b/ordinary-differential-equations/ode-system.lisp index 4bb39fe3677a032d6d48306e55bd69b05e55e2e6..ffd33de4538a89796fa1def8c87cb2a09968ef99 100644 --- a/ordinary-differential-equations/ode-system.lisp +++ b/ordinary-differential-equations/ode-system.lisp @@ -1,6 +1,6 @@ ;; ODE system setup ;; Liam Healy, Sun Apr 15 2007 - 14:19 -;; Time-stamp: <2009-01-20 22:47:16EST ode-system.lisp> +;; Time-stamp: <2009-01-24 18:23:33EST ode-system.lisp> ;; $Id$ (in-package :gsl) @@ -13,9 +13,9 @@ (dimension sizet) (parameters :pointer)) -(export '(def-ode-functions with-ode-integration)) +(export '(make-ode-functions with-ode-integration)) -(defmacro def-ode-functions (name jacobian dimension) +(defmacro make-ode-functions (name jacobian dimension) "Setup functions for ODE integrators. The variable name is used as the name of the The CL functions name and jacobian should be defined previously with defuns. @@ -28,17 +28,18 @@ of the dependent variables y, and dimension values corresponding to the derivatives of f with respect to t." ;; set return values - ;; Possible future improvements: take/set arrays easily, allow lambdas instead of named functions. - `(progn - (defmcallback - ,name :success-failure - (:double (:double ,dimension) (:set :double ,dimension))) - (defmcallback - ,jacobian :success-failure - (:double (:double ,dimension) (:set :double ,(expt dimension 2)) - (:set :double ,dimension))) - (defcbstruct (,name function ,jacobian jacobian) ode-system - ((dimension ,dimension))))) + ;; Possible future improvements: take/set arrays easily, allow lambdas instead of named functions. + (with-unique-names (solverfn solverdf) + `(progn + (defmcallback + ,solverfn :success-failure + (:double (:double ,dimension) (:set :double ,dimension)) nil nil ,name) + (defmcallback + ,solverdf :success-failure + (:double (:double ,dimension) (:set :double ,(expt dimension 2)) + (:set :double ,dimension)) nil nil ,jacobian) + (defcbstruct (,solverfn function ,solverdf jacobian) ode-system + ((dimension ,dimension)))))) (defmacro with-ode-integration ((time step-size dependent dimensions &optional (stepper '*step-rk8pd*) diff --git a/solve-minimize-fit/generic.lisp b/solve-minimize-fit/generic.lisp index 8c33c5a757b696805c08632df28f1b0a1fb3b7c7..6ba91b912cefda4159789cf5f4ab7e7c439a3c7c 100644 --- a/solve-minimize-fit/generic.lisp +++ b/solve-minimize-fit/generic.lisp @@ -1,6 +1,6 @@ ;; Generic functions for optimization ;; Liam Healy 2009-01-03 12:59:07EST generic.lisp -;; Time-stamp: <2009-01-24 09:11:55EST generic.lisp> +;; Time-stamp: <2009-01-24 17:15:48EST generic.lisp> ;; $Id: $ (in-package :gsl) @@ -35,10 +35,10 @@ (dimensions sizet) (parameters :pointer)) -(export 'def-mfunction) -(defmacro def-mfunction (name dimensions) +(export 'make-mfunction) +(defmacro make-mfunction (name dimensions) "Define a function for multivariate root solving." - `(def-single-function ,name :success-failure :double gsl-mfunction + `(make-single-function ,name :success-failure :double gsl-mfunction ,dimensions)) (cffi:defcstruct gsl-mfunction-fdf @@ -51,3 +51,52 @@ (dimensions sizet) (parameters :pointer)) +;;;;**************************************************************************** +;;;; Function definition +;;;;**************************************************************************** + +;;; Solvers that require the function and its derivative use the +;;; following structure. +(cffi:defcstruct gsl-function-fdf + ;; See /usr/include/gsl/gsl_math.h + "The definition of a function and its derivative for root finding in GSL." + (function :pointer) + (df :pointer) + (fdf :pointer) + (parameters :pointer)) + +(export 'make-solver-functions) + +(defmacro make-solver-functions (function df fdf &optional dimensions array) + "Setup functions for solvers. + The CL functions name and derivative should be defined previously + with defuns. If dimensions is non-nil (positive fixnum), set multiroot solver + functions. If dimensions is a number, the functions should expect + dimensions scalar (double-float) arguments and return " + (let ((struct (if dimensions 'gsl-mfunction-fdf 'gsl-function-fdf)) + (argtype (if dimensions (if array :pointer `((:double ,dimensions))) :double)) + (rettype (if dimensions :success-failure :double)) + (vecrettype (if array '(:pointer) `((:set :double ,dimensions)))) + (matrettype + (if array '(:pointer) `((:set :double ,dimensions ,dimensions))))) + (with-unique-names (solverfn solverdf solverfdf) + `(progn + (defmcallback + ,solverfn ,rettype ,argtype ,(when dimensions vecrettype) ,dimensions + ,function) + (defmcallback + ,solverdf ,rettype ,argtype + ,(when dimensions matrettype) + ,dimensions ,df) + (defmcallback + ,solverfdf + ,(if dimensions :success-failure :void) + ,argtype + ,(if dimensions + (append vecrettype matrettype) + '((:set :double 1) (:set :double 1))) + ,dimensions ,fdf) + (defcbstruct (,solverfn function ,solverdf df ,solverfdf fdf) + ,struct + ,(when dimensions `((dimensions ,dimensions)))))))) + diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp index 131098be4d607386476f1d6fff2e0caca31c2b6a..c74d3c3e3ded49acfe03dd6621c3cb221a47cbb0 100644 --- a/solve-minimize-fit/minimization-multi.lisp +++ b/solve-minimize-fit/minimization-multi.lisp @@ -1,6 +1,6 @@ ;; Multivariate minimization. ;; Liam Healy <Tue Jan 8 2008 - 21:28> -;; Time-stamp: <2009-01-22 21:35:26EST minimization-multi.lisp> +;; Time-stamp: <2009-01-24 16:58:00EST minimization-multi.lisp> ;; $Id$ (in-package :gsl) @@ -27,25 +27,28 @@ ;;; pointer is a pointer, even though the C definition the functions ;;; they point to have different signatures. -(export 'def-minimization-functions) -(defmacro def-minimization-functions (function dimensions &optional df fdf array) +(export 'make-minimization-functions) +(defmacro make-minimization-functions (function dimensions &optional df fdf array) "Setup functions for multivariate minimization. The CL functions name and derivative should be defined previously with defuns." (let ((vdec (if array :pointer `((:double ,dimensions)))) (svdec (if array :pointer `(:set :double ,dimensions)))) - `(progn - (defmcallback ,function :double ,vdec nil t) - ,@(when df - `((defmcallback ,df :void ,vdec (,svdec) t) - (defmcallback ,fdf :void ,vdec ((:set :double -1) ,svdec) t))) - ,(if df - `(defcbstruct (,function function ,df df ,fdf fdf) - gsl-mfunction-fdf - ((dimensions ,dimensions))) - `(defcbstruct (,function function) - gsl-mfunction - ((dimensions ,dimensions))))))) + (with-unique-names (solverfn solverdf solverfdf) + `(progn + (defmcallback ,solverfn :double ,vdec nil t ,function) + ,@(when + df + `((defmcallback ,solverdf :void ,vdec (,svdec) t ,df) + (defmcallback + ,solverfdf :void ,vdec ((:set :double -1) ,svdec) t ,fdf))) + ,(if df + `(defcbstruct (,solverfn function ,solverdf df ,solverfdf fdf) + gsl-mfunction-fdf + ((dimensions ,dimensions))) + `(defcbstruct (,solverfn function) + gsl-mfunction + ((dimensions ,dimensions)))))))) ;;;;**************************************************************************** ;;;; Initialization @@ -285,11 +288,11 @@ (defparameter *parabaloid-center* #(1.0d0 2.0d0)) -(defun parabaloid (gsl-vector-pointer) +(defun parabaloid-vector (gsl-vector) "A parabaloid function of two arguments, given in GSL manual Sec. 35.4. This version takes a vector-double-float argument." - (let ((x (maref gsl-vector-pointer 0)) - (y (maref gsl-vector-pointer 1)) + (let ((x (maref gsl-vector 0)) + (y (maref gsl-vector 1)) (dp0 (aref *parabaloid-center* 0)) (dp1 (aref *parabaloid-center* 1))) (+ (* 10 (expt (- x dp0) 2)) @@ -309,19 +312,19 @@ (defun parabaloid-and-derivative (arguments-gv-pointer derivative-gv-pointer) (prog1 - (parabaloid arguments-gv-pointer) + (parabaloid-vector arguments-gv-pointer) (parabaloid-derivative arguments-gv-pointer derivative-gv-pointer))) -(def-minimization-functions - parabaloid 2 parabaloid-derivative parabaloid-and-derivative t) - (defun multimin-example-derivative (&optional (method *conjugate-fletcher-reeves*) (print-steps t)) (let* ((initial #m(5.0d0 7.0d0)) (minimizer (make-multi-dimensional-minimizer-fdf - method 2 parabaloid + method 2 + (make-minimization-functions + parabaloid-vector 2 + parabaloid-derivative parabaloid-and-derivative t) initial 0.01d0 1.0d-4))) (loop with status = T for iter from 0 below 100 @@ -343,8 +346,9 @@ (values (maref x 0) (maref x 1) (function-value minimizer))))))) ;;; Example without derivatives, same function but now defined using +;;; scalars. -(defun parabaloid-f (x y) +(defun parabaloid-scalar (x y) "A parabaloid function of two arguments, given in GSL manual Sec. 35.4. This version takes scalar arguments." (let ((dp0 (aref *parabaloid-center* 0)) @@ -353,15 +357,15 @@ (* 20 (expt (- y dp1) 2)) 30))) -(def-minimization-functions parabaloid-f 2) - (defun multimin-example-no-derivative (&optional (method *simplex-nelder-mead*) (print-steps t)) (let ((step-size (make-marray 'double-float :dimensions 2))) (set-all step-size 1.0d0) (let ((minimizer (make-multi-dimensional-minimizer-f - method 2 parabaloid-f #m(5.0d0 7.0d0) step-size))) + method 2 + (make-minimization-functions parabaloid-scalar 2) + #m(5.0d0 7.0d0) step-size))) (loop with status = T and size for iter from 0 below 100 while status diff --git a/solve-minimize-fit/minimization-one.lisp b/solve-minimize-fit/minimization-one.lisp index 924b1d4a31e935578ec1ef77ccfe1182cf018d9e..978c3a84da6ceb87b62f5f1bad84ec4d71534f62 100644 --- a/solve-minimize-fit/minimization-one.lisp +++ b/solve-minimize-fit/minimization-one.lisp @@ -1,6 +1,6 @@ ;; Univariate minimization ;; Liam Healy Tue Jan 8 2008 - 21:02 -;; Time-stamp: <2009-01-22 18:59:23EST minimization-one.lisp> +;; Time-stamp: <2009-01-24 14:46:49EST minimization-one.lisp> ;; $Id$ (in-package :gsl) @@ -175,7 +175,7 @@ ;;; This is the example given in Sec. 33.8. The results are different ;;; than given there. -(defun-single minimization-one-fn (x) +(defun minimization-one-fn (x) (1+ (cos x))) (defun minimization-one-example @@ -184,7 +184,9 @@ (let ((max-iter 100) (minimizer (make-one-dimensional-minimizer - minimizer-type minimization-one-fn 2.0d0 0.0d0 6.0d0))) + minimizer-type + (make-single-function minimization-one-fn) + 2.0d0 0.0d0 6.0d0))) (when print-steps (format t diff --git a/solve-minimize-fit/nonlinear-least-squares.lisp b/solve-minimize-fit/nonlinear-least-squares.lisp index a952572f572acbe34b56736eb3b8365ff9fc3900..d6fc385caf9d4b7daf28016464509c401f62b6bf 100644 --- a/solve-minimize-fit/nonlinear-least-squares.lisp +++ b/solve-minimize-fit/nonlinear-least-squares.lisp @@ -1,6 +1,6 @@ ;; Nonlinear least squares fitting. ;; Liam Healy, 2008-02-09 12:59:16EST nonlinear-least-squares.lisp -;; Time-stamp: <2009-01-24 11:46:27EST nonlinear-least-squares.lisp> +;; Time-stamp: <2009-01-24 16:58:11EST nonlinear-least-squares.lisp> ;; $Id$ (in-package :gsl) @@ -85,29 +85,30 @@ (number-of-parameters sizet) (parameters :pointer)) -(export 'def-fitting-functions) -(defmacro def-fitting-functions - (function number-of-parameters &optional df fdf (number-of-observations 0)) - "Setup functions for nonlinear least squares fitting. +(export 'make-fitting-functions) +(defmacro make-fitting-functions + (function number-of-parameters number-of-observations &optional df fdf) + "Create the GSL struct for nonlinear least squares fitting. The CL functions name and derivative should be defined previously with defuns." - ;; The number of observations doesn't have anything to do with the - ;; fitting functions, only with the data. Therefore it defaults to - ;; 0 and should be specified separately with the data. - `(progn - (defmcallback ,function :success-failure :pointer :pointer) - ,@(when df - `((defmcallback ,df :success-failure :pointer :pointer) - (defmcallback ,fdf :success-failure :pointer (:pointer :pointer)))) - ,(if df - `(defcbstruct (,function function ,df df ,fdf fdf) - gsl-fdffit-function - ((number-of-observations ,number-of-observations) - (number-of-parameters ,number-of-parameters))) - `(defcbstruct (,function function) - gsl-ffit-function - ((number-of-observations ,number-of-observations) - (number-of-parameters ,number-of-parameters)))))) + ;; The number of observations defaults to 0 so that the value can be + ;; set separately and should be specified separately with the data. + (let ((numbers `((number-of-observations ,number-of-observations) + (number-of-parameters ,number-of-parameters)))) + (with-unique-names (solverfn solverdf solverfdf) + `(progn + (defmcallback ,solverfn :success-failure :pointer :pointer nil ,function) + ,@(when + df + `((defmcallback ,solverdf :success-failure :pointer :pointer nil ,df) + (defmcallback + ,solverfdf + :success-failure :pointer (:pointer :pointer) nil ,fdf))) + ,(if df + `(defcbstruct (,solverfn function ,solverdf df ,solverfdf fdf) + gsl-fdffit-function ,numbers) + `(defcbstruct (,function function) + gsl-ffit-function ,numbers)))))) (export '(number-of-parameters number-of-observations)) @@ -364,9 +365,6 @@ (exponential-residual x f) (exponential-residual-derivative x jacobian)) -(def-fitting-functions exponential-residual 3 - exponential-residual-derivative exponential-residual-fdf) - (defun norm-f (fit) "Find the norm of the fit function f." (euclidean-norm (function-value fit))) @@ -375,10 +373,14 @@ (&optional (number-of-observations 40) (method *levenberg-marquardt*) (print-steps t)) - (let ((*nlls-example-data* (generate-nlls-data number-of-observations))) - (setf (number-of-observations exponential-residual) number-of-observations) + (let ((*nlls-example-data* (generate-nlls-data number-of-observations)) + (nlls-callback + (make-fitting-functions + exponential-residual 3 number-of-observations + exponential-residual-derivative exponential-residual-fdf))) + (setf (number-of-observations nlls-callback) number-of-observations) (let* ((init #m(1.0d0 0.0d0 0.0d0)) - (number-of-parameters (number-of-parameters exponential-residual)) + (number-of-parameters (number-of-parameters nlls-callback)) (covariance (make-marray 'double-float :dimensions @@ -387,7 +389,7 @@ method number-of-observations number-of-parameters - exponential-residual + nlls-callback init))) (macrolet ((fitx (i) `(maref (solution fit) ,i)) (err (i) `(sqrt (maref covariance ,i ,i)))) diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp index 59efda2cf8532d2ca32b26f2cca7a0cb3370daf3..2d73af2406ab0074345791f887bc74e9ed99798c 100644 --- a/solve-minimize-fit/roots-multi.lisp +++ b/solve-minimize-fit/roots-multi.lisp @@ -1,6 +1,6 @@ ;;; Multivariate roots. ;;; Liam Healy 2008-01-12 12:49:08 -;;; Time-stamp: <2009-01-24 09:12:18EST roots-multi.lisp> +;;; Time-stamp: <2009-01-24 13:09:32EST roots-multi.lisp> ;;; $Id$ (in-package :gsl) @@ -342,8 +342,7 @@ (values (- (* *powell-A* arg0 arg1) 1) (+ (exp (- arg0)) (exp (- arg1)) (- (1+ (/ *powell-A*)))))) - -(def-mfunction powell 2) +;; not used? ;;; This is the example given in Sec. 34.8. @@ -356,14 +355,12 @@ (* *rosenbrock-a* (- 1 arg0)) (* *rosenbrock-b* (- arg1 (expt arg0 2))))) -(def-mfunction rosenbrock 2) - (defun roots-multi-example-no-derivative (&optional (method *hybrid-scaled*) (print-steps t)) "Solving Rosenbrock, the example given in Sec. 34.8 of the GSL manual." (let ((max-iter 1000) (solver (make-multi-dimensional-root-solver-f - method rosenbrock + method (make-mfunction rosenbrock 2) #m(-10.0d0 -5.0d0)))) (loop for iter from 0 with fnval and argval @@ -402,14 +399,6 @@ (rosenbrock-df arg0 arg1) (values v0 v1 j0 j1 j2 j3)))) -;;; Because def-solver-functions and def-single-function bind a symbol -;;; of the same name as the first function, and we want both to run, -;;; we'll make an alias function so we can use both. -(defun rosenbrock-f (argument return) - (rosenbrock argument return)) - -(def-solver-functions rosenbrock-f rosenbrock-df rosenbrock-fdf 2) - (defun roots-multi-example-derivative (&optional (method *gnewton-mfdfsolver*) (print-steps t)) "Solving Rosenbrock with derivatives, the example given in Sec. 34.8 of the GSL manual." @@ -423,7 +412,8 @@ (maref fnval 1))))) (let ((max-iter 1000) (solver (make-multi-dimensional-root-solver-fdf - method rosenbrock-f + method + (make-solver-functions rosenbrock rosenbrock-df rosenbrock-fdf 2) #m(-10.0d0 -5.0d0)))) (loop for iter from 0 with fnval = (function-value solver) diff --git a/solve-minimize-fit/roots-one.lisp b/solve-minimize-fit/roots-one.lisp index 6917db5aa6313260c3a6f02e963aedc7386e15bb..044516c8d45232194215014b55c692a3fd035bef 100644 --- a/solve-minimize-fit/roots-one.lisp +++ b/solve-minimize-fit/roots-one.lisp @@ -1,58 +1,12 @@ ;; One-dimensional root solver. ;; Liam Healy -;; Time-stamp: <2009-01-22 22:15:50EST roots-one.lisp> +;; Time-stamp: <2009-01-24 15:08:14EST roots-one.lisp> ;; $Id$ (in-package :gsl) ;;; /usr/include/gsl/gsl_roots.h -;;;;**************************************************************************** -;;;; Function definition -;;;;**************************************************************************** - -;;; Solvers that require the function and its derivative use the -;;; following structure. -(cffi:defcstruct gsl-function-fdf - ;; See /usr/include/gsl/gsl_math.h - "The definition of a function and its derivative for root finding in GSL." - (function :pointer) - (df :pointer) - (fdf :pointer) - (parameters :pointer)) - -(export 'def-solver-functions) - -(defmacro def-solver-functions (function df fdf &optional dimensions array) - "Setup functions for solvers. - The CL functions name and derivative should be defined previously - with defuns. If dimensions is non-nil (positive fixnum), set multiroot solver - functions. If dimensions is a number, the functions should expect - dimensions scalar (double-float) arguments and return " - (let ((struct (if dimensions 'gsl-mfunction-fdf 'gsl-function-fdf)) - (argtype (if dimensions (if array :pointer `((:double ,dimensions))) :double)) - (rettype (if dimensions :success-failure :double)) - (vecrettype (if array '(:pointer) `((:set :double ,dimensions)))) - (matrettype - (if array '(:pointer) `((:set :double ,dimensions ,dimensions))))) - `(progn - (defmcallback - ,function ,rettype ,argtype ,(when dimensions vecrettype) ,dimensions) - (defmcallback - ,df ,rettype ,argtype - ,(when dimensions matrettype) - ,dimensions) - (defmcallback - ,fdf - ,(if dimensions :success-failure :void) - ,argtype - ,(if dimensions - (append vecrettype matrettype) - '((:set :double 1) (:set :double 1))) - ,dimensions) - (defcbstruct (,function function ,df df ,fdf fdf) ,struct - ,(when dimensions `((dimensions ,dimensions))))))) - ;;;;**************************************************************************** ;;;; Initialization ;;;;**************************************************************************** @@ -328,14 +282,13 @@ (values (+ (* (+ (* a x) b) x) c) (+ (* 2 a x) b)))) -(def-single-function quadratic) - (defun roots-one-example-no-derivative (&optional (method *brent-fsolver*) (print-steps t)) "Solving a quadratic, the example given in Sec. 32.10 of the GSL manual." (let ((max-iter 50) (solver - (make-one-dimensional-root-solver-f method quadratic 0.0d0 5.0d0))) + (make-one-dimensional-root-solver-f + method (make-single-function quadratic) 0.0d0 5.0d0))) (when print-steps (format t "iter ~6t [lower ~24tupper] ~36troot ~44terr ~54terr(est)~&")) (loop for iter from 0 @@ -353,21 +306,16 @@ (- upper lower))) finally (return root)))) -;;; Because def-solver-functions and def-single-function bind a symbol -;;; of the same name as the first function, and we want both to run, -;;; we'll make an alias function so we can use both. -(defun quadratic-df (x) (quadratic x)) - -(def-solver-functions - quadratic-df quadratic-derivative quadratic-and-derivative) - (defun roots-one-example-derivative (&optional (method *newton-fdfsolver*) (print-steps t)) "Solving a quadratic, the example given in Sec. 32.10 of the GSL manual." (let* ((max-iter 100) (initial 5.0d0) (solver (make-one-dimensional-root-solver-fdf - method quadratic-df initial))) + method + (make-solver-functions + quadratic quadratic-derivative quadratic-and-derivative) + initial))) (when print-steps (format t "iter ~6t ~8troot ~22terr ~34terr(est)~&")) (loop for iter from 0 diff --git a/tests/numerical-differentiation.lisp b/tests/numerical-differentiation.lisp index a002579b444580401c7594e27e26d467b3f102af..ac878513ddf6e85df524a115638f5fa9902caa47 100644 --- a/tests/numerical-differentiation.lisp +++ b/tests/numerical-differentiation.lisp @@ -6,73 +6,91 @@ (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.718281828441488d0 4.123659913167868d-10) (MULTIPLE-VALUE-LIST - (CENTRAL-DERIVATIVE DERIV-F1 1.0d0 1.d-4))) + (CENTRAL-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F1) + 1.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.7182817825298398d0 9.540320743340577d-7) (MULTIPLE-VALUE-LIST - (FORWARD-DERIVATIVE DERIV-F1 1.0d0 1.d-4))) + (FORWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F1) + 1.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.7182818293827378d0 9.086969640080628d-7) (MULTIPLE-VALUE-LIST - (BACKWARD-DERIVATIVE DERIV-F1 1.0d0 1.d-4))) + (BACKWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F1) + 1.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 0.474341649024533d0 3.3922603135575853d-11) (MULTIPLE-VALUE-LIST - (CENTRAL-DERIVATIVE DERIV-F2 0.1d0 1.d-4))) + (CENTRAL-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F2) + 0.1d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 0.47434164943235285d0 9.102230432046565d-8) (MULTIPLE-VALUE-LIST - (FORWARD-DERIVATIVE DERIV-F2 0.1d0 1.d-4))) + (FORWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F2) + 0.1d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 0.4743416462049176d0 8.787851752748856d-8) (MULTIPLE-VALUE-LIST - (BACKWARD-DERIVATIVE DERIV-F2 0.1d0 1.d-4))) + (BACKWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F2) + 0.1d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.9941773945923913d0 6.730277498876722d-10) (MULTIPLE-VALUE-LIST - (CENTRAL-DERIVATIVE DERIV-F3 0.45d0 1.d-4))) + (CENTRAL-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F3) + 0.45d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.994177385772526d0 1.6952086150997503d-6) (MULTIPLE-VALUE-LIST - (FORWARD-DERIVATIVE DERIV-F3 0.45d0 1.d-4))) + (FORWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F3) + 0.45d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.9941775182635064d0 1.568063267060477d-6) (MULTIPLE-VALUE-LIST - (BACKWARD-DERIVATIVE DERIV-F3 0.45d0 1.d-4))) + (BACKWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F3) + 0.45d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -0.7788007830653751d0 1.7227267499194736d-10) (MULTIPLE-VALUE-LIST - (CENTRAL-DERIVATIVE DERIV-F4 0.5d0 1.d-4))) + (CENTRAL-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F4) + 0.5d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -0.7788007884386108d0 2.530006603059119d-7) (MULTIPLE-VALUE-LIST - (FORWARD-DERIVATIVE DERIV-F4 0.5d0 1.d-4))) + (FORWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F4) + 0.5d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -0.7788007743421791d0 2.503617930568489d-7) (MULTIPLE-VALUE-LIST - (BACKWARD-DERIVATIVE DERIV-F4 0.5d0 1.d-4))) + (BACKWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F4) + 0.5d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 0.0d0 6.66133814775094d-20) (MULTIPLE-VALUE-LIST - (CENTRAL-DERIVATIVE DERIV-F5 0.0d0 1.d-4))) + (CENTRAL-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F5) + 0.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -2.6337311035821125d-26 1.606762230663824d-11) (MULTIPLE-VALUE-LIST - (FORWARD-DERIVATIVE DERIV-F5 0.0d0 1.d-4))) + (FORWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F5) + 0.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.6337311035821125d-26 1.606762230663824d-11) (MULTIPLE-VALUE-LIST - (BACKWARD-DERIVATIVE DERIV-F5 0.0d0 1.d-4))) + (BACKWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F5) + 0.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -0.009999999999871223d0 2.6645352591887814d-12) (MULTIPLE-VALUE-LIST - (CENTRAL-DERIVATIVE DERIV-F6 10.0d0 1.d-4))) + (CENTRAL-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F6) + 10.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -0.010000000266238856d0 4.9950606958271945d-9) (MULTIPLE-VALUE-LIST - (FORWARD-DERIVATIVE DERIV-F6 10.0d0 1.d-4))) + (FORWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F6) + 10.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST -0.010000000076196142d0 4.641550044799095d-9) (MULTIPLE-VALUE-LIST - (BACKWARD-DERIVATIVE DERIV-F6 10.0d0 1.d-4)))) + (BACKWARD-DERIVATIVE (MAKE-SINGLE-FUNCTION DERIV-F6) + 10.0d0 1.d-4)))) diff --git a/tests/numerical-integration.lisp b/tests/numerical-integration.lisp index a1c1be94b1a911b8d0903af85fbfe6ab74543bbe..c01fe3aa6afaa93e183be1cfa4fc290a0d16fe0a 100644 --- a/tests/numerical-integration.lisp +++ b/tests/numerical-integration.lisp @@ -6,18 +6,18 @@ (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.0d0 2.220446049250313d-14 21) (MULTIPLE-VALUE-LIST - (INTEGRATION-QNG ONE-SINE 0.0d0 PI))) + (INTEGRATION-QNG *ONE-SINE* 0.0d0 PI))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.0d0 2.220446049250313d-14) (MULTIPLE-VALUE-LIST (LET ((WS (MAKE-INTEGRATION-WORKSPACE 20))) - (INTEGRATION-QAG ONE-SINE 0.0d0 PI :GAUSS15 20 + (INTEGRATION-QAG *ONE-SINE* 0.0d0 PI :GAUSS15 20 WS)))) (LISP-UNIT:ASSERT-ERROR 'INVALID-ARGUMENT (LET ((WS (MAKE-INTEGRATION-WORKSPACE 20))) - (INTEGRATION-QAG ONE-SINE + (INTEGRATION-QAG *ONE-SINE* 0.0d0 PI :GAUSS15 50 WS))))