diff --git a/calculus/monte-carlo.lisp b/calculus/monte-carlo.lisp index 41f46461e23100af065f1d748c166c4102b44a96..96be3a3d0ece666620ad4b71355d97227112e412 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-02-16 10:16:43EST monte-carlo.lisp> +;; Time-stamp: <2009-03-31 22:07:09EDT monte-carlo.lisp> ;; $Id$ (in-package :gsl) @@ -10,6 +10,15 @@ ;;; /usr/include/gsl/gsl_monte_miser.h ;;; /usr/include/gsl/gsl_monte_vegas.h +;;;;**************************************************************************** +;;;; Callback definition +;;;;**************************************************************************** + +(cffi:defcstruct monte-function + (function :pointer) + (dimensions sizet) + (parameters :pointer)) + ;;;;**************************************************************************** ;;;; PLAIN Monte Carlo ;;;;**************************************************************************** @@ -28,7 +37,8 @@ (x :pointer)) (defmfun monte-carlo-integrate-plain - (function lower-limits upper-limits calls generator state) + (function lower-limits upper-limits calls generator state + &optional (scalars t)) "gsl_monte_plain_integrate" ((callback :pointer) ((c-pointer lower-limits) :pointer) ((c-pointer upper-limits) :pointer) @@ -37,7 +47,10 @@ ((mpointer state) :pointer) (result :double) (abserr :double)) :inputs (lower-limits upper-limits) - :callback-struct monte-function + :callbacks + (callback monte-function (dimensions) + (function :double (:input :double :cvector dim0) :slug)) + :callback-dynamic (((dim0 lower-limits)) (function scalars)) :documentation ; FDL "Uses the plain Monte Carlo algorithm to integrate the function f over the hypercubic region defined by the @@ -104,7 +117,8 @@ `(foreign-slot-value ,workspace 'miser-state ',parameter)) (defmfun monte-carlo-integrate-miser - (function lower-limits upper-limits calls generator state) + (function lower-limits upper-limits calls generator state + &optional (scalars t)) "gsl_monte_miser_integrate" ((callback :pointer) ((c-pointer lower-limits) :pointer) ((c-pointer upper-limits) :pointer) @@ -113,7 +127,10 @@ ((mpointer state) :pointer) (result :double) (abserr :double)) :inputs (lower-limits upper-limits) - :callback-struct monte-function + :callbacks + (callback monte-function (dimensions) + (function :double (:input :double :cvector dim0) :slug)) + :callback-dynamic (((dim0 lower-limits)) (function scalars)) :documentation ; FDL "Uses the miser Monte Carlo algorithm to integrate the function f over the hypercubic region defined by the @@ -190,7 +207,8 @@ `(foreign-slot-value ,workspace 'vegas-state ',parameter)) (defmfun monte-carlo-integrate-vegas - (function lower-limits upper-limits calls generator state) + (function lower-limits upper-limits calls generator state + &optional (scalars t)) "gsl_monte_vegas_integrate" ((callback :pointer) ((c-pointer lower-limits) :pointer) ((c-pointer upper-limits) :pointer) @@ -199,7 +217,10 @@ ((mpointer state) :pointer) (result :double) (abserr :double)) :inputs (lower-limits upper-limits) - :callback-struct monte-function + :callbacks + (callback monte-function (dimensions) + (function :double (:input :double :cvector dim0) :slug)) + :callback-dynamic (((dim0 lower-limits)) (function scalars)) :documentation ; FDL "Uses the vegas Monte Carlo algorithm to integrate the function f over the dim-dimensional hypercubic region @@ -214,22 +235,6 @@ is returned via the state struct component, s->chisq, and must be consistent with 1 for the weighted average to be reliable.") -;;;;**************************************************************************** -;;;; Callback definition -;;;;**************************************************************************** - -(cffi:defcstruct monte-function - (function :pointer) - (dimensions sizet) - (parameters :pointer)) - -(def-make-callbacks monte-carlo (function dimension) - `(defmcallback ,function - :double ((:double ,dimension)) - nil - nil - ,function)) - ;;;;**************************************************************************** ;;;; Examples and unit test ;;;;**************************************************************************** @@ -241,8 +246,6 @@ (* (/ (expt pi 3)) (/ (- 1 (* (cos x) (cos y) (cos z)))))) -(make-callbacks monte-carlo mcrw 3) - (defun random-walk-plain-example (&optional (nsamples 500000)) (let ((ws (make-monte-carlo-plain 3)) (lower #m(0.0d0 0.0d0 0.0d0)) diff --git a/calculus/numerical-differentiation.lisp b/calculus/numerical-differentiation.lisp index b80565da49f227c2ef7bdfb8ecdba0ee5bd5c477..84f66ebaefcdb1706e033c8839a803e26cb55200 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: <2009-02-15 14:49:44EST numerical-differentiation.lisp> +;; Time-stamp: <2009-03-31 22:08:34EDT numerical-differentiation.lisp> ;; $Id$ (in-package :gsl) @@ -14,6 +14,9 @@ "gsl_deriv_central" ((callback :pointer) (x :double) (step :double) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the numerical derivative of the function at the point x using an adaptive central difference algorithm with @@ -34,6 +37,9 @@ "gsl_deriv_forward" ((callback :pointer) (x :double) (step :double) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the numerical derivative of the function at the point x using an adaptive forward difference algorithm with @@ -56,6 +62,9 @@ "gsl_deriv_backward" ((callback :pointer) (x :double) (step :double) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the numerical derivative of the function at the point x using an adaptive backward difference algorithm with a step-size of @@ -70,7 +79,6 @@ ;;; Examples from gsl-1.11/deriv/test.c -(defun deriv-f1 (x) (exp x)) (defun deriv-f1-d (x) (exp x)) (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)) @@ -80,20 +88,12 @@ (defun deriv-f4-d (x) (* -2 x (exp (- (expt x 2))))) (defun deriv-f5 (x) (expt x 2)) (defun deriv-f5-d (x) (* 2 x)) -(defun deriv-f6 (x) (/ x)) (defun deriv-f6-d (x) (- (expt x -2))) -(make-callbacks single-function deriv-f1) -(make-callbacks single-function deriv-f2) -(make-callbacks single-function deriv-f3) -(make-callbacks single-function deriv-f4) -(make-callbacks single-function deriv-f5) -(make-callbacks single-function deriv-f6) - (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 'exp 1.0d0 1.0d-4) + (forward-derivative 'exp 1.0d0 1.0d-4) + (backward-derivative 'exp 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) @@ -106,6 +106,6 @@ (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 '/ 10.0d0 1.0d-4) + (forward-derivative '/ 10.0d0 1.0d-4) + (backward-derivative '/ 10.0d0 1.0d-4)) diff --git a/calculus/numerical-integration.lisp b/calculus/numerical-integration.lisp index 8f63b34758c2c0e4aa1e8f6a4ab2d600a713107f..7740919ead9e48daef9cddf955a8ffc7b474dbf0 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: <2009-02-15 14:43:39EST numerical-integration.lisp> +;; Time-stamp: <2009-03-31 22:09:43EDT numerical-integration.lisp> ;; $Id$ ;;; To do: QAWS, QAWO, QAWF, more tests @@ -23,7 +23,10 @@ (a :double) (b :double) (absolute-error :double) (relative-error :double) (result :double) (abserr :double) (neval sizet)) - :documentation ; FDL + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) + :documentation ; FDL "Apply the Gauss-Kronrod 10-point, 21-point, 43-point and 87-point integration rules in succession until an estimate of the integral of f over (a,b) is achieved within the desired @@ -62,6 +65,9 @@ (absolute-error :double) (relative-error :double) (limit sizet) (method integrate-method) ((mpointer workspace) :pointer) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Apply an integration rule adaptively until an estimate of the integral of f over (a,b) is achieved within the @@ -94,6 +100,9 @@ (a :double) (b :double) (absolute-error :double) (relative-error :double) (limit sizet) ((mpointer workspace) :pointer) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Apply the Gauss-Kronrod 21-point integration rule adaptively until an estimate of the integral of f over @@ -122,6 +131,9 @@ (absolute-error :double) (relative-error :double) (limit sizet) ((mpointer workspace) :pointer) (result :double) (abserr :double)) :inputs (points) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Apply the adaptive integration algorithm QAGS taking account of the user-supplied locations of singular points. The array @@ -146,6 +158,9 @@ ((callback :pointer) (absolute-error :double) (relative-error :double) (limit sizet) ((mpointer workspace) :pointer) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the integral of the function f over the infinite interval (-\infty,+\infty). The integral is mapped onto the @@ -165,6 +180,9 @@ ((callback :pointer) (a :double) (absolute-error :double) (relative-error :double) (limit sizet) ((mpointer workspace) :pointer) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the integral of the function f over the semi-infinite interval (a,+\infty). The integral is mapped onto the @@ -180,6 +198,9 @@ ((callback :pointer) (b :double) (absolute-error :double) (relative-error :double) (limit sizet) ((mpointer workspace) :pointer) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the integral of the function f over the semi-infinite interval (-\infty,b). The integral is mapped onto the @@ -200,6 +221,9 @@ (a :double) (b :double) (c :double) (absolute-error :double) (relative-error :double) (limit sizet) ((mpointer workspace) :pointer) (result :double) (abserr :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) + :callback-dynamic (nil (function)) :documentation ; FDL "Compute the Cauchy principal value of the integral of f over (a,b), with a singularity at c, @@ -217,10 +241,7 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(defun one-sine (x) (sin x)) -(make-callbacks single-function one-sine) - (save-test numerical-integration - (integration-qng 'one-sine 0.0d0 pi) - (integration-QAG 'one-sine 0.0d0 pi :gauss15 20) - (integration-QAG 'one-sine 0.0d0 pi :gauss21 40)) + (integration-qng 'sin 0.0d0 pi) + (integration-QAG 'sin 0.0d0 pi :gauss15 20) + (integration-QAG 'sin 0.0d0 pi :gauss21 40)) diff --git a/chebyshev.lisp b/chebyshev.lisp index 181c1b35c49c8d809dae494333b37a341c5a1946..7578836d7ccafbe0a143a0a1eb0ecf7c5d44f459 100644 --- a/chebyshev.lisp +++ b/chebyshev.lisp @@ -1,6 +1,6 @@ ;; Chebyshev Approximations ;; Liam Healy Sat Nov 17 2007 - 20:36 -;; Time-stamp: <2009-02-17 22:52:51EST chebyshev.lisp> +;; Time-stamp: <2009-03-29 11:44:09EDT chebyshev.lisp> ;; $Id$ (in-package :gsl) @@ -16,8 +16,8 @@ "Chebyshev series" :documentation ; FDL "Make a Chebyshev series of specified order." - :superclasses (callback-included) - :ci-class-slots (gsl-function nil (function)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) :initialize-suffix "init" :initialize-args ((callback :pointer) (lower-limit :double) (upper-limit :double)) @@ -55,6 +55,7 @@ ((((mpointer object) :pointer) (x :double)) (((mpointer object) :pointer) (order sizet) (x :double))) :definition :method + :callback-object object :c-return :double :documentation ; FDL "Evaluate the Chebyshev series at a point x. If order is supplied, @@ -102,8 +103,6 @@ (defun chebyshev-step (x) (if (< x 0.5d0) 0.25d0 0.75d0)) -(make-callbacks single-function chebyshev-step) - (defun chebyshev-table-example () (let ((steps 100)) (let ((cheb (make-chebyshev 40 'chebyshev-step 0.0d0 1.0d0))) diff --git a/documentation/index.html b/documentation/index.html index 70caeaf558839edbf1b190f0afc8bac41d519c89..5451b29fb67696a9baee12b42563f1e4e91d652a 100644 --- a/documentation/index.html +++ b/documentation/index.html @@ -312,22 +312,14 @@ area of memory.</p> <h3>Passing functions</h3> <p> Functions that are passed to GSL functions (known as <i>callbacks</i> - in C) are defined by writing an ordinary CL function or functions and - then calling <code>make-callbacks</code> with arguments that - depend on the application. Functions or objects that require a - callback will accept the symbol representing the first or only function - defined in the <code>make-callbacks</code>. For example, after - defining an ordinary CL function <code>mcrw</code>, - <pre> - (make-callbacks monte-carlo mcrw 3) - (monte-carlo-integrate-plain 'mcrw lower upper nsamples rng ws) - </pre> - <p> - In some cases, the CL function can be written to accept and return - either scalars or arrays. See examples for numerical - integration, numerical differentiation, Chebyshev, root solvers, - minimizers, Monte Carlo, nonlinear least squares, and ordinary - differential equation solvers. + in C) are specified with a + <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function + designator</a> for the CL function, that is, either the function + object itself or a symbol denoting the function. + There is usually an option <code>scalarsp</code> for functions + that take or return arrays that, if true, will + send the user function the argument element by element, and expect + the return values to be the individual elements. </p> <h3>GSL objects</h3> @@ -396,7 +388,7 @@ and arrays used internally or for function return. <!-- Created: Feb 25 2005 --> <!-- hhmts start --> <small> -Time-stamp: <2009-03-20 11:54:53EDT index.html> +Time-stamp: <2009-03-31 22:41:54EDT index.html> </small> <!-- hhmts end --> </div> diff --git a/gsll.asd b/gsll.asd index 2b78987e739c14bcb3f399505fe850ad323c8c5a..db76ec13824fecd31ed68ef0ea9507c16bf16d9f 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,207 +1,211 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2009-02-16 17:15:57EST gsll.asd> +;; Time-stamp: <2009-03-31 22:11:14EDT gsll.asd> ;; $Id$ (asdf:defsystem "gsll" - :name "gsll" - :description "GNU Scientific Library for Lisp." - :version "0" - :author "Liam M. Healy" - :licence "LLGPL v3, FDL" - :depends-on (cffi trivial-garbage cl-utilities) - :components - ((:module init - :components - ((:file "init") - (:file "conditions" :depends-on (init)) - (:file "mobject" :depends-on (init)) - (:file "callback" :depends-on (init mobject)) - (:file "types" :depends-on (init)) - (:file "complex-types" :depends-on (types)) - (:file "element-types" :depends-on (init complex-types)) - (:file "number-conversion" :depends-on (init)) - (:file "interface" - :depends-on (init conditions element-types number-conversion)) - (:file "defmfun" :depends-on (init element-types interface)) - (:file "defmfun-array" :depends-on (defmfun)) - (:file "defmfun-single" :depends-on (defmfun mobject callback)) - (:file "generate-examples" :depends-on (init)))) - (:module floating-point - :depends-on (init) - :components - ((:file "ieee-modes") - (:file "floating-point"))) - (:module mathematical - :depends-on (init) - :components - ((:file "mathematical") - (:file "complex"))) - (:module data - :depends-on (init) - :components - ((:file "foreign-friendly") - (:file "foreign-array" :depends-on (foreign-friendly)) - (:file "marray" :depends-on (foreign-array)) - (:file "vector" :depends-on (marray)) - (:file "matrix" :depends-on (marray vector)) - (:file "maref" :depends-on (marray vector matrix)) - (:file "both" :depends-on (marray vector matrix)) - (:file "copy-cl") - (:file "array-tests" :depends-on (both)) - (:file "permutation" :depends-on (marray)) - (:file "combination" :depends-on (marray)))) - (:file "polynomial" :depends-on (init data)) - (:module special-functions - :depends-on (init) - :components - ((:file "return-structures") - (:file "airy" :depends-on (return-structures)) - (:file "bessel" :depends-on (return-structures)) - (:file "clausen" :depends-on (return-structures)) - (:file "coulomb" :depends-on (return-structures)) - (:file "coupling" :depends-on (return-structures)) - (:file "dawson" :depends-on (return-structures)) - (:file "debye" :depends-on (return-structures)) - (:file "dilogarithm" :depends-on (return-structures)) - (:file "elementary" :depends-on (return-structures)) - (:file "elliptic-integrals" :depends-on (return-structures)) - (:file "elliptic-functions" :depends-on (return-structures)) - (:file "error-functions" :depends-on (return-structures)) - (:file "exponential-functions" :depends-on (return-structures)) - (:file "exponential-integrals" :depends-on (return-structures)) - (:file "fermi-dirac" :depends-on (return-structures)) - (:file "gamma" :depends-on (return-structures)) - (:file "gegenbauer" :depends-on (return-structures)) - (:file "hypergeometric" :depends-on (return-structures)) - (:file "laguerre" :depends-on (return-structures)) - (:file "lambert" :depends-on (return-structures)) - (:file "legendre" :depends-on (return-structures)) - (:file "logarithm" :depends-on (return-structures)) - (:file "mathieu" :depends-on (return-structures)) - (:file "power" :depends-on (return-structures)) - (:file "psi" :depends-on (return-structures)) - (:file "synchrotron" :depends-on (return-structures)) - (:file "transport" :depends-on (return-structures)) - (:file "trigonometry" :depends-on (return-structures)) - (:file "zeta" :depends-on (return-structures)))) - (:file "sorting" :depends-on (init data)) - (:module linear-algebra - :depends-on (init data special-functions) - :components - ((:file "blas1") - (:file "blas2") - (:file "blas3" :depends-on (blas2)) - (:file "exponential") - (:file "lu") - (:file "qr") - (:file "qrpt") - (:file "svd") - (:file "cholesky") - (:file "diagonal") - (:file "householder"))) - (:module eigensystems - :depends-on (init data) - :components - ((:file "symmetric-hermitian") - (:file "nonsymmetric") - (:file "generalized") - (:file "nonsymmetric-generalized"))) - ;; Skip fft for now, I'm not sure how it works in C - (:module random - :depends-on (init data) - :components - ((:file "rng-types") - (:file "generators" :depends-on (rng-types)) - (:file "quasi" :depends-on (rng-types generators)) - (:file "gaussian" :depends-on (rng-types)) - (:file "gaussian-tail" :depends-on (rng-types)) - (:file "gaussian-bivariate" :depends-on (rng-types)) - (:file "exponential" :depends-on (rng-types)) - (:file "laplace" :depends-on (rng-types)) - (:file "exponential-power" :depends-on (rng-types)) - (:file "cauchy" :depends-on (rng-types)) - (:file "rayleigh" :depends-on (rng-types)) - (:file "rayleigh-tail" :depends-on (rng-types)) - (:file "landau" :depends-on (rng-types)) - (:file "levy" :depends-on (rng-types)) - (:file "gamma" :depends-on (rng-types)) - (:file "flat" :depends-on (rng-types)) - (:file "lognormal" :depends-on (rng-types)) - (:file "chi-squared" :depends-on (rng-types)) - (:file "fdist" :depends-on (rng-types)) - (:file "tdist" :depends-on (rng-types)) - (:file "beta" :depends-on (rng-types)) - (:file "logistic" :depends-on (rng-types)) - (:file "pareto" :depends-on (rng-types)) - (:file "spherical-vector" :depends-on (rng-types)) - (:file "weibull" :depends-on (rng-types)) - (:file "gumbel1" :depends-on (rng-types)) - (:file "gumbel2" :depends-on (rng-types)) - (:file "dirichlet" :depends-on (rng-types)) - (:file "discrete" :depends-on (rng-types)) - (:file "poisson" :depends-on (rng-types)) - (:file "bernoulli" :depends-on (rng-types)) - (:file "binomial" :depends-on (rng-types)) - (:file "multinomial" :depends-on (rng-types)) - (:file "negative-binomial" :depends-on (rng-types)) - (:file "geometric" :depends-on (rng-types)) - (:file "hypergeometric" :depends-on (rng-types)) - (:file "logarithmic" :depends-on (rng-types)) - (:file "shuffling-sampling" :depends-on (rng-types)))) - (:module statistics - :depends-on (init data) - :components - ((:file "mean-variance") - (:file "absolute-deviation") - (:file "higher-moments") - (:file "autocorrelation") - (:file "covariance") - ;; minimum and maximum values provided in vector.lisp - (:file "median-percentile"))) - (:module histogram - :depends-on (init linear-algebra) - :components - ((:file "histogram") - (:file "updating-accessing" :depends-on (histogram)) - (:file "statistics" :depends-on (histogram)) - (:file "operations" :depends-on (histogram)) - (:file "probability-distribution" :depends-on (histogram)) - (:file "ntuple"))) - (:module calculus - :depends-on (init data random) - :components - ((:file "numerical-integration") - (:file "monte-carlo") - (:file "numerical-differentiation"))) - (:module ordinary-differential-equations - :depends-on (init) - :components - ((:file "ode-system") - (:file "stepping") - (:file "control") - (:file "evolution") - (:file "ode-example" :depends-on (ode-system stepping)))) - (:module interpolation - :depends-on (init) - :components - ((:file "interpolation") - (:file "types" :depends-on (interpolation)) - (:file "lookup") - (:file "evaluation") - (:file "spline-example" :depends-on (types)))) - (:file "chebyshev" :depends-on (init)) - (:file "series-acceleration" :depends-on (init)) - (:file "wavelet" :depends-on (init data)) - (:file "hankel" :depends-on (init data)) - (:module solve-minimize-fit - :depends-on (init data random) - :components - ((:file "generic") - (:file "roots-one" :depends-on (generic)) - (:file "minimization-one" :depends-on (generic)) - (:file "roots-multi" :depends-on (roots-one generic)) - (:file "minimization-multi" :depends-on (generic)) - (:file "linear-least-squares") - (:file "nonlinear-least-squares" :depends-on (generic)))) - (:file "basis-splines" :depends-on (init data random)))) + :name "gsll" + :description "GNU Scientific Library for Lisp." + :version "0" + :author "Liam M. Healy" + :licence "LLGPL v3, FDL" + :depends-on (cffi trivial-garbage cl-utilities) + :components + ((:module init + :components + ((:file "init") + (:file "forms") + (:file "conditions" :depends-on (init)) + (:file "number-conversion" :depends-on (init)) + (:file "callback-compile-defs" :depends-on (init)) + (:file "mobject" :depends-on (init callback-compile-defs)) + (:file "callback-included" :depends-on (mobject)) + (:file "callback" :depends-on (init forms number-conversion callback-included)) + (:file "funcallable") + (:file "types" :depends-on (init)) + (:file "complex-types" :depends-on (types)) + (:file "element-types" :depends-on (init complex-types)) + (:file "interface" + :depends-on (init conditions element-types number-conversion)) + (:file "defmfun" :depends-on (init forms element-types interface)) + (:file "defmfun-array" :depends-on (defmfun callback-included)) + (:file "defmfun-single" :depends-on (defmfun mobject callback)) + (:file "generate-examples" :depends-on (init)))) + (:module floating-point + :depends-on (init) + :components + ((:file "ieee-modes") + (:file "floating-point"))) + (:module mathematical + :depends-on (init) + :components + ((:file "mathematical") + (:file "complex"))) + (:module data + :depends-on (init) + :components + ((:file "foreign-friendly") + (:file "foreign-array" :depends-on (foreign-friendly)) + (:file "marray" :depends-on (foreign-array)) + (:file "vector" :depends-on (marray)) + (:file "matrix" :depends-on (marray vector)) + (:file "maref" :depends-on (marray vector matrix)) + (:file "both" :depends-on (marray vector matrix)) + (:file "copy-cl") + (:file "array-tests" :depends-on (both)) + (:file "permutation" :depends-on (marray)) + (:file "combination" :depends-on (marray)))) + (:file "polynomial" :depends-on (init data)) + (:module special-functions + :depends-on (init) + :components + ((:file "return-structures") + (:file "airy" :depends-on (return-structures)) + (:file "bessel" :depends-on (return-structures)) + (:file "clausen" :depends-on (return-structures)) + (:file "coulomb" :depends-on (return-structures)) + (:file "coupling" :depends-on (return-structures)) + (:file "dawson" :depends-on (return-structures)) + (:file "debye" :depends-on (return-structures)) + (:file "dilogarithm" :depends-on (return-structures)) + (:file "elementary" :depends-on (return-structures)) + (:file "elliptic-integrals" :depends-on (return-structures)) + (:file "elliptic-functions" :depends-on (return-structures)) + (:file "error-functions" :depends-on (return-structures)) + (:file "exponential-functions" :depends-on (return-structures)) + (:file "exponential-integrals" :depends-on (return-structures)) + (:file "fermi-dirac" :depends-on (return-structures)) + (:file "gamma" :depends-on (return-structures)) + (:file "gegenbauer" :depends-on (return-structures)) + (:file "hypergeometric" :depends-on (return-structures)) + (:file "laguerre" :depends-on (return-structures)) + (:file "lambert" :depends-on (return-structures)) + (:file "legendre" :depends-on (return-structures)) + (:file "logarithm" :depends-on (return-structures)) + (:file "mathieu" :depends-on (return-structures)) + (:file "power" :depends-on (return-structures)) + (:file "psi" :depends-on (return-structures)) + (:file "synchrotron" :depends-on (return-structures)) + (:file "transport" :depends-on (return-structures)) + (:file "trigonometry" :depends-on (return-structures)) + (:file "zeta" :depends-on (return-structures)))) + (:file "sorting" :depends-on (init data)) + (:module linear-algebra + :depends-on (init data special-functions) + :components + ((:file "blas1") + (:file "blas2") + (:file "blas3" :depends-on (blas2)) + (:file "exponential") + (:file "lu") + (:file "qr") + (:file "qrpt") + (:file "svd") + (:file "cholesky") + (:file "diagonal") + (:file "householder"))) + (:module eigensystems + :depends-on (init data) + :components + ((:file "symmetric-hermitian") + (:file "nonsymmetric") + (:file "generalized") + (:file "nonsymmetric-generalized"))) + ;; Skip fft for now, I'm not sure how it works in C + (:module random + :depends-on (init data) + :components + ((:file "rng-types") + (:file "generators" :depends-on (rng-types)) + (:file "quasi" :depends-on (rng-types generators)) + (:file "gaussian" :depends-on (rng-types)) + (:file "gaussian-tail" :depends-on (rng-types)) + (:file "gaussian-bivariate" :depends-on (rng-types)) + (:file "exponential" :depends-on (rng-types)) + (:file "laplace" :depends-on (rng-types)) + (:file "exponential-power" :depends-on (rng-types)) + (:file "cauchy" :depends-on (rng-types)) + (:file "rayleigh" :depends-on (rng-types)) + (:file "rayleigh-tail" :depends-on (rng-types)) + (:file "landau" :depends-on (rng-types)) + (:file "levy" :depends-on (rng-types)) + (:file "gamma" :depends-on (rng-types)) + (:file "flat" :depends-on (rng-types)) + (:file "lognormal" :depends-on (rng-types)) + (:file "chi-squared" :depends-on (rng-types)) + (:file "fdist" :depends-on (rng-types)) + (:file "tdist" :depends-on (rng-types)) + (:file "beta" :depends-on (rng-types)) + (:file "logistic" :depends-on (rng-types)) + (:file "pareto" :depends-on (rng-types)) + (:file "spherical-vector" :depends-on (rng-types)) + (:file "weibull" :depends-on (rng-types)) + (:file "gumbel1" :depends-on (rng-types)) + (:file "gumbel2" :depends-on (rng-types)) + (:file "dirichlet" :depends-on (rng-types)) + (:file "discrete" :depends-on (rng-types)) + (:file "poisson" :depends-on (rng-types)) + (:file "bernoulli" :depends-on (rng-types)) + (:file "binomial" :depends-on (rng-types)) + (:file "multinomial" :depends-on (rng-types)) + (:file "negative-binomial" :depends-on (rng-types)) + (:file "geometric" :depends-on (rng-types)) + (:file "hypergeometric" :depends-on (rng-types)) + (:file "logarithmic" :depends-on (rng-types)) + (:file "shuffling-sampling" :depends-on (rng-types)))) + (:module statistics + :depends-on (init data) + :components + ((:file "mean-variance") + (:file "absolute-deviation") + (:file "higher-moments") + (:file "autocorrelation") + (:file "covariance") + ;; minimum and maximum values provided in vector.lisp + (:file "median-percentile"))) + (:module histogram + :depends-on (init linear-algebra) + :components + ((:file "histogram") + (:file "updating-accessing" :depends-on (histogram)) + (:file "statistics" :depends-on (histogram)) + (:file "operations" :depends-on (histogram)) + (:file "probability-distribution" :depends-on (histogram)) + (:file "ntuple"))) + (:module calculus + :depends-on (init data random) + :components + ((:file "numerical-integration") + (:file "monte-carlo") + (:file "numerical-differentiation"))) + (:module ordinary-differential-equations + :depends-on (init) + :components + ((:file "ode-system") + (:file "stepping") + (:file "control") + (:file "evolution") + (:file "ode-example" :depends-on (ode-system stepping)))) + (:module interpolation + :depends-on (init) + :components + ((:file "interpolation") + (:file "types" :depends-on (interpolation)) + (:file "lookup") + (:file "evaluation") + (:file "spline-example" :depends-on (types)))) + (:file "chebyshev" :depends-on (init)) + (:file "series-acceleration" :depends-on (init)) + (:file "wavelet" :depends-on (init data)) + (:file "hankel" :depends-on (init data)) + (:module solve-minimize-fit + :depends-on (init data random) + :components + ((:file "generic") + (:file "roots-one" :depends-on (generic)) + (:file "minimization-one" :depends-on (generic)) + (:file "roots-multi" :depends-on (roots-one generic)) + (:file "minimization-multi" :depends-on (generic)) + (:file "linear-least-squares") + (:file "nonlinear-least-squares" :depends-on (generic)))) + (:file "basis-splines" :depends-on (init data random)))) diff --git a/init/callback-compile-defs.lisp b/init/callback-compile-defs.lisp new file mode 100644 index 0000000000000000000000000000000000000000..4769ac23f17a9b12a025bc6270cda35454006375 --- /dev/null +++ b/init/callback-compile-defs.lisp @@ -0,0 +1,69 @@ +;; Definitions for macro expansion +;; Liam Healy 2009-03-15 14:50:28EDT callback-compile-defs.lisp +;; Time-stamp: <2009-03-18 22:46:59EDT callback-compile-defs.lisp> +;; $Id: $ + +(in-package :gsl) + +;;;;**************************************************************************** +;;;; Record the :callbacks information for the object +;;;;**************************************************************************** + +(defvar *callbacks-for-classes* (make-hash-table :size 32) + "A table of :callbacks arguments for each class.") + +(defun record-callbacks-for-class (class callbacks) + (setf (gethash class *callbacks-for-classes*) callbacks)) + +(defun get-callbacks-for-class (class) + (gethash class *callbacks-for-classes*)) + +(defun make-cbstruct-object (class) + "Make the callback structure based on the mobject definition." + (let ((cbs (get-callbacks-for-class class))) + (unless cbs (error "Class ~a not defined." class)) + `(make-cbstruct + ',(parse-callback-static cbs 'callback-structure-type) + (when (dimension-names object) + (mapcan 'list (dimension-names object) (dimensions object))) + ,@(mapcan + 'list + (mapcar + (lambda (fn) `',(parse-callback-fnspec fn 'structure-slot-name)) + (parse-callback-static cbs 'functions)) + (mapcar (lambda (nm) `',nm) + (mobject-cbvnames class (number-of-callbacks cbs))))))) + +;;;;**************************************************************************** +;;;; Make defmcallback forms +;;;;**************************************************************************** + +;;; These functions make interned symbols that will be bound to +;;; dynamic variables. + +(defun make-mobject-defmcallbacks (callbacks class) + "Make the defmcallback forms needed to define the callbacks + associated with mobject that includes callback functions." + (let ((numcb (number-of-callbacks callbacks))) + (make-defmcallbacks + callbacks + (mobject-cbvnames class numcb) + (mobject-fnvnames class numcb)))) + +(defun mobject-variable-name (class-name suffix &optional count) + (intern (format nil "~:@(~a~)-~:@(~a~)~@[~d~]" class-name suffix count) + :gsll)) + +(defun mobject-cbvname (class-name &optional count) + (mobject-variable-name class-name 'cbfn count)) + +(defun mobject-cbvnames (class-name &optional count) + (loop for i from 0 below count collect (mobject-cbvname class-name i))) + +(defun mobject-fnvname (class-name &optional count) + (mobject-variable-name class-name 'dynfn count)) + +(defun mobject-fnvnames (class-name &optional count) + (when class-name + (loop for i from 0 below count collect (mobject-fnvname class-name i)))) + diff --git a/init/callback-included.lisp b/init/callback-included.lisp new file mode 100644 index 0000000000000000000000000000000000000000..dc30791bcad9786f2efb6e7c9ec9970751b4cdf9 --- /dev/null +++ b/init/callback-included.lisp @@ -0,0 +1,83 @@ +;; The mobject that defines callbacks +;; Liam Healy 2009-03-14 11:20:03EDT callback-included.lisp +;; Time-stamp: <2009-03-31 22:33:09EDT callback-included.lisp> +;; $Id: $ + +(in-package :gsl) + +;;;;**************************************************************************** +;;;; Class definitions and macros +;;;;**************************************************************************** + +(defclass callback-included (mobject) + ((callbacks + :initarg :callbacks :reader callbacks + :documentation "The specification form for static callback information.") + (dimension-names + :initarg :dimension-names :reader dimension-names + :documentation "The names in the GSL struct for dimensions.") + (functions + :initarg :functions :reader functions :initform nil + :documentation "The user functions as function designators. + These should correspond in order to the structure-slot-name list.") + (funcallables + :initarg :funcallables :reader funcallables :initform nil + :documentation "The function objects that will be called by + the callbacks.") + (scalarsp + :initarg :scalarsp :reader scalarsp :initform t + :documentation "Whether the function expect to be passed and return + scalars or arrays.") + (dimensions :initarg :dimensions :reader dimensions)) + (:documentation + "A mobject that includes a callback function or functions to GSL.")) + +(defclass callback-included-cl (callback-included) + ((callback :initarg :callback :reader callback-struct)) + (:documentation + "A mobject that includes a callback function or functions, in which + the pointer to the callback structure is stored in a CL class + slot.")) + +(defmacro def-ci-subclass + (class-name superclasses documentation dimension-names) + `(defclass ,class-name ,superclasses + ((dimension-names :initform ',dimension-names :allocation :class)) + (:documentation ,documentation))) + +(defmacro def-ci-subclass-1d + (class-name superclasses documentation ignore) + (declare (ignore ignore)) + `(defclass ,class-name ,superclasses + ((dimension-names :initform nil :allocation :class) + (dimensions :initform '(1) :allocation :class) + (scalarsp :initform T :allocation :class)) + (:documentation ,documentation))) + +(defmethod print-object ((object callback-included) stream) + (print-unreadable-object (object stream :type t :identity t) + (when (slot-boundp object 'functions) + (princ "for " stream) + (princ (first (functions object)) stream) + (princ ", " stream)) + (princ "dimensions " stream) + (princ (dimensions object) stream))) + +;;;;**************************************************************************** +;;;; For making mobjects +;;;;**************************************************************************** + +;;; This is expanded in defmfun to set the dynamic variables. +(defun callback-set-dynamic (callback-object &optional arglist) + "Make a form to set the dynamic variable defining callbacks." + (when (listp callback-object) + (setf arglist callback-object + callback-object (caar callback-object))) + `((setf + ,@(loop for symb in + (let ((class (category-for-argument arglist callback-object))) + (mobject-fnvnames + class + (number-of-callbacks (get-callbacks-for-class class)))) + for n from 0 + append `(,symb (nth ,n (funcallables ,callback-object))))))) diff --git a/init/callback.lisp b/init/callback.lisp index f7ab1bee5e8d7a93907acb56405ab08b50249417..664e9f60a48abdb80670b3fe69ce388315788399 100644 --- a/init/callback.lisp +++ b/init/callback.lisp @@ -1,6 +1,6 @@ ;; Foreign callback functions. ;; Liam Healy -;; Time-stamp: <2009-03-23 11:18:51EDT callback.lisp> +;; Time-stamp: <2009-03-31 22:50:57EDT callback.lisp> ;; $Id$ (in-package :gsl) @@ -40,9 +40,13 @@ value)) (defun set-slot-function (foreign-structure structure-name slot-name gsl-function) + "Set the slot in the cbstruct to the callback corresponding to gsl-function. + If gsl-function is nil, set to the null-pointer." (set-structure-slot foreign-structure structure-name slot-name - (cffi:get-callback gsl-function))) + (if gsl-function + (cffi:get-callback gsl-function) + (cffi:null-pointer)))) (defun set-parameters (foreign-structure structure-name) "Set the parameters slot to null." @@ -60,324 +64,172 @@ (parameters :pointer)) ;;;;**************************************************************************** -;;;; Macros for defining a callback to wrap a CL function +;;;; Definitions for making cbstruct ;;;;**************************************************************************** -;;; Callback functions are defined using demcallback by passing the -;;; name of the function and the argument list of types. Arrays can -;;; be handled in one of two ways. If they are declared :pointer, the -;;; CL function will be passed a C pointer, and it is responsible for -;;; reading or setting the array, with #'dcref or #'maref. If they -;;; are declared (type size) then size scalars will be passed as -;;; arguments to the CL function, and if they are declared (:set type -;;; size), the CL function return size values, to which the array -;;; elements will be set. - -;;; Usage example for scalar function (e.g. numerical-integration, -;;; numerical-differentiation, chebyshev, ntuple). -;;; (defmcallback myfn :double :double) -;;; Usage example for vector function (e.g. roots-multi) -;;; (defmcallback myfn :pointer :int (:pointer)) -;;; Usage example for function and derivative -;;; (defmcallback fdf :pointer :double (:pointer :pointer)) -;;; (defmcallback fdf :success-failure :int (:pointer :pointer)) -;;; Usage example for def-ode-functions -;;; (defmcallback vanderpol :success-failure (:double (:double 2) (:set :double 2))) -;;; or -;;; (defmcallback vanderpol :success-failure (:double :pointer :pointer)) -;;; to read and set within the CL function with #'dcref. - -;;; (callback-args '(:double (:double 2) (:set :double 2))) -;;; ((#:ARG1193 :DOUBLE) (#:ARG1194 :POINTER) (#:ARG1195 :POINTER)) - -(defun callback-args (types) - "The arguments passed by GSL to the callback function." - (mapcar (lambda (type) - (let ((symbol (gensym "ARG"))) - (list symbol - (if (listp type) ; like (:double 3) - :pointer ; C array - type)))) - (if (listp types) types (list types)))) - -;;; (embedded-clfunc-args '(:double (:double 2) (:set :double 2)) (callback-args '(:double (:double 2) (:set :double 2)))) -;;; (#:ARG1244 (MEM-AREF #:ARG1245 ':DOUBLE 0) (MEM-AREF #:ARG1245 ':DOUBLE 1)) - -(defvar *setting-spec* '(:set)) -(defun embedded-clfunc-args (types callback-args &optional marray) - "The arguments passed to the CL function call embedded in the callback. - If 'marray is T, then reference GSL arrays; otherwise reference raw - C vectors. A specification (:set ...) means that the CL function - will define the array as multiple values; if the size is negative, - then the opposite value will be used for marray." - (loop for spec in types - for (symbol nil) in callback-args - append - (unless (and (listp spec) (member (first spec) *setting-spec*)) - (if (listp spec) - (if (third spec) - ;; matrix, marrays only - (loop for i from 0 below (second spec) - append - (loop for j from 0 below (third spec) - collect - `(maref ,symbol ,i ,j ',(cffi-cl (first spec))))) - ;; vector, marray or C array - (loop for ind from 0 below (abs (second spec)) - collect (if (if (minusp (second spec)) (not marray) marray) - `(maref ,symbol ,ind nil ',(cffi-cl (first spec))) - `(cffi:mem-aref ,symbol ',(first spec) ,ind)))) - (list symbol))))) - -(defun callback-set-mvb (form types callback-args &optional marray) - "Create the multiple-value-bind form in the callback to set the return C arrays." - (multiple-value-bind (settype setcba) - (loop for cba in callback-args - for type in types - for setting = (and (listp type) (member (first type) *setting-spec*)) - when setting - collect cba into setcba - when setting - collect type into settype - finally (return (values (mapcar 'rest settype) setcba))) - (let* ((setvbls (embedded-clfunc-args settype setcba marray)) - (count - (apply - '+ - (mapcar (lambda (inds) (abs (apply '* (rest inds)))) settype))) - (mvbvbls (loop repeat count collect (gensym "SETCB")))) - (if (zerop count) - form - `(multiple-value-bind ,mvbvbls - ,form - (setf ,@(loop for mvbvbl in mvbvbls - for setvbl in setvbls - append (list setvbl mvbvbl)))))))) - -(defmacro defmcallback - (name &optional (return-type :double) (argument-types :double) - additional-argument-types marray (function-name-or-lambda 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) - that appear before parameters, and the additional-argument-types - (default none) is a single type or list of types of the argument(s) - that appear after parameters. The argument types are C types or - a list of a C type and a length, indicating a C array of that type - for which each element will be passed as a separate argument. - The return-type is the type that should be returned to GSL. - If :success-failure, a GSL_SUCCESS code (0) is always returned; - if :pointer, a null pointer is returned." - (let* ((atl (if (listp argument-types) argument-types (list argument-types))) - (aatl (if (listp additional-argument-types) additional-argument-types - (list additional-argument-types))) - (cbargs (callback-args atl)) - (cbaddl (callback-args aatl))) - `(cffi:defcallback ,name - ,(if (eq return-type :success-failure) :int return-type) - (,@cbargs (params :pointer) ,@cbaddl) - ;; Parameters as C argument are always ignored, because we have - ;; CL specials to do the same job. - (declare (ignore params)) - ,(callback-set-mvb - `(,function-name-or-lambda - ,@(append - (embedded-clfunc-args atl cbargs marray) - (embedded-clfunc-args aatl cbaddl marray))) - (append atl aatl) - (append cbargs cbaddl) - marray) - ,@(case - return-type - (:success-failure - ;; We always return success, because if there was a - ;; problem, a CL error would be signalled. - '(+success+)) - (:pointer - ;; For unclear reasons, some GSL functions want callbacks - ;; to return a void pointer which is apparently meaningless. - '((cffi:null-pointer))))))) - -(defun set-cbstruct (cbstruct struct slots-values function-slotnames) +(defun set-cbstruct (cbstruct structure-name slots-values function-slotnames) "Make the slots in the foreign callback structure." (loop for (slot-name function) on function-slotnames by #'cddr - do (set-slot-function cbstruct struct slot-name function)) - (set-parameters cbstruct struct) + do (set-slot-function cbstruct structure-name slot-name function)) + (set-parameters cbstruct structure-name) (when slots-values (loop for (slot-name value) on slots-values by #'cddr - do (set-structure-slot cbstruct struct slot-name value)))) + do (set-structure-slot cbstruct structure-name slot-name value)))) (defun make-cbstruct (struct slots-values &rest function-slotnames) "Make the callback structure." + (assert struct (struct) "Structure must be supplied.") (let ((cbstruct (cffi:foreign-alloc struct))) (set-cbstruct cbstruct struct slots-values function-slotnames) cbstruct)) -(defun make-cbstruct-object (object) - "Make the callback structure based on the mobject definition." - (apply - 'make-cbstruct - (cbstruct-name object) - (when (dimension-names object) - (mapcan 'list (dimension-names object) (dimensions object))) - (mapcan 'list (callback-labels object) (functions object)))) - -(defmacro with-computed-dimensions - (dimensions-spec dimensions-used lambda-form &body body) - (cl-utilities:once-only (lambda-form) - `(let ((,dimensions-used - (if (and (listp ,lambda-form) (eq (first ,lambda-form) 'lambda)) - (length (second ,lambda-form)) - ,dimensions-spec))) - ,@body))) - -(defun dimensions-from-lambda (lambda-form dimensions) - "Determine the number of dimensions from the lambda form, - or return the value specified in 'dimensions." - (if (and (listp lambda-form) (eq (first lambda-form) 'lambda)) - (length (second lambda-form)) - dimensions)) - ;;;;**************************************************************************** -;;;; Classes that include callback information +;;;; Parsing :callback argument specification ;;;;**************************************************************************** -(defclass callback-included (mobject) - ((cbstruct-name - :initarg :cbstruct-name :reader cbstruct-name - :documentation - "The name of the GSL structure representing the callback(s).") - (array-type - :initarg :array-type :reader array-type - :documentation "A symbol 'marray or 'cvector.") - (callback-labels - :initarg :callback-labels :reader callback-labels - :documentation "The labels in the GSL struct for each callback function.") - (dimension-names - :initarg :dimension-names :reader dimension-names - :documentation "The names in the GSL struct for dimensions.") - (functions - :initarg :functions :reader functions - :documentation "The names of the function(s) put into - the callback. These should correspond in order to - callback-labels.") - (dimensions :initarg :dimensions :reader dimensions)) - (:documentation - "A mobject that includes a callback function or functions to GSL.")) - -(defclass callback-included-cl (callback-included) - ((callback :initarg :callback :reader callback-struct)) - (:documentation - "A mobject that includes a callback function or functions, which - the pointer to the callback structure is stored in a CL class - slot.")) - -(defmacro def-ci-subclass - (class-name superclasses documentation - cbstruct-name array-type callback-labels - &optional (dimension-names '(dimensions))) - `(defclass ,class-name ,superclasses - ((cbstruct-name :initform ',cbstruct-name :allocation :class) - (array-type :initform ',array-type :allocation :class) - (callback-labels :initform ',callback-labels :allocation :class) - (dimension-names :initform ',dimension-names :allocation :class)) - (:documentation ,documentation))) - -(defmacro def-ci-subclass-1d - (class-name superclasses documentation - cbstruct-name array-type callback-labels) - `(defclass ,class-name ,superclasses - ((cbstruct-name :initform ',cbstruct-name :allocation :class) - (array-type :initform ',array-type :allocation :class) - (callback-labels :initform ',callback-labels :allocation :class) - (dimension-names :initform nil :allocation :class) - (dimensions :initform '(1) :allocation :class)) - (:documentation ,documentation))) - -(defgeneric make-callbacks-fn (class args) - (:documentation "Function to make forms that expand into defmcallback(s).")) - -(eval-when (:compile-toplevel :load-toplevel) - (defvar *callback-table* (make-hash-table :size 20))) - -(defmacro def-make-callbacks (class arglist &body body) - `(eval-when (:compile-toplevel :load-toplevel) - (setf (gethash ',class *callback-table*) - (lambda ,arglist ,@body)))) - -(def-make-callbacks single-function (function) - `(defmcallback ,function - :double :double - nil - t - ,function)) - -(export 'make-callbacks) -(defmacro make-callbacks (class &rest args) - "Make the callbacks for the named class. The args are generally of the form - function [function...] dimension [dimension ...] scalars - If 'scalars is T, the functions will be called with scalars, and should - return answer as multiple values with #'values. If it is NIL, it will - be called with two arguments; it should read the values from the first - array and write the answer in the second array." - (apply (gethash class *callback-table*) args)) - -(defmethod print-object ((object callback-included) stream) - (print-unreadable-object (object stream :type t :identity t) - (when (slot-boundp object 'functions) - (princ "for " stream) - (princ (first (functions object)) stream) - (princ "," stream)) - (princ "dimensions " stream) - (princ (dimensions object) stream))) +;;; The :callbacks argument is a list of the form: +;;; (foreign-argument callback-structure-type dimension-names function ...) +;;; where each function is of the form +;;; (structure-slot-name +;;; &optional (return-spec 'double-float) (argument-spec 'double-float) +;;; set1-spec set2-spec) +;;; and each of the *-spec are (type array-type &rest dimensions). + +(defun parse-callback-static (callbacks component) + "Get the information component from the callbacks list." + (case component + (foreign-argument (first callbacks)) + (callback-structure-type (second callbacks)) + (dimension-names (third callbacks)) + (functions (nthcdr 3 callbacks)))) + +(defun number-of-callbacks (callbacks) + (length (parse-callback-static callbacks 'functions))) + +(defun parse-callback-fnspec (fnspec component) + "From the :callbacks argument, parse a single function specification." + (ecase component + (structure-slot-name (first fnspec)) + (return-spec (second fnspec)) + (arguments-spec (cddr fnspec)))) + +(defun parse-callback-argspec (argspec component) + "From the :callbacks argument, parse a single argument of a single + function specification." + (ecase component + (io (first argspec)) ; :input or :output + (element-type (second argspec)) ; :double + (array-type (third argspec)) ; :marray or :cvector + (dimensions (nthcdr 3 argspec)))) ;;;;**************************************************************************** ;;;; Using callback specification in function arugments ;;;;**************************************************************************** -(defun callback-arg-p (arglist &optional key) - (member +callback-argument-name+ arglist :key key)) - -(defun callback-replace-arg (replacement list) - (subst replacement +callback-argument-name+ list)) - -(defun callback-remove-arg (list &optional key) - (remove +callback-argument-name+ list :key key)) - -;;; From CLOCC:port, with addition of openmcl -(defun arglist (fn) - "Return the signature of the function." - #+allegro (excl:arglist fn) - #+clisp (sys::arglist fn) - #+(or cmu scl) - (let ((f (coerce fn 'function))) - (typecase f - (STANDARD-GENERIC-FUNCTION (pcl:generic-function-lambda-list f)) - (EVAL:INTERPRETED-FUNCTION (eval:interpreted-function-arglist f)) - (FUNCTION (values (read-from-string (kernel:%function-arglist f)))))) - #+cormanlisp (ccl:function-lambda-list - (typecase fn (symbol (fdefinition fn)) (t fn))) - #+gcl (let ((fn (etypecase fn - (symbol fn) - (function (si:compiled-function-name fn))))) - (get fn 'si:debug)) - #+lispworks (lw:function-lambda-list fn) - #+lucid (lcl:arglist fn) - #+sbcl (progn (require :sb-introspect) - (let ((fun (find-symbol (symbol-name 'function-arglist) 'sb-introspect))) - (when fun - (funcall fun fn)))) - #+openmcl (ccl:arglist fn) - #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl scl openmcl) - (error "No arglist function known.")) - -(defmacro callback-set-slots - (trigger-list struct-name function) - "If the callback argument is on trigger-list, then return a form - that sets the slots in the GSL callback structure." - `(let ((setdim (not (eq ,struct-name 'gsl-function)))) - (when (callback-arg-p ,trigger-list) - `((set-cbstruct ,',+callback-argument-name+ ',,struct-name - ,,'(when setdim - '(list 'dimensions (length (arglist function)))) - (list 'function ,',function)))))) +(defun callback-arg-p (arglist callbacks &optional key) + (member (parse-callback-static callbacks 'foreign-argument) arglist :key key)) + +(defun callback-replace-arg (replacement list callbacks) + "Replace in the list the symbol representing the foreign callback argument." + (if callbacks + (subst + replacement + (parse-callback-static callbacks 'foreign-argument) + list) + list)) + +(defun callback-remove-arg (list callbacks &optional key) + "Remove from the list the symbol representing the foreign callback argument." + (remove (parse-callback-static callbacks 'foreign-argument) list :key key)) + +;;;;**************************************************************************** +;;;; Form generation +;;;;**************************************************************************** + +;;; The :callback-dynamic is a list of the form +;;; (dimensions (function scalarsp) ...) +;;; This is used in defmfuns that send callbacks directly, with no mobject. +;;; With functions given in the same order as +;;; the in the :callbacks argument +;;; function = function designator, +;;; scalarsp = flag determining whether to pass/accept scalars or arrays +;;; dimensions = source dimensions, a list + +(defun cbd-dimensions (callback-dynamic) + (first callback-dynamic)) + +(defun cbd-functions (callback-dynamic) + (rest callback-dynamic)) + +(defun callback-symbol-set (callback-dynamic callbacks symbols) + "Generate the form to set each of the dynamic (special) variables + to (function scalarsp dimensions...) in the body of the demfun for + each of the callback functions." + (when callbacks + `((setf + ,@(loop for symb in symbols + for function in (cbd-functions callback-dynamic) + for fnspec in (parse-callback-static callbacks 'functions) + append + `(,symb + (make-compiled-funcallable + ,(first function) + ',fnspec + ,(second function) + ,(cons 'list (cbd-dimensions callback-dynamic))))))))) + +(defun callback-set-slots (callbacks dynamic-variables callback-dynamic) + "Set the slots in the foreign callback struct." + (when callbacks + `((set-cbstruct + ,(parse-callback-static callbacks 'foreign-argument) + ',(parse-callback-static callbacks 'callback-structure-type) + ,(when (parse-callback-static callbacks 'dimension-names) + (cons 'list + (loop + for dim-name in (parse-callback-static callbacks 'dimension-names) + for dim in (cbd-dimensions callback-dynamic) + append (list `',dim-name dim)))) + ,(cons + 'list + (loop for symb in (second dynamic-variables) + for fn in (parse-callback-static callbacks 'functions) + append + `(',(parse-callback-fnspec fn 'structure-slot-name) + ',symb))))))) + +(defun callback-args (argspec) + "The arguments passed by GSL to the callback function." + (mapcar (lambda (arg) + (if (listp arg) + (let ((symbol (gensym "ARG"))) + (list symbol + (if (parse-callback-argspec arg 'array-type) + :pointer ; C array + (parse-callback-argspec arg 'element-type)))) + arg)) + argspec)) + +;;;;**************************************************************************** +;;;; Macro defmcallback +;;;;**************************************************************************** + +(defun make-defmcallbacks (callbacks callback-names function-names) + (when callbacks + (mapcar + (lambda (cb vbl fspec) `(defmcallback ,cb ,vbl ,fspec)) + callback-names function-names + (parse-callback-static callbacks 'functions)))) + +(defmacro defmcallback (name dynamic-variable function-spec) + (let* ((argspec (parse-callback-fnspec function-spec 'arguments-spec)) + (return-type (parse-callback-fnspec function-spec 'return-spec)) + (args (callback-args argspec)) + (slug (make-symbol "SLUG"))) + `(cffi:defcallback ,name + ,(if (eq return-type :success-failure) :int return-type) + (,@(substitute `(,slug :pointer) :slug args)) + ;; Parameters as C argument are always ignored, because we have + ;; CL specials to do the same job. + (declare (ignore ,slug) (special ,dynamic-variable)) + (funcall ,dynamic-variable ,@(mapcar 'st-symbol (remove :slug args)))))) diff --git a/init/defmfun-array.lisp b/init/defmfun-array.lisp index facfe578f7e5693e8f29c0a1b4a37a2829cab874..080b144a23f378674932807f10f9b686294fd028 100644 --- a/init/defmfun-array.lisp +++ b/init/defmfun-array.lisp @@ -1,6 +1,6 @@ ;; Helpers for defining GSL functions on arrays ;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp -;; Time-stamp: <2009-02-17 21:10:22EST defmfun-array.lisp> +;; Time-stamp: <2009-03-07 15:54:48EST defmfun-array.lisp> ;; $Id: $ (in-package :gsl) @@ -182,24 +182,6 @@ "Find the actual form to use as the default based on the list in form." (loop for (type result) on form by #'cddr thereis (when (subtypep element-type type) result))) - -(defun arglist-plain-and-categories - (arglist &optional (include-llk t)) - "Get arglist without classes and a list of categories." - (loop for arg in arglist - with getting-categories = t and categories - do - (when (and getting-categories (member arg *defmfun-llk*)) - (setf getting-categories nil)) - (when (and getting-categories (listp arg)) - ;; Collect categories (classes), but not default values to - ;; optional arugments. - (pushnew (second arg) categories)) - when (or (not (member arg *defmfun-llk*)) include-llk) - collect - (if (listp arg) (first arg) arg) - into noclass-arglist - finally (return (values noclass-arglist categories)))) (defun actual-array-c-type (category c-arguments &optional map-down) "Replace the declared proto-type with an actual GSL struct type diff --git a/init/defmfun-single.lisp b/init/defmfun-single.lisp index 6f5b9f7a3e8ac01f38058310e14c3cdd6108d9f3..90a7f852ffe74c06754d90b40338de8922ffb5c7 100644 --- a/init/defmfun-single.lisp +++ b/init/defmfun-single.lisp @@ -1,6 +1,6 @@ ;; Helpers that define a single GSL function interface ;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp -;; Time-stamp: <2009-02-25 09:39:03EST defmfun-single.lisp> +;; Time-stamp: <2009-03-31 21:37:38EDT defmfun-single.lisp> ;; $Id: $ (in-package :gsl) @@ -71,17 +71,14 @@ does not have the function defined.")) (defun complete-definition - (definition name arglist gsl-name c-arguments key-args + (defn name arglist gsl-name c-arguments key-args &optional (body-maker 'body-no-optional-arg) (mapdown (eq body-maker 'body-optional-arg))) "A complete definition form, starting with defun, :method, or defmethod." - (destructuring-bind - (&key documentation before after - qualifier gsl-version &allow-other-keys) - key-args + (with-defmfun-key-args key-args (if (have-at-least-gsl-version gsl-version) - `(,definition + `(,defn ,@(when (and name (not (defgeneric-method-p name))) (list name)) ,@(when qualifier (list qualifier)) @@ -90,7 +87,7 @@ (cl-argument-types arglist c-arguments) (set-difference ; find all the unused variables (arglist-plain-and-categories arglist nil) - (union + (remove-duplicates (union (if mapdown (apply 'union (mapcar 'variables-used-in-c-arguments c-arguments)) @@ -100,18 +97,18 @@ (cons 'values (append before after - (when (callback-arg-p - (variables-used-in-c-arguments c-arguments)) - '(function)) ; hardwired name to use for callback + (callback-symbol-set + callback-dynamic callbacks (first callback-dynamic-variables)) (let ((auxstart (position '&aux arglist))) ;; &aux bindings are checked (when auxstart (apply 'append (mapcar 'rest (subseq arglist (1+ auxstart)))))))))))) + (first callback-dynamic-variables)) ,@(when documentation (list documentation)) ,(funcall body-maker name arglist gsl-name c-arguments key-args)) - `(,definition + `(,defn ,@(when (and name (not (defgeneric-method-p name))) (list name)) ,@(when qualifier (list qualifier)) @@ -174,8 +171,9 @@ (first (cl-convert-form it)) sym))) return)) - (mapcan #'cl-convert-form - (callback-remove-arg allocated-decl 'st-symbol)) + (mapcan + #'cl-convert-form + (callback-remove-arg allocated-decl callbacks 'st-symbol)) outputs (unless (eq c-return :void) (list cret-name))))) @@ -183,46 +181,52 @@ '(error 'pass-complex-by-value) ; arglist should be declared ignore (wrap-letlike allocated-decl - (mapcar #'wfo-declare allocated-decl) + (mapcar (lambda (d) (wfo-declare d callbacks)) + allocated-decl) 'cffi:with-foreign-objects - `(,@before - ,@(callback-set-slots allocated callback-struct function) - (let ((,cret-name - (cffi:foreign-funcall - ,gsl-name - ,@(mapcan - (lambda (arg) - (let ((cfind ; variable is complex - (find (st-symbol arg) complex-args :key 'first))) - (if cfind ; make two successive scalars - (passing-complex-by-value cfind) - ;; otherwise use without conversion - (list (if (member (st-symbol arg) allocated) - :pointer - (st-type arg)) - (st-symbol arg))))) - c-arguments) - ,cret-type))) - ,@(case c-return - (:void `((declare (ignore ,cret-name)))) - (:error-code ; fill in arguments - `((check-gsl-status ,cret-name - ',(or (defgeneric-method-p name) name))))) - #-native - ,@(when outputs - (mapcar - (lambda (x) `(setf (cl-invalid ,x) t (c-invalid ,x) nil)) - outputs)) - ,@(when (eq cret-type :pointer) - `((check-null-pointer - ,cret-name - ,@'('memory-allocation-failure "No memory allocated.")))) - ,@after - (values - ,@(defmfun-return - c-return cret-name clret allocated - return return-supplied-p - enumeration outputs))))))))) + `(,@(append + (callback-symbol-set + callback-dynamic callbacks (first callback-dynamic-variables)) + before + (when callback-object (callback-set-dynamic callback-object arglist))) + ,@(callback-set-slots + callbacks callback-dynamic-variables callback-dynamic) + (let ((,cret-name + (cffi:foreign-funcall + ,gsl-name + ,@(mapcan + (lambda (arg) + (let ((cfind ; variable is complex + (find (st-symbol arg) complex-args :key 'first))) + (if cfind ; make two successive scalars + (passing-complex-by-value cfind) + ;; otherwise use without conversion + (list (if (member (st-symbol arg) allocated) + :pointer + (st-type arg)) + (st-symbol arg))))) + c-arguments) + ,cret-type))) + ,@(case c-return + (:void `((declare (ignore ,cret-name)))) + (:error-code ; fill in arguments + `((check-gsl-status ,cret-name + ',(or (defgeneric-method-p name) name))))) + #-native + ,@(when outputs + (mapcar + (lambda (x) `(setf (cl-invalid ,x) t (c-invalid ,x) nil)) + outputs)) + ,@(when (eq cret-type :pointer) + `((check-null-pointer + ,cret-name + ,@'('memory-allocation-failure "No memory allocated.")))) + ,@after + (values + ,@(defmfun-return + c-return cret-name clret allocated + return return-supplied-p + enumeration outputs))))))))) (defun defmfun-return (c-return cret-name clret allocated return return-supplied-p enumeration outputs) diff --git a/init/defmfun.lisp b/init/defmfun.lisp index 8564b623d5c546eb1a7d3e7cc8006a87922fe691..d71fa83e33529204a61945be4e40ec76fa2e4866 100644 --- a/init/defmfun.lisp +++ b/init/defmfun.lisp @@ -1,6 +1,6 @@ ;; Macro for defining GSL functions. ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp -;; Time-stamp: <2009-02-15 18:51:03EST defmfun.lisp> +;; Time-stamp: <2009-03-29 16:28:26EDT defmfun.lisp> ;; $Id$ (in-package :gsl) @@ -58,6 +58,10 @@ ;;; enumeration The name of the enumeration return. ;;; gsl-version The GSL version at which this function was introduced. ;;; switch Switch only the listed optional/key variables (default all of them) +;;; callbacks A list that specifies the callback structure and function(s); see callback.lisp +;;; callback-dynamic Values for callback function(s) set at runtime. The order matches +;;; the functions listed in :callbacks. See callback.lisp for contents. +;;; callback-object Name of the object has callbacks. (defmacro defmfun (name arglist gsl-name c-arguments &rest key-args) "Definition of a GSL function." @@ -74,21 +78,15 @@ (definition :function) (export (not (member definition (list :method :methods)))) documentation inputs outputs before after enumeration qualifier - gsl-version switch (callback-struct 'gsl-function)) + gsl-version switch callbacks callback-dynamic callback-object) ,key-args (declare (ignorable c-return return definition element-types index export documentation inputs outputs before after enumeration qualifier - gsl-version switch callback-struct) - (special indexed-functions)) + gsl-version switch callbacks callback-dynamic callback-object) + (special indexed-functions callback-dynamic-variables)) ,@body)) -(defparameter *defmfun-llk* '(&optional &key &aux) - "Possible lambda-list keywords.") - -(defparameter *defmfun-optk* '(&optional &key) - "Possible optional-argument keywords.") - (defun optional-args-to-switch-gsl-functions (arglist gsl-name) "The presence/absence of optional arguments will switch between the first and second listed GSL function names." @@ -99,11 +97,26 @@ (listp (first gsl-name))))) (defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args) - (let (indexed-functions) + (let (indexed-functions callback-dynamic-variables) ;; workaround for compiler errors that don't see 'indexed-function is used - (declare (ignorable indexed-functions)) + (declare (ignorable indexed-functions callback-dynamic-variables)) (with-defmfun-key-args key-args - (setf indexed-functions (list)) + (setf indexed-functions (list) + callback-dynamic-variables + ;; A list of variable names, and a list of callback names + (when (or callbacks callback-object) + (if callback-object + (let ((class (if (listp callback-object) + (second (first callback-object)) + (category-for-argument arglist callback-object)))) + (list (mobject-fnvnames + class + (number-of-callbacks (get-callbacks-for-class class))) + nil)) + (let ((num-callbacks (number-of-callbacks callbacks))) + (list + (loop repeat num-callbacks collect (gensym "DYNFN")) + (loop repeat num-callbacks collect (gensym "CBFN"))))))) (wrap-index-export (cond ((eq definition :generic) @@ -118,29 +131,29 @@ (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args))) name gsl-name key-args)))) -(defun wrap-index-export (definition name gsl-name key-args) - "Wrap the definition with index and export if requested. +(defun wrap-index-export (expanded-body name gsl-name key-args) + "Wrap the expanded-body with index and export if requested. Use a progn if needed." - (let ((index-export - (with-defmfun-key-args key-args - (if (eq index t) - (setf index name)) - (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm))) - (append - (when index - (if indexed-functions - (mapcar #'mapnfn indexed-functions) - (if (listp gsl-name) - (mapcar #'mapnfn gsl-name) - (list (mapnfn gsl-name))))) - (when export `((export ',name)))))))) - (if index-export - (if (symbolp (first definition)) - `(progn ,definition ,@index-export) - `(progn ,@definition ,@index-export)) - (if (symbolp (first definition)) - definition - `(progn ,definition ,@index-export))))) + (with-defmfun-key-args key-args + (let ((index-export + (progn + (if (eq index t) (setf index name)) + (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm))) + (append + (when index + (if indexed-functions + (mapcar #'mapnfn indexed-functions) + (if (listp gsl-name) + (mapcar #'mapnfn gsl-name) + (list (mapnfn gsl-name))))) + (when export `((export ',name)))))))) + `(progn + ,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body) + ,@(make-defmcallbacks + callbacks + (second callback-dynamic-variables) + (first callback-dynamic-variables)) + ,@index-export)))) ;;;;**************************************************************************** ;;;; A method for a generic function, on any class diff --git a/init/forms.lisp b/init/forms.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ce1c325bdbc362b895a93266b886ca8a57952ce9 --- /dev/null +++ b/init/forms.lisp @@ -0,0 +1,41 @@ +;; Lisp forms +;; Liam Healy 2009-03-07 15:49:25EST forms.lisp +;; Time-stamp: <2009-03-14 18:44:04EDT forms.lisp> + +(in-package :gsl) + +;;;;**************************************************************************** +;;;; Arglists +;;;;**************************************************************************** + +(defparameter *defmfun-llk* '(&optional &key &aux) + "Possible lambda-list keywords.") + +(defparameter *defmfun-optk* '(&optional &key) + "Possible optional-argument keywords.") + +(defun arglist-plain-and-categories + (arglist &optional (include-llk t)) + "Get arglist without classes and a list of categories." + (loop for arg in arglist + with getting-categories = t and categories + do + (when (and getting-categories (member arg *defmfun-llk*)) + (setf getting-categories nil)) + (when (and getting-categories (listp arg)) + ;; Collect categories (classes), but not default values to + ;; optional arugments. + (pushnew (second arg) categories)) + when (or (not (member arg *defmfun-llk*)) include-llk) + collect + (if (listp arg) (first arg) arg) + into noclass-arglist + finally (return (values noclass-arglist categories)))) + +(defun category-for-argument (arglist symbol) + "Find the category (class) for the given argument." + (multiple-value-bind (plain cats) + (arglist-plain-and-categories arglist) + (let ((pos (position symbol plain))) + (when pos + (nth pos cats))))) diff --git a/init/funcallable.lisp b/init/funcallable.lisp new file mode 100644 index 0000000000000000000000000000000000000000..1bb6eb00a81d5bddad31a14afe5a1e9e12a25035 --- /dev/null +++ b/init/funcallable.lisp @@ -0,0 +1,196 @@ +;; Generate a lambda that calls the user function; will be called by callback. +;; Liam Healy +;; Time-stamp: <2009-03-31 22:22:50EDT funcallable.lisp> +;; $Id$ + +(in-package :gsl) + +;;;;**************************************************************************** +;;;; Utility +;;;;**************************************************************************** + +(defun make-symbol-cardinal (name i) + (make-symbol (format nil "~:@(~a~)~d" name i))) + +(defun make-symbol-cardinals (name max-count) + (loop for i from 0 below max-count + collect (make-symbol-cardinal name i))) + +(defun value-from-dimensions (argspec dimension-values &optional total) + "Return a list of numerical sizes for dimensions of an array. If + total = T, then return the product of those dimensions." + ;; (DIM0) -> numerical value + ;; (DIM0 DIM0) -> product of numerical values + (let ((list + (subst (first dimension-values) + 'dim0 + (subst (second dimension-values) + 'dim1 + (parse-callback-argspec argspec 'dimensions))))) + (if total + (apply '* list) list))) + +(defun all-io (direction &optional (arrays t)) + "Create a function that returns dimensions for argspecs that are arrays + for the specified direction." + (if arrays + (lambda (arg) + (and (listp arg) + (eql (parse-callback-argspec arg 'io) direction) + (parse-callback-argspec arg 'dimensions))) + (lambda (arg) + (and (listp arg) + (eql (parse-callback-argspec arg 'io) direction))))) + +(defun vspecs-direction (argspecs direction &optional array-only) + "Find the specs for all variables, or all array variables, with the + specified direction." + (remove-if-not + (lambda (arg) + (when + (and (eql (parse-callback-argspec arg 'io) direction) + (if array-only (parse-callback-argspec arg 'dimensions) t)) + arg)) + argspecs)) + +;;;;**************************************************************************** +;;;; Reference foreign elements and make multiple-value-bind form +;;;;**************************************************************************** + +(defun reference-foreign-element + (foreign-variable-name linear-index argspec dimension-values) + "Form to reference, for getting or setting, the element of a foreign + array, or a scalar." + (if (parse-callback-argspec argspec 'dimensions) + (if (eql (parse-callback-argspec argspec 'array-type) :marray) + `(maref + ,foreign-variable-name + ,@(let ((dims (value-from-dimensions argspec dimension-values))) + (if (= (length dims) 2) ; matrix + (multiple-value-list + (floor linear-index + (first dims))) + (list linear-index nil))) + ',(cffi-cl (parse-callback-argspec argspec 'element-type))) + `(cffi:mem-aref + ,foreign-variable-name + ',(parse-callback-argspec argspec 'element-type) + ,linear-index)) + ;; not setfable if it's a scalar + foreign-variable-name)) + +(defun array-element-refs (names argspecs dimension-values) + "A list of forms reference each array element in succession. + If there is no argspec for the argument, just reference the variable itself." + (if argspecs + (loop for arg in argspecs + for count = (when arg (value-from-dimensions arg dimension-values t)) + for name in names + append + (if arg + (loop for i from 0 below count + collect (reference-foreign-element name i arg dimension-values)) + (list name))) + names)) + +(defun callback-set-mvb (argument-names form fnspec dimension-values) + "Create the multiple-value-bind form in the callback to set the return C arrays." + (let* ((setargs ; arguments that are arrays being set + (remove-if-not + (all-io :output) + (parse-callback-fnspec fnspec 'arguments-spec))) + (counts ; number of scalars for each set arg + (mapcar (lambda (arg) (value-from-dimensions arg dimension-values t)) + setargs)) + (count ; total number of scalars set + (apply '+ counts)) + (mvbvbls ; the symbols to be multiple-value-bound + (loop for i from 0 below count + collect (make-symbol-cardinal 'setscalar i))) + (setvbls (array-element-refs argument-names setargs dimension-values))) + (if (zerop count) + form + `(multiple-value-bind ,mvbvbls + ,form + (setf ,@(loop for count in counts + with svs = (copy-list setvbls) + and mvv = (copy-list mvbvbls) + append + (loop for i from 0 below count + append (list (pop svs) (pop mvv))))))))) + + +;;;;**************************************************************************** +;;;; Create a lambda form suitable for call by defmcallback +;;;;**************************************************************************** + +(defun make-funcallable-form (user-function fnspec scalarsp dimension-values) + "Define a wrapper function to interface GSL with the user's function. + scalarsp will be either T or NIL, depending on whether the user function + expects and returns scalars, and dimension-values should be a list + of number(s), (dim0) or (dim0 dim1), or NIL." + (let* ((argspecs (remove :slug (parse-callback-fnspec fnspec 'arguments-spec))) + (inargs-specs (vspecs-direction argspecs :input)) + (inargs-names + (make-symbol-cardinals + 'input + (length (remove nil (mapcar (all-io :input nil) argspecs))))) + (outarrayp (vspecs-direction argspecs :output t)) + (outargs-names (make-symbol-cardinals 'output (length outarrayp))) + (lambda-args + (loop for arg in argspecs + with oarg = (copy-list outargs-names) + and iarg = (copy-list inargs-names) + append + (if (and (eql (parse-callback-argspec arg 'io) :output) + (parse-callback-argspec arg 'array-type)) + (list (pop oarg)) + (if (eql (parse-callback-argspec arg 'io) :input) + (list (pop iarg)))))) + (function-designator + (if (symbolp user-function) + (let ((uf user-function)) `',uf) + user-function))) + `(lambda ,lambda-args + ,(if (and scalarsp (or inargs-specs outarrayp)) + (let ((call-form + `(funcall + ,function-designator + ,@(array-element-refs inargs-names inargs-specs dimension-values)))) + (if outarrayp + (callback-set-mvb outargs-names call-form fnspec dimension-values) + ;; no specified output, return what the function returns + call-form)) + `(funcall ,function-designator + ,@(if outarrayp + (append inargs-names outargs-names) + ;; no arrays to return, just return the value + inargs-names))) + ,@(case + (parse-callback-fnspec fnspec 'return-spec) + (:success-failure + ;; We always return success, because if there is a + ;; problem, a CL error should be signalled. + '(+success+)) + (:pointer + ;; For unclear reasons, some GSL functions want callbacks + ;; to return a void pointer which is apparently meaningless. + '((cffi:null-pointer))) + ;; If it isn't either of these things, return what the + ;; function returned. + (otherwise nil))))) + +(defun make-funcallables-for-object (object) + "Make compiled functions for the object that can be funcalled in the callback." + (setf + (slot-value object 'funcallables) + (mapcar + (lambda (fn fnspec) + (compile + nil + (make-funcallable-form fn fnspec (scalarsp object) (dimensions object)))) + (functions object) + (parse-callback-static (callbacks object) 'functions)))) + +(defun make-compiled-funcallable (function fnspec scalarsp dimensions) + (compile nil (make-funcallable-form function fnspec scalarsp dimensions))) diff --git a/init/interface.lisp b/init/interface.lisp index 1fd5b8c540a71a3712ba74936d9c735050a4d5b1..13f200ad222ae4eb32b683e36569dde76f94858c 100644 --- a/init/interface.lisp +++ b/init/interface.lisp @@ -1,6 +1,6 @@ ;; Macros to interface GSL functions, including definitions necessary for defmfun. ;; Liam Healy -;; Time-stamp: <2009-03-23 12:14:14EDT interface.lisp> +;; Time-stamp: <2009-03-31 22:51:22EDT interface.lisp> ;; $Id$ (in-package :gsl) @@ -59,12 +59,13 @@ (defun st-pointer-last-p (decl) (third (st-type decl))) -(defun wfo-declare (d) +(defun wfo-declare (d callbacks) `(,(st-symbol d) ,@(if (st-arrayp d) `(',(st-eltype d) ,(st-dim d)) - (if (eq (st-symbol d) +callback-argument-name+) - '('gsl-function) + (if (eq (st-symbol d) + (parse-callback-static callbacks 'foreign-argument)) + `(',(parse-callback-static callbacks 'callback-structure-type)) `(',(st-type d)))))) ;;;;**************************************************************************** @@ -107,12 +108,13 @@ (when (and cl-type (member (st-symbol sd) (cl-symbols cl-arguments))) (list (list (st-symbol sd) cl-type))))) -(defun declaration-form (cl-argument-types &optional ignores) +(defun declaration-form (cl-argument-types &optional ignores specials) (cons 'declare (append (mapcar (lambda (v) (cons 'type (reverse v))) cl-argument-types) - (when ignores (list (cons 'ignore ignores)))))) + (when ignores (list (cons 'ignore ignores))) + (when specials (list (cons 'special specials)))))) ;;;;**************************************************************************** ;;;; Returns diff --git a/init/mobject.lisp b/init/mobject.lisp index 897f7738ec875e7741f13fd73cae0cb5837dc74e..1d57c02f98f4afa5fd13db2e0c29c7f6ef1a887d 100644 --- a/init/mobject.lisp +++ b/init/mobject.lisp @@ -1,6 +1,6 @@ ;; Definition of GSL objects and ways to use them. ;; Liam Healy, Sun Dec 3 2006 - 10:21 -;; Time-stamp: <2009-03-20 17:22:22EDT mobject.lisp> +;; Time-stamp: <2009-03-29 23:04:45EDT mobject.lisp> ;;; GSL objects are represented in GSLL as and instance of a 'mobject. ;;; The macro demobject takes care of defining the appropriate @@ -19,22 +19,51 @@ ((mpointer :initarg :mpointer :reader mpointer :documentation "A pointer to the GSL representation of the object."))) -(defconstant +callback-argument-name+ 'callback) +;;; Required arguments for defmobject: +;;; class Name of class being made. +;;; prefix String that starts each GSL function name +;;; allocation-args Arguments used in the allocation (initialization) +;;; description Short string describing class + +;;; Key arguments for defmobject: +;;; documentation +;;; Docstring for the object maker. +;;; initialize-suffix +;;; The string appended to prefix to form GSL function name or a list of +;;; such a string and the c-return argument. +;;; initialize-name +;;; A string with the name of the GSL function for initialization; defaults to +;;; prefix + initialize-suffix. +;;; initialize-args +;;; arglists-function +;;; A function of one symbol, a flag indicating that an optional +;;; argument has been set. It returns a list of three forms: the +;;; arglists for the maker defun, the arguments that will be applied +;;; therein to the inititializer and to the reinitializer. +;;; inputs, gsl-version +;;; Defmfun arguments for reinitializer. +;;; allocator +;;; allocate-inputs +;;; freer +;;; class-slots-instance +;;; callbacks +;;; See callbacks.lisp +;;; superclasses +;;; List of superclasses other than 'mobject. +;;; singular +;;; Where a list of several objects like 'functions is specified, this permits +;;; a single one with the singular form, like 'function. (defmacro defmobject (class prefix allocation-args description &key documentation initialize-suffix initialize-name initialize-args arglists-function inputs gsl-version allocator allocate-inputs freer - (superclasses '(mobject)) - class-slots-instance ci-class-slots singular) + class-slots-instance callbacks + (superclasses (if callbacks '(callback-included) '(mobject))) + singular) "Define the class, the allocate, initialize-instance and reinitialize-instance methods, and the make-* function for the GSL object." - ;; Argument 'initialize-suffix: string appended to prefix to form - ;; GSL function name or a list of such a string and the c-return - ;; argument. (let* ((settingp (make-symbol "SETTINGP")) - (callbackp - (member-if (lambda (cl) (subtypep cl 'callback-included)) superclasses)) (arglists (when arglists-function (funcall (coerce arglists-function 'function) settingp))) @@ -42,19 +71,21 @@ (cl-alloc-args (variables-used-in-c-arguments allocation-args)) (cl-initialize-args (callback-replace-arg - 'functions (variables-used-in-c-arguments initialize-args))) - (initializerp (or initialize-name initialize-suffix)) - (initargs ; arguments that are exclusively for reinitialize-instance - (remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args))) + 'functions + (variables-used-in-c-arguments initialize-args) + callbacks)) + (initializerp (or initialize-name initialize-suffix))) + ;; Need callback information for macroexpansion make-cbstruct-object + (when callbacks (record-callbacks-for-class class callbacks)) (if (have-at-least-gsl-version gsl-version) `(progn - ,(if callbackp + ,(if callbacks `(,(if (member 'dimensions cl-alloc-args) 'def-ci-subclass 'def-ci-subclass-1d) ,class ,superclasses ,(format nil "The GSL representation of the ~a." description) - ,@ci-class-slots) + ,(parse-callback-static callbacks 'dimension-names)) `(defclass ,class ,superclasses nil (:documentation @@ -74,13 +105,16 @@ (make-reinitialize-instance class cl-initialize-args initialize-name prefix initialize-suffix initialize-args inputs - (and callbackp - (not (callback-arg-p class-slots-instance))))) + (and (not (callback-arg-p class-slots-instance callbacks)) + callbacks) + superclasses)) (export '(,maker ,class)) + ,@(when callbacks `((record-callbacks-for-class ',class ',callbacks))) + ,@(when callbacks (make-mobject-defmcallbacks callbacks class)) ,(mobject-maker - maker arglists initargs class cl-alloc-args cl-initialize-args + maker arglists class cl-alloc-args cl-initialize-args description documentation initialize-args initializerp settingp - singular class-slots-instance)) + singular class-slots-instance callbacks)) `(progn (export ',maker) (defun ,maker (&rest args) @@ -109,31 +143,35 @@ (defun make-reinitialize-instance (class cl-initialize-args initialize-name prefix initialize-suffix initialize-args inputs - callback) - "Expand the reinitialize-instance form. In the GSL arglist, the callback - structure pointer should be named the value of +callback-argument-name+." + callbacks superclasses) + "Expand the reinitialize-instance form." (let ((cbstruct (make-symbol "CBSTRUCT"))) `((defmfun reinitialize-instance ((object ,class) &key ,@cl-initialize-args - ,@(when callback - `(&aux (,cbstruct (make-cbstruct-object object))))) + ,@(when callbacks + `(&aux (,cbstruct ,(make-cbstruct-object class))))) ,(or initialize-name (format nil "~a_~a" prefix (if (listp initialize-suffix) (first initialize-suffix) initialize-suffix))) (((mpointer object) :pointer) - ,@(callback-replace-arg cbstruct initialize-args)) + ,@(callback-replace-arg cbstruct initialize-args callbacks)) :definition :method + ,@(when callbacks '(:callback-object object)) :qualifier :after ,@(when (and initialize-suffix (listp initialize-suffix)) `(:c-return ,(second initialize-suffix))) :return (object) ,@(when inputs `(:inputs ,inputs)) - ,@(when callback - `(:after + ,@(when callbacks + `(:before + (,@(when (member 'callback-included-cl superclasses) + `((setf (slot-value object 'callback) ,cbstruct))) + (make-funcallables-for-object object)) + :after ((trivial-garbage:finalize object (lambda () @@ -142,53 +180,67 @@ :index (reinitialize-instance ,class))))) (defun mobject-maker - (maker arglists initargs class cl-alloc-args cl-initialize-args + (maker arglists class cl-alloc-args cl-initialize-args description documentation initialize-args initializerp settingp - singular class-slots-instance) + singular class-slots-instance callbacks) "Make the defun form that makes the mobject." - `(defun ,maker - ,(if arglists - (first arglists) - (singularize - singular - `(,@cl-alloc-args - ,@(callback-replace-arg 'functions class-slots-instance) - ,@(when initargs - (append - (list - '&optional (list (first initargs) nil settingp)) - (rest initargs)))))) - ,(format - nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]" - description class documentation) - (let ((object - (make-instance - ',class - ,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance)) - ,@(when (callback-arg-p class-slots-instance) - (symbol-keyword-symbol 'functions)) - ,@(if arglists - (second arglists) - (symbol-keyword-symbol cl-alloc-args singular))))) - ;; There is callback slot variable - ,@(when (callback-arg-p class-slots-instance) - (with-unique-names (cbs) - `((let ((,cbs (make-cbstruct-object object))) - (setf (slot-value object ',+callback-argument-name+) ,cbs) - (tg:finalize object (lambda () (foreign-free ,cbs))))))) - ;; There is an initialization step - ,@(when initializerp - (if initialize-args ; with arguments - (let ((reii - `(reinitialize-instance - object - ,@(if arglists - (third arglists) - (symbol-keyword-symbol - cl-initialize-args singular))))) - (if initargs `((when ,settingp ,reii)) `(,reii))) - '((reinitialize-instance object)))) ; without arguments - object))) + (when callbacks + (setf cl-initialize-args (append cl-initialize-args '((scalarsp t))))) + (let ((initargs ; arguments that are exclusively for reinitialize-instance + (remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args))) + `(defun ,maker + ,(if arglists + (first arglists) + (singularize + singular + `(,@cl-alloc-args + ,@(callback-replace-arg + 'functions class-slots-instance callbacks) + ,@(when initargs + (append + (list + '&optional + (if (listp (first initargs)) + `(,@(first initargs) ,settingp) + `(,(first initargs) nil ,settingp))) + (rest initargs)))))) + ,(format + nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]" + description class documentation) + (let ((object + (make-instance + ',class + ,@(when callbacks `(:callbacks ',callbacks)) + ,@(symbol-keyword-symbol + (callback-remove-arg class-slots-instance callbacks)) + ,@(when (callback-arg-p class-slots-instance callbacks) + (symbol-keyword-symbol 'functions)) + ,@(if arglists + (second arglists) + (symbol-keyword-symbol cl-alloc-args singular))))) + ;; There is callback slot variable + ,@(when (callback-arg-p class-slots-instance callbacks) + (with-unique-names (cbs) + `((let ((,cbs ,(make-cbstruct-object class))) + (setf (slot-value + object + ',(parse-callback-static callbacks 'foreign-argument)) + ,cbs) + (tg:finalize object (lambda () (foreign-free ,cbs))))))) + ;; There is an initialization step + ,@(when initializerp + (if (or initialize-args arglists) ; with arguments + (let ((reii + `(reinitialize-instance + object + ,@(if arglists + (third arglists) + (symbol-keyword-symbol + (arglist-plain-and-categories cl-initialize-args) + singular))))) + (if initargs `((when ,settingp ,reii)) `(,reii))) + '((reinitialize-instance object)))) ; without arguments + object)))) (defun plural-symbol (symbol) "Make the plural form of this symbol." diff --git a/ordinary-differential-equations/evolution.lisp b/ordinary-differential-equations/evolution.lisp index 49839b6ac422c0a08e1a85c44cb8c3dc3605b19e..fc20dab55dc451b84fe07cbfeba536e74ddd95c9 100644 --- a/ordinary-differential-equations/evolution.lisp +++ b/ordinary-differential-equations/evolution.lisp @@ -1,6 +1,6 @@ ;; Evolution functions for ODE integration. ;; Liam Healy, Sun Sep 30 2007 - 14:31 -;; Time-stamp: <2009-02-15 08:58:47EST evolution.lisp> +;; Time-stamp: <2009-03-29 16:25:04EDT evolution.lisp> ;; $Id$ (in-package :gsl) @@ -22,6 +22,7 @@ ((c-pointer step-size) :pointer) ((c-pointer y) :pointer)) :inputs (time step-size y) :outputs (time step-size y) + :callback-object ((stepper ode-stepper)) :documentation ; FDL "Advance the system (e, dydt) from time and position y using the stepping function step. @@ -33,4 +34,3 @@ changed the value of step-size will be modified on output. The maximum time max-time is guaranteed not to be exceeded by the time-step. On the final time-step the value of time will be set to t1 exactly.") - diff --git a/ordinary-differential-equations/ode-example.lisp b/ordinary-differential-equations/ode-example.lisp index 2710ac8ee2226a9a3ff10fb6819aec4b402a5dca..69fc49500290c7c17265b6ddeaf9945351352199 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-02-16 10:18:29EST ode-example.lisp> +;; Time-stamp: <2009-03-29 22:51:51EDT ode-example.lisp> ;; $Id$ ;;; van der Pol as given in Section 25.5 of the GSL manual. To @@ -26,8 +26,6 @@ (defparameter *max-iter* 2000) -(make-callbacks ode-stepper vanderpol vanderpol-jacobian 2) - (defun integrate-vanderpol (max-time &optional (step-size 1.0d-6) (stepper +step-rk8pd+) (print-steps t)) "Integrate the van der Pol oscillator as given in Section 25.5 of the @@ -35,8 +33,8 @@ (let ((mu 10.0d0) (initial-time 0.0d0) (iter 0)) (declare (special mu)) (with-ode-integration - ((vanderpol vanderpol-jacobian) - time step max-time (dep0 dep1) 2 stepper) + (vanderpol time step max-time (dep0 dep1) 2 + :jacobian vanderpol-jacobian :stepper stepper) (setf dep0 1.0d0 dep1 0.0d0 step step-size time initial-time) (loop (when (or (>= time max-time) (> iter *max-iter*)) diff --git a/ordinary-differential-equations/ode-system.lisp b/ordinary-differential-equations/ode-system.lisp index 62caf58616e92549f602790306b62d9ca4fac750..73a9196cd015b656fc1b26a14650dd2294ab96e6 100644 --- a/ordinary-differential-equations/ode-system.lisp +++ b/ordinary-differential-equations/ode-system.lisp @@ -1,30 +1,26 @@ ;; ODE system setup ;; Liam Healy, Sun Apr 15 2007 - 14:19 -;; Time-stamp: <2009-02-23 09:35:27EST ode-system.lisp> +;; Time-stamp: <2009-03-29 22:54:21EDT ode-system.lisp> ;; $Id$ (in-package :gsl) -(cffi:defcstruct ode-system ; gsl_odeiv_system - ;; See /usr/include/gsl/gsl_odeiv.h - "The definition of an ordinary differential equation system for GSL." - (function :pointer) - (jacobian :pointer) - (dimension sizet) - (parameters :pointer)) - (export '(with-ode-integration)) (defmacro with-ode-integration - ((function time step-size max-time - dependent dimensions &optional (stepper '+step-rk8pd+) + ((function time step-size max-time dependent dimensions + &key jacobian (scalarsp t) (stepper '+step-rk8pd+) (absolute-error 1.0d-6) (relative-error 0.0d0)) &body body) "Environment for integration of ordinary differential equations." + ;; Note: the case jacobian=nil is not properly handled yet; it + ;; should put a null pointer into the struct that is passed to GSL. (let ((dep (make-symbol "DEP")) (ctime (make-symbol "CTIME")) (cstep (make-symbol "CSTEP"))) - `(let ((stepperobj (make-ode-stepper ,stepper ,dimensions ',function)) + `(let ((stepperobj + (make-ode-stepper + ,stepper ,dimensions ',function ',jacobian ,scalarsp)) (control (make-y-control ,absolute-error ,relative-error)) (evolve (make-ode-evolution ,dimensions)) (,dep diff --git a/ordinary-differential-equations/stepping.lisp b/ordinary-differential-equations/stepping.lisp index 5c7679e2a3f78e8a9b91634ce18a226654482615..ad8637260f4c651e5a44e8d784b9a6c20ba20a07 100644 --- a/ordinary-differential-equations/stepping.lisp +++ b/ordinary-differential-equations/stepping.lisp @@ -1,8 +1,10 @@ ;; Stepping functions for ODE systems. ;; Liam Healy, Mon Sep 24 2007 - 21:33 -;; Time-stamp: <2009-02-16 09:57:47EST stepping.lisp> +;; Time-stamp: <2009-03-31 22:33:39EDT stepping.lisp> ;; $Id$ +;; /usr/include/gsl/gsl_odeiv.h + (in-package :gsl) (defmobject ode-stepper "gsl_odeiv_step" @@ -15,11 +17,35 @@ should be reinitialized whenever the next use of it will not be a continuation of a previous step." :superclasses (callback-included-cl) - :ci-class-slots (ode-system marray (function jacobian) (dimension)) - :class-slots-instance (#.+callback-argument-name+) + :callbacks + (callback ode-system + (dimension) + (function :success-failure + (:input :double) ; t (independent variable) + (:input :double :cvector dim0) ; y (dependent variables) + (:output :double :cvector dim0) ; dydt + :slug) + (jacobian :success-failure + (:input :double) ; t (independent variable) + (:input :double :cvector dim0) ; y (dependent variables) + (:output :double :cvector dim0 dim0) ; dfdy + (:output :double :cvector dim0) ; dydt + :slug)) :initialize-suffix "reset" :initialize-args nil - :singular (dimension)) + :arglists-function + (lambda (set) + `((type dimension &optional (function nil ,set) jacobian (scalarsp t)) + (:type type :dimensions (list dimension)) + (:functions (list function jacobian) :scalarsp scalarsp)))) + +(cffi:defcstruct ode-system ; gsl_odeiv_system + "The definition of an ordinary differential equation system for GSL." + (function :pointer) + (jacobian :pointer) + (dimension sizet) + (parameters :pointer)) + #| This description applies when scalars=t: @@ -51,33 +77,6 @@ values): `d f_N / d y_1' `d f_N / d y_2' ... `d f_N / d y_N') |# -(def-make-callbacks ode-stepper - (function jacobian dimension &optional (scalars t)) - (if scalars - `(progn - (defmcallback ,function - :success-failure - (:double (:double ,dimension) (:set :double ,dimension)) - nil nil - ,function) - (defmcallback ,jacobian - :success-failure - (:double - (:double ,dimension) - (:set :double ,(expt dimension 2)) - (:set :double ,dimension)) - nil nil ,jacobian)) - `(progn - (defmcallback ,function - :success-failure - (:double :pointer :pointer) - nil nil - ,function) - (defmcallback ,jacobian - :success-failure - (:double :pointer :pointer :pointer) - nil nil ,jacobian)))) - (defmfun name ((object ode-stepper)) "gsl_odeiv_step_name" (((mpointer object) :pointer)) diff --git a/solve-minimize-fit/generic.lisp b/solve-minimize-fit/generic.lisp index 882422c734fd195b31d66f361ebe584cb0ffae25..f660c773b5df98439f091d91d1c24c6750dbec92 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-02-21 16:47:51EST generic.lisp> +;; Time-stamp: <2009-03-21 23:52:17EDT generic.lisp> ;; $Id: $ (in-package :gsl) @@ -34,7 +34,7 @@ ;; See /usr/include/gsl/gsl_multiroots.h "The definition of a function for multiroot finding in GSL." (function :pointer) - (dimensions sizet) + (dimension sizet) (parameters :pointer)) (cffi:defcstruct gsl-mfunction-fdf @@ -44,7 +44,7 @@ (function :pointer) (df :pointer) (fdf :pointer) - (dimensions sizet) + (dimension sizet) (parameters :pointer)) ;;;;**************************************************************************** diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp index a7038f3b768d42a8b29fee49b71f36fff3039744..c7938b816571297d966aeb516951808940ad6780 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-03-19 11:19:31EDT minimization-multi.lisp> +;; Time-stamp: <2009-03-29 12:43:30EDT minimization-multi.lisp> ;; $Id$ (in-package :gsl) @@ -37,28 +37,15 @@ the function starting from the initial point. The size of the initial trial steps is given in vector step-size. The precise meaning of this parameter depends on the method used." - :superclasses (callback-included) - :ci-class-slots (gsl-mfunction marray (function)) + :callbacks + (callback gsl-mfunction (dimension) + (function :double (:input :double :marray dim0) :slug)) :initialize-suffix "set" :initialize-args ;; Could have one fewer argument: dimension=(dim0 initial) ((callback :pointer) ((mpointer initial) :pointer) ((mpointer step-size) :pointer)) :singular (dimension function)) -(def-make-callbacks - multi-dimensional-minimizer-f (function dimension &optional (scalars t)) - (if scalars - `(defmcallback ,function - :double - ((:double ,dimension)) - nil t - ,function) - `(defmcallback ,function - :double - (:pointer) - nil t - ,function))) - (defmobject multi-dimensional-minimizer-fdf "gsl_multimin_fdfminimizer" ((type :pointer) ((first dimensions) sizet)) @@ -74,37 +61,22 @@ gradient of the function g is orthogonal to the current search direction p to a relative accuracy of tolerance, where dot(p,g) < tol |p| |g|." - :superclasses (callback-included) - :ci-class-slots (gsl-mfunction-fdf marray (function df fdf)) + :callbacks + (callback gsl-mfunction-fdf (dimension) + (function :double (:input :double :marray dim0) :slug) + (df :void + (:input :double :marray dim0) :slug + (:output :double :marray dim0 dim0)) + (fdf :void + (:input :double :marray dim0) :slug + (:output :double :cvector dim0) + (:output :double :marray dim0 dim0))) :initialize-suffix "set" :initialize-args ((callback :pointer) ((mpointer initial) :pointer) (step-size :double) (tolerance :double)) :singular (dimension)) -(def-make-callbacks - multi-dimensional-minimizer-fdf - (function df fdf dimension &optional (scalars t)) - ;; If scalars=T, assume scalars are sent and returned from the functions. - ;; Otherwise, marrays are. - ;; Though the definition of struct gsl_multimin_function_fdf_struct - ;; says that they functions return pointers to :double, :void and :void - ;; resepctively, CFFI converts the double to a pointer to a double. - (if scalars - `(progn - (defmcallback ,function :double ((:double ,dimension)) nil t ,function) - (defmcallback ,df :void - ((:double ,dimension)) ((:set :double ,dimension ,dimension)) - t ,df) - (defmcallback ,fdf :void - ((:double ,dimension)) - ((:set :double -1) (:set :double ,dimension ,dimension)) - t ,fdf)) - `(progn - (defmcallback ,function :double :pointer nil t ,function) - (defmcallback ,df :void :pointer (:pointer) t ,df) - (defmcallback ,fdf :void :pointer ((:set :double -1) :pointer) t ,fdf)))) - (defmfun name ((minimizer multi-dimensional-minimizer-f)) "gsl_multimin_fminimizer_name" (((mpointer minimizer) :pointer)) @@ -129,6 +101,7 @@ "gsl_multimin_fminimizer_iterate" (((mpointer minimizer) :pointer)) :definition :method + :callback-object minimizer :documentation ; FDL "Perform a single iteration of the minimizer. If the iteration encounters an unexpected problem then an error code will be @@ -138,6 +111,7 @@ "gsl_multimin_fdfminimizer_iterate" (((mpointer minimizer) :pointer)) :definition :method + :callback-object minimizer :documentation ; FDL "Perform a single iteration of the minimizer. If the iteration encounters an unexpected problem then an error code will be @@ -147,6 +121,7 @@ "gsl_multimin_fminimizer_x" (((mpointer minimizer) :pointer)) :definition :method + :callback-object minimizer :c-return (crtn :pointer) :return ((copy crtn)) :documentation ; FDL @@ -156,6 +131,7 @@ "gsl_multimin_fdfminimizer_x" (((mpointer minimizer) :pointer)) :definition :method + :callback-object minimizer :c-return (crtn :pointer) :return ((copy crtn)) :documentation ; FDL @@ -373,8 +349,6 @@ (* 20 (expt (- y dp1) 2)) 30))) -(make-callbacks multi-dimensional-minimizer-f paraboloid-scalar 2 t) - (defun multimin-example-no-derivative (&optional (method +simplex-nelder-mead-on2+) (print-steps t)) (let ((step-size (make-marray 'double-float :dimensions 2))) @@ -405,8 +379,7 @@ ;;; Example using derivatives, taking a vector argument. ;;; Note that these functions are written to read objects of ;;; vector-double-float. They could as well have been written to -;;; accept the correct number of scalar double-floats, in which case -;;; the last argument to the make-callbacks form would be t. +;;; accept the correct number of scalar double-floats. (defun paraboloid-vector (gsl-vector) "A paraboloid function of two arguments, given in GSL manual Sec. 35.4. @@ -430,16 +403,14 @@ (maref derivative-gv-pointer 1) (* 40 (- y dp1))))) -(defun paraboloid-and-derivative (arguments-gv-pointer derivative-gv-pointer) +(defun paraboloid-and-derivative + (arguments-gv-pointer value-pointer derivative-gv-pointer) (prog1 - (paraboloid-vector arguments-gv-pointer) + (setf (dcref value-pointer) + (paraboloid-vector arguments-gv-pointer)) (paraboloid-derivative arguments-gv-pointer derivative-gv-pointer))) -(make-callbacks - multi-dimensional-minimizer-fdf - paraboloid-vector paraboloid-derivative paraboloid-and-derivative 2 nil) - (defun multimin-example-derivative (&optional (method +conjugate-fletcher-reeves+) (print-steps t)) (let* ((initial #m(5.0d0 7.0d0)) @@ -447,7 +418,7 @@ (make-multi-dimensional-minimizer-fdf method 2 '(paraboloid-vector paraboloid-derivative paraboloid-and-derivative) - initial 0.01d0 1.0d-4))) + initial 0.01d0 1.0d-4 nil))) (loop with status = T 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 1f8fa9c0b2174f163aa26c545dfc95d80338604b..b1bd0037ac783881703b62bb64fc1c7e912fa46c 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-02-16 09:55:06EST minimization-one.lisp> +;; Time-stamp: <2009-03-29 12:13:30EDT minimization-one.lisp> ;; $Id$ (in-package :gsl) @@ -17,11 +17,11 @@ ((type :pointer)) "one-dimensional minimizer" :documentation ; FDL - "Make an instance of a minimizer of the given type. Optionally + "Make an instance of a minimizer of tphe given type. Optionally set to use the function and the initial search interval [lower, upper], with a guess for the location of the minimum." - :superclasses (callback-included) - :ci-class-slots (gsl-function nil (function)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) :initialize-suffix "set" ; should use set_with_values? :initialize-args ((callback :pointer) (minimum :double) (lower :double) (upper :double)) @@ -57,6 +57,7 @@ (((mpointer minimizer) :pointer)) :definition :method :c-return :success-continue + :callback-object minimizer :documentation ; FDL "Perform a single iteration of the minimizer. The following errors may be signalled: 'bad-function-supplied, @@ -180,19 +181,13 @@ ;;; This is the example given in Sec. 33.8. The results are different ;;; than given there. -(defun minimization-one-fn (x) - (1+ (cos x))) - -(make-callbacks single-function minimization-one-fn) - (defun minimization-one-example (&optional (minimizer-type +brent-fminimizer+) (print-steps t)) "Solving a minimum, the example given in Sec. 33.8 of the GSL manual." (let ((max-iter 100) (minimizer (make-one-dimensional-minimizer - minimizer-type 'minimization-one-fn - 2.0d0 0.0d0 6.0d0))) + minimizer-type (lambda (x) (1+ (cos x))) 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 4802598c9964633e1b40d04200505c844d498e4c..583dab1ce1e1c036f3bedb62f6b2b78b7bcd113a 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-03-19 11:13:41EDT nonlinear-least-squares.lisp> +;; Time-stamp: <2009-03-29 12:42:59EDT nonlinear-least-squares.lisp> ;; $Id$ (in-package :gsl) @@ -21,9 +21,13 @@ "nonlinear least squares fit with function only" :documentation ; FDL "The number of observations must be greater than or equal to parameters." - :superclasses (callback-included) - :ci-class-slots - (gsl-ffit-function nil (function) (number-of-observations number-of-parameters)) + :callbacks + (callback gsl-ffit-function + (number-of-observations number-of-parameters) + (function + :success-failure + (:input :double :marray dim1) :slug + (:output :double :marray dim0))) :initialize-suffix "set" :initialize-args ((callback :pointer) ((mpointer initial-guess) :pointer)) :singular (function)) @@ -36,17 +40,6 @@ (number-of-parameters sizet) (parameters :pointer)) -(def-make-callbacks nonlinear-ffit - (function number-of-observations number-of-parameters &optional (scalars t)) - (if scalars - `(defmcallback ,function - :success-failure - (:double ,number-of-parameters) - ((:double ,number-of-observations)) - t ,function) - `(defmcallback ,function - :success-failure :pointer :pointer nil ,function))) - (defmfun name ((solver nonlinear-ffit)) "gsl_multifit_fsolver_name" (((mpointer solver) :pointer)) @@ -67,10 +60,22 @@ :documentation ; FDL "The number of observations must be greater than or equal to parameters." - :superclasses (callback-included) - :ci-class-slots - (gsl-fdffit-function marray (function df fdf) - (number-of-observations number-of-parameters)) + :callbacks + (callback gsl-fdffit-function + (number-of-observations number-of-parameters) + (function :success-failure + (:input :double :marray dim1) + :slug + (:output :double :marray dim0)) + (df :success-failure + (:input :double :marray dim1) + :slug + (:output :double :marray dim0 dim1)) + (fdf :success-failure + (:input :double :marray dim1) + :slug + (:output :double :marray dim0) + (:output :double :marray dim0 dim1))) :initialize-suffix "set" :initialize-args ((callback :pointer) ((mpointer initial-guess) :pointer))) @@ -96,34 +101,6 @@ (number-of-parameters sizet) (parameters :pointer)) -(def-make-callbacks nonlinear-fdffit - (function df fdf &optional number-of-observations number-of-parameters) - (if number-of-observations - (cl-utilities:once-only (number-of-parameters number-of-observations) - `(progn - (defmcallback ,function - :success-failure - (:double ,number-of-parameters) - ((:double ,number-of-observations)) - t ,function) - (defmcallback ,df - :success-failure - (:double ,number-of-parameters) - ((:double ,number-of-observations ,number-of-parameters)) - t ,df) - (defmcallback ,fdf - :success-failure - (:double ,number-of-parameters) - ((:double ,number-of-observations) - (:double ,number-of-observations ,number-of-parameters)) - t ,fdf))) - `(progn - (defmcallback ,function - :success-failure :pointer :pointer nil ,function) - (defmcallback ,df :success-failure :pointer :pointer nil ,df) - (defmcallback - ,fdf :success-failure :pointer (:pointer :pointer) nil ,fdf)))) - (defmfun name ((solver nonlinear-fdffit)) "gsl_multifit_fdfsolver_name" (((mpointer solver) :pointer)) @@ -377,11 +354,6 @@ (exponential-residual x f) (exponential-residual-derivative x jacobian)) -(make-callbacks - nonlinear-fdffit - exponential-residual exponential-residual-derivative - exponential-residual-fdf) - (defun norm-f (fit) "Find the norm of the fit function f." (euclidean-norm (function-value fit))) @@ -402,7 +374,7 @@ (list number-of-observations number-of-parameters) '(exponential-residual exponential-residual-derivative exponential-residual-fdf) - init))) + init nil))) (macrolet ((fitx (i) `(maref (solution fit) ,i)) (err (i) `(sqrt (maref covariance ,i ,i)))) (when print-steps diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp index 0516f0801c4b22405b112d220e30942013012787..c0ab5aa99b3a3bab594258e0d604e7e5115a9bfc 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-03-23 12:50:44EDT roots-multi.lisp> +;;; Time-stamp: <2009-03-31 22:51:42EDT roots-multi.lisp> ;;; $Id$ (in-package :gsl) @@ -24,34 +24,26 @@ "Make an instance of a solver of the type specified for a system of the specified number of dimensions. Optionally set or reset an existing solver to use the function and the - initial guess gsl-vector." + initial guess gsl-vector. If scalarsp is T, the functions will + be supplied, and should return scalars." :initialize-suffix "set" :initialize-args ((callback :pointer) ((mpointer initial) :pointer)) - :superclasses (callback-included) - :ci-class-slots (gsl-mfunction marray (function)) + :callbacks + (callback gsl-mfunction (dimension) + (function + :success-failure + (:input :double :marray dim0) :slug + (:output :double :marray dim0))) :arglists-function (lambda (set) - `((type &optional function-or-dimension (initial nil ,set)) + `((type &optional function-or-dimension (initial nil ,set) (scalarsp t)) (:type type :dimensions (if ,set (dimensions initial) function-or-dimension)) - (:functions (list function-or-dimension) :initial initial))) + (:functions + (list function-or-dimension) :initial initial :scalarsp scalarsp))) :inputs (initial)) -(def-make-callbacks - multi-dimensional-root-solver-f (function dimension &optional (scalars t)) - (if scalars - `(defmcallback ,function - :success-failure - ((:double ,dimension)) ((:set :double ,dimension)) - T - ,function) - `(defmcallback ,function - :success-failure - (:pointer) (:pointer) - T - ,function))) - (defmobject multi-dimensional-root-solver-fdf "gsl_multiroot_fdfsolver" ((type :pointer) ((first dimensions) sizet)) "multi-dimensional root solver with function and derivative" @@ -59,41 +51,35 @@ "Make an instance of a derivative solver of the type specified for a system of the specified number of dimensions. Optionally set or reset an existing solver to use the function and derivative - (fdf) and the initial guess." + (fdf) and the initial guess. If scalarsp is T, the functions will + be supplied, and should return scalars." :initialize-suffix "set" :initialize-args ((callback :pointer) ((mpointer initial) :pointer)) - :superclasses (callback-included) - :ci-class-slots (gsl-mfunction-fdf marray (function df fdf)) + :callbacks + (callback gsl-mfunction-fdf (dimension) + (function :success-failure + (:input :double :marray dim0) + :slug + (:output :double :marray dim0)) + (df :success-failure + (:input :double :marray dim0) + :slug + (:output :double :marray dim0 dim0)) + (fdf :success-failure + (:input :double :marray dim0) + :slug + (:output :double :marray dim0) + (:output :double :marray dim0 dim0))) :arglists-function (lambda (set) - `((type &optional function-or-dimension (initial nil ,set)) + `((type &optional function-or-dimension (initial nil ,set) + (scalarsp t)) (:type type :dimensions (if ,set (dimensions initial) function-or-dimension)) - (:functions function-or-dimension :initial initial))) + (:functions function-or-dimension :initial initial :scalarsp scalarsp))) :inputs (initial)) -(def-make-callbacks - multi-dimensional-root-solver-fdf - (function df fdf dimension &optional (array t)) - `(progn - (defmcallback ,function - :success-failure - ((:double ,dimension)) ((:set :double ,dimension)) - ,array - ,function) - (defmcallback ,df - :success-failure - ((:double ,dimension)) ((:set :double ,dimension ,dimension)) - ,array - ,df) - (defmcallback ,fdf - :success-failure - ((:double ,dimension)) - ((:set :double ,dimension) (:set :double ,dimension ,dimension)) - ,array - ,fdf))) - (defmfun name ((solver multi-dimensional-root-solver-f)) "gsl_multiroot_fsolver_name" (((mpointer solver) :pointer)) @@ -118,6 +104,7 @@ "gsl_multiroot_fsolver_iterate" (((mpointer solver) :pointer)) :definition :method + :callback-object solver :documentation ; FDL "Perform a single iteration of the solver. The following errors may be signalled: 'bad-function-supplied, the iteration encountered a @@ -130,6 +117,7 @@ "gsl_multiroot_fdfsolver_iterate" (((mpointer solver) :pointer)) :definition :method + :callback-object solver :documentation ; FDL "Perform a single iteration of the solver. The following errors may be signalled: 'bad-function-supplied, the iteration encountered a @@ -142,6 +130,7 @@ "gsl_multiroot_fsolver_root" (((mpointer solver) :pointer)) :definition :method + :callback-object solver :c-return (crtn :pointer) :return ((copy crtn)) :documentation ; FDL @@ -151,6 +140,7 @@ "gsl_multiroot_fdfsolver_root" (((mpointer solver) :pointer)) :definition :method + :callback-object solver :c-return (crtn :pointer) :return ((copy crtn)) :documentation @@ -398,8 +388,6 @@ (* *rosenbrock-a* (- 1 arg0)) (* *rosenbrock-b* (- arg1 (expt arg0 2))))) -(make-callbacks multi-dimensional-root-solver-f 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." @@ -444,9 +432,6 @@ (rosenbrock-df arg0 arg1) (values v0 v1 j0 j1 j2 j3)))) -(make-callbacks multi-dimensional-root-solver-fdf - rosenbrock 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 diff --git a/solve-minimize-fit/roots-one.lisp b/solve-minimize-fit/roots-one.lisp index 3cb029cf8ce5b03ed66632e40b76268e0b44d85e..21d28ccde01ce460def1db6bf6841038d45f28b6 100644 --- a/solve-minimize-fit/roots-one.lisp +++ b/solve-minimize-fit/roots-one.lisp @@ -1,6 +1,6 @@ ;; One-dimensional root solver. ;; Liam Healy -;; Time-stamp: <2009-02-16 09:50:33EST roots-one.lisp> +;; Time-stamp: <2009-03-29 11:50:01EDT roots-one.lisp> ;; $Id$ (in-package :gsl) @@ -14,36 +14,28 @@ (defmobject one-dimensional-root-solver-f "gsl_root_fsolver" ((type :pointer)) "one-dimensional root solver with function only" - :superclasses (callback-included) - :ci-class-slots (gsl-function nil (function)) :initialize-suffix "set" :initialize-args ((callback :pointer) (lower :double) (upper :double)) + :callbacks + (callback gsl-function nil (function :double (:input :double) :slug)) :singular (function)) (defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver" ((type :pointer)) "one-dimensional root solver with function and derivative" - :superclasses (callback-included) - :ci-class-slots (gsl-function-fdf nil (function df fdf)) :initialize-suffix "set" - :initialize-args ((callback :pointer) (root-guess :double))) - -(def-make-callbacks one-dimensional-root-solver-fdf (function df fdf) - `(progn - (defmcallback ,function - :double :double - nil - nil - ,function) - (defmcallback ,df - :double :double - nil - nil - ,df) - (defmcallback ,fdf - :void :double ((:set :double 1) (:set :double 1)) - nil - ,fdf))) + :initialize-args ((callback :pointer) (root-guess :double)) + :callbacks + (callback gsl-function-fdf nil + (function :double (:input :double) :slug) + (df :double (:input :double) :slug) + (fdf :void (:input :double) :slug + (:output :double :cvector 1) (:output :double :cvector 1))) + :arglists-function + (lambda (set) + `((type &optional (function nil ,set) df fdf root-guess) + (:type type) + (:functions (list function df fdf) :root-guess root-guess)))) (defmfun name ((solver one-dimensional-root-solver-f)) "gsl_root_fsolver_name" @@ -70,6 +62,7 @@ "gsl_root_fsolver_iterate" (((mpointer solver) :pointer)) :definition :method + :callback-object solver :documentation ; FDL "Perform a single iteration of the solver. The following errors may be signalled: 'bad-function-supplied, the iteration encountered a @@ -82,6 +75,7 @@ "gsl_root_fdfsolver_iterate" (((mpointer solver) :pointer)) :definition :method + :callback-object solver :documentation ; FDL "Perform a single iteration of the solver. The following errors may be signalled: 'bad-function-supplied, the iteration encountered a @@ -302,10 +296,6 @@ (values (+ (* (+ (* a x) b) x) c) (+ (* 2 a x) b)))) -(make-callbacks single-function quadratic) -(make-callbacks one-dimensional-root-solver-fdf - quadratic quadratic-derivative quadratic-and-derivative) - (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." @@ -336,7 +326,7 @@ (initial 5.0d0) (solver (make-one-dimensional-root-solver-fdf method - '(quadratic quadratic-derivative quadratic-and-derivative) + 'quadratic 'quadratic-derivative 'quadratic-and-derivative initial))) (when print-steps (format t "iter ~6t ~8troot ~22terr ~34terr(est)~&")) diff --git a/tests/numerical-differentiation.lisp b/tests/numerical-differentiation.lisp index c14ad72195b361a4ca7b70f1e078132fc9ce7136..1b6118ccbe4f1721100cc11c968b409abbee5b96 100644 --- a/tests/numerical-differentiation.lisp +++ b/tests/numerical-differentiation.lisp @@ -6,15 +6,15 @@ (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 'exp 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 'exp 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 'exp 1.0d0 1.d-4))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 0.474341649024533d0 3.3922603135575853d-11) (MULTIPLE-VALUE-LIST @@ -66,13 +66,13 @@ (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 '/ 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 '/ 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 '/ 10.0d0 1.d-4)))) diff --git a/tests/numerical-integration.lisp b/tests/numerical-integration.lisp index 61d4d94a7f839cd9b4695917de08626783acee53..09047741b34959185213f39371d2ab598a81f6f9 100644 --- a/tests/numerical-integration.lisp +++ b/tests/numerical-integration.lisp @@ -6,13 +6,13 @@ (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.0d0 2.220446049250313d-14 21) (MULTIPLE-VALUE-LIST - (INTEGRATION-QNG 'ONE-SINE 0.0d0 PI))) + (INTEGRATION-QNG 'SIN 0.0d0 PI))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.0d0 2.220446049250313d-14) (MULTIPLE-VALUE-LIST - (INTEGRATION-QAG 'ONE-SINE 0.0d0 PI :GAUSS15 20))) + (INTEGRATION-QAG 'SIN 0.0d0 PI :GAUSS15 20))) (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 2.0d0 2.220446049250313d-14) (MULTIPLE-VALUE-LIST - (INTEGRATION-QAG 'ONE-SINE 0.0d0 PI :GAUSS21 40)))) + (INTEGRATION-QAG 'SIN 0.0d0 PI :GAUSS21 40))))