Commit b134ed94 authored by Liam Healy's avatar Liam Healy

Use lambda forms in callbacks

It is possible to use lambda forms as well as function names in
callback definers; this is demonstrated in the Monte Carlo example.
Eliminated make-mfunction and folded its functionality into
make-solver-functions.  Added a section to the documentation to
explain how function definitions work.
parent f0c7ecec
;; Monte Carlo Integration
;; Liam Healy Sat Feb 3 2007 - 17:42
;; Time-stamp: <2009-01-24 12:58:12EST monte-carlo.lisp>
;; Time-stamp: <2009-01-24 19:32:18EST monte-carlo.lisp>
;; $Id$
(in-package :gsl)
......@@ -218,9 +218,13 @@
(parameters :pointer))
(export 'make-monte-carlo-function)
(defmacro make-monte-carlo-function (name dimensions)
`(make-single-function ,name :double :double monte-function
,dimensions nil nil))
(defmacro make-monte-carlo-function (name-or-lambda &optional (dimensions 1))
"Define the function for use in the Monte Carlo functions. The function
should be specified with either the name of a CL function already defined,
or as a lambda form. In the latter case, the number of dimensions need
not be specified, they will be computed."
`(make-single-function ,name-or-lambda :double :double monte-function
,dimensions nil nil))
;;;;****************************************************************************
;;;; Examples and unit test
......@@ -229,33 +233,32 @@
;;; Example from Sec. 23.5
;;; This is a function that occurs in random walk studies.
(defun monte-carlo-g (x y z)
(* (/ (expt pi 3))
(/ (- 1 (* (cos x) (cos y) (cos z))))))
(defparameter *monte-carlo-g*
(make-monte-carlo-function monte-carlo-g 3))
(defparameter *monte-carlo-cb*
(make-monte-carlo-function
(lambda (x y z)
(* (/ (expt pi 3))
(/ (- 1 (* (cos x) (cos y) (cos z))))))))
(defun random-walk-plain-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-plain 3))
(lower #m(0.0d0 0.0d0 0.0d0))
(upper (make-marray 'double-float :initial-contents (list pi pi pi)))
(rng (make-random-number-generator *mt19937* 0)))
(monte-carlo-integrate-plain *monte-carlo-g* lower upper nsamples rng ws)))
(monte-carlo-integrate-plain *monte-carlo-cb* lower upper nsamples rng ws)))
(defun random-walk-miser-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-miser 3))
(lower #m(0.0d0 0.0d0 0.0d0))
(upper (make-marray 'double-float :initial-contents (list pi pi pi)))
(rng (make-random-number-generator *mt19937* 0)))
(monte-carlo-integrate-miser *monte-carlo-g* lower upper nsamples rng ws)))
(monte-carlo-integrate-miser *monte-carlo-cb* lower upper nsamples rng ws)))
(defun random-walk-vegas-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-vegas 3))
(lower #m(0.0d0 0.0d0 0.0d0))
(upper (make-marray 'double-float :initial-contents (list pi pi pi)))
(rng (make-random-number-generator *mt19937* 0)))
(monte-carlo-integrate-vegas *monte-carlo-g* lower upper nsamples rng ws)))
(monte-carlo-integrate-vegas *monte-carlo-cb* lower upper nsamples rng ws)))
(save-test monte-carlo
(random-walk-plain-example)
......
......@@ -296,6 +296,33 @@ area of memory.</p>
be extracted with the function <code>#'cl-array</code>.
</p>
<h3>Passing functions</h3>
<p>
Functions that are passed to GSL functions (known as <i>callbacks</i>
in C) are defined with one of the following macros in GSLL, depending
on the application:
<ul>
<li><code>make-single-function</code>, used by numerical
integration, numerical differentiation, Chebyshev, one-dimensional
root solver without derivatives, one-dimensional minimizer;</li>
<li><code>make-monte-carlo-function</code>, used by Monte Carlo;</li>
<li><code>make-solver-functions</code>, used by the root
solvers;</li>
<li><code>make-fitting-functions</code>, used by nonlinear least squares;</li>
<li><code>make-minimization-functions</code>, used by
the multi-dimensional minimizer;</li>
<li><code>make-ode-functions</code>, used by ordinary differential
equation solvers;</li>
</ul>
<p>
The function may be specified as the name of a CL function, or as a
lambda form. If the latter, the dimensions need not be specified in
<code>make-single-function</code>, <code>make-monte-carlo-function</code>,
or <code>make-solver-functions</code> for derivative-free solvers;
they will be computed from the arglist. Each of these macros will
return a foreign pointer that can be passed to the appropriate GSL
function that requires a function.
<h3>GSL objects</h3>
<p>
There are a number of GSL objects other than arrays that can be
......@@ -360,7 +387,7 @@ and arrays used internally or for function return.
<!-- Created: Feb 25 2005 -->
<!-- hhmts start -->
<small>
Time-stamp: <2009-01-24 18:40:10EST index.html>
Time-stamp: <2009-01-24 21:04:19EST index.html>
</small>
<!-- hhmts end -->
</div>
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-01-24 18:17:53EST callback.lisp>
;; Time-stamp: <2009-01-24 19:31:51EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -159,7 +159,7 @@
(defmacro defmcallback
(name &optional (return-type :double) (argument-types :double)
additional-argument-types marray (function-name name))
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)
......@@ -183,7 +183,7 @@
;; CL specials to do the same job.
(declare (ignore params))
,(callback-set-mvb
`(,function-name
`(,function-name-or-lambda
,@(append
(embedded-clfunc-args atl cbargs marray)
(embedded-clfunc-args aatl cbaddl marray)))
......@@ -231,6 +231,22 @@
less than that used by an unused defun."
(cffi:foreign-free 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))
(defmacro make-single-function
(name
&optional (return-type :double) (argument-type :double)
......@@ -244,15 +260,16 @@
placed in a struct that has no other functions defined."
;; I don't think structure=nil is ever used, but it is permissible
(with-unique-names (cbsymb)
(let ((dim (dimensions-from-lambda name dimensions)))
`(progn
(defmcallback ,cbsymb ,return-type
,(if dimensions `((,argument-type ,dimensions)) argument-type)
,(if dim `((,argument-type ,dim)) argument-type)
,(if dimensions-return `((:set ,argument-type ,dimensions-return)))
,marray ,name)
,@(when
structure
`((defcbstruct ,cbsymb ,structure
,(if dimensions `((dimensions ,dimensions)))))))))
,(if dim `((dimensions ,dim))))))))))
;;;;****************************************************************************
;;;; Vector of doubles
......
;; Generic functions for optimization
;; Liam Healy 2009-01-03 12:59:07EST generic.lisp
;; Time-stamp: <2009-01-24 17:15:48EST generic.lisp>
;; Time-stamp: <2009-01-24 20:09:47EST generic.lisp>
;; $Id: $
(in-package :gsl)
......@@ -35,12 +35,6 @@
(dimensions sizet)
(parameters :pointer))
(export 'make-mfunction)
(defmacro make-mfunction (name dimensions)
"Define a function for multivariate root solving."
`(make-single-function ,name :success-failure :double gsl-mfunction
,dimensions))
(cffi:defcstruct gsl-mfunction-fdf
;; See /usr/include/gsl/gsl_multiroots.h
"The definition of a function and its derivatives for multiroot
......@@ -66,37 +60,39 @@
(parameters :pointer))
(export 'make-solver-functions)
(defmacro make-solver-functions (function df fdf &optional dimensions array)
(defmacro make-solver-functions (function &optional df fdf dimensions array)
"Setup functions for solvers.
The CL functions name and derivative should be defined previously
with defuns. If dimensions is non-nil (positive fixnum), set multiroot solver
functions. If dimensions is a number, the functions should expect
dimensions scalar (double-float) arguments and return "
(let ((struct (if dimensions 'gsl-mfunction-fdf 'gsl-function-fdf))
(argtype (if dimensions (if array :pointer `((:double ,dimensions))) :double))
(rettype (if dimensions :success-failure :double))
(vecrettype (if array '(:pointer) `((:set :double ,dimensions))))
(matrettype
(if array '(:pointer) `((:set :double ,dimensions ,dimensions)))))
(with-unique-names (solverfn solverdf solverfdf)
`(progn
(defmcallback
,solverfn ,rettype ,argtype ,(when dimensions vecrettype) ,dimensions
,function)
(defmcallback
,solverdf ,rettype ,argtype
,(when dimensions matrettype)
,dimensions ,df)
(defmcallback
,solverfdf
,(if dimensions :success-failure :void)
,argtype
,(if dimensions
(append vecrettype matrettype)
'((:set :double 1) (:set :double 1)))
,dimensions ,fdf)
(defcbstruct (,solverfn function ,solverdf df ,solverfdf fdf)
,struct
,(when dimensions `((dimensions ,dimensions))))))))
The CL functions can be specified as a previously-defined defun or
as a lambda. If dimensions is non-nil (positive fixnum), set
multiroot solver functions. If dimensions is a number, the
functions should expect dimensions scalar (double-float) arguments.
If df and fdf are non-nil, define for derivative solvers."
(if df
(let ((struct (if dimensions 'gsl-mfunction-fdf 'gsl-function-fdf))
(argtype (if dimensions (if array :pointer `((:double ,dimensions))) :double))
(rettype (if dimensions :success-failure :double))
(vecrettype (if array '(:pointer) `((:set :double ,dimensions))))
(matrettype
(if array '(:pointer) `((:set :double ,dimensions ,dimensions)))))
(with-unique-names (solverfn solverdf solverfdf)
`(progn
(defmcallback
,solverfn ,rettype ,argtype ,(when dimensions vecrettype) ,dimensions
,function)
(defmcallback
,solverdf ,rettype ,argtype
,(when dimensions matrettype)
,dimensions ,df)
(defmcallback
,solverfdf
,(if dimensions :success-failure :void)
,argtype
,(if dimensions
(append vecrettype matrettype)
'((:set :double 1) (:set :double 1)))
,dimensions ,fdf)
(defcbstruct (,solverfn function ,solverdf df ,solverfdf fdf)
,struct
,(when dimensions `((dimensions ,dimensions)))))))
`(make-single-function ,function :success-failure :double gsl-mfunction
,dimensions)))
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-01-24 13:09:32EST roots-multi.lisp>
;;; Time-stamp: <2009-01-24 20:09:17EST roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -360,7 +360,7 @@
"Solving Rosenbrock, the example given in Sec. 34.8 of the GSL manual."
(let ((max-iter 1000)
(solver (make-multi-dimensional-root-solver-f
method (make-mfunction rosenbrock 2)
method (make-solver-functions rosenbrock nil nil 2)
#m(-10.0d0 -5.0d0))))
(loop for iter from 0
with fnval and argval
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment