Commit 1349c73a authored by Liam Healy's avatar Liam Healy

Most mobject-based callbacks ported to funcallables

All mobject-based callbacks now use the funcallable mechanism, except
ODE, which has been ported but fails to compile.  All other tests
pass.  In the event of some or all arguments are scalars and not
arrays, #'array-element-refs will return just the argument symbol.  To
avoid double quoting the function name when calling the object maker,
let bind 'function-designator in #'make-funcallable-form which does
the quoting.
parent ea9a2156
;; Chebyshev Approximations
;; Liam Healy Sat Nov 17 2007 - 20:36
;; Time-stamp: <2009-03-21 23:49:02EDT chebyshev.lisp>
;; Time-stamp: <2009-03-29 11:44:09EDT chebyshev.lisp>
;; $Id$
(in-package :gsl)
......@@ -16,7 +16,8 @@
"Chebyshev series"
:documentation ; FDL
"Make a Chebyshev series of specified order."
:callbacks (callback 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))
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-03-22 16:58:26EDT gsll.asd>
;; Time-stamp: <2009-03-29 12:54:31EDT gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -21,6 +21,7 @@
(: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))
......@@ -171,6 +172,7 @@
(:file "operations" :depends-on (histogram))
(:file "probability-distribution" :depends-on (histogram))
(:file "ntuple")))
#+(or)
(:module calculus
:depends-on (init data random)
:components
......
;; Generate a lambda that calls the user function; will be called by callback.
;; Liam Healy
;; Time-stamp: <2009-03-29 10:00:03EDT funcallable.lisp>
;; Time-stamp: <2009-03-29 12:04:35EDT funcallable.lisp>
;; $Id$
(in-package :gsl)
......@@ -77,14 +77,19 @@
;; not setfable if it's a scalar
foreign-variable-name))
(defun array-element-refs (array-names argspecs dimension-values)
"A list of forms reference each array element in succession."
(loop for arg in argspecs
for count = (value-from-dimensions arg dimension-values t)
for name in array-names
append
(loop for i from 0 below count
collect (reference-foreign-element name i arg dimension-values))))
(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."
......@@ -101,7 +106,6 @@
(loop for i from 0 below count
collect (make-symbol-cardinal 'setscalar i)))
(setvbls (array-element-refs argument-names setargs dimension-values)))
;;(lu:print-variables setargs counts count mvbvbls setvbls)
(if (zerop count)
form
`(multiple-value-bind ,mvbvbls
......@@ -142,18 +146,22 @@
(parse-callback-argspec arg 'array-type))
(list (pop oarg))
(if (eql (parse-callback-argspec arg 'io) :input)
(list (pop iarg)))))))
(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 outargs-specs))
(let ((call-form
`(funcall
,user-function
,function-designator
,@(array-element-refs inargs-names inargs-specs dimension-values))))
(if outargs-specs
(callback-set-mvb outargs-names call-form fnspec dimension-values)
;; no specified output, return what the function returns
call-form))
`(funcall ,user-function ,@(append inargs-names outargs-names)))
`(funcall ,function-designator ,@(append inargs-names outargs-names)))
,@(case
(parse-callback-fnspec fnspec 'return-spec)
(:success-failure
......
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-03-29 10:04:13EDT mobject.lisp>
;; Time-stamp: <2009-03-29 12:52:22EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -218,7 +218,7 @@
;; There is callback slot variable
,@(when (callback-arg-p class-slots-instance callbacks)
(with-unique-names (cbs)
`((let ((,cbs (make-cbstruct-object object)))
`((let ((,cbs ,(make-cbstruct-object class)))
(setf (slot-value
object
',(parse-callback-static callbacks 'foreign-argument))
......
;; 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 12:43:02EDT 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
......
;; Stepping functions for ODE systems.
;; Liam Healy, Mon Sep 24 2007 - 21:33
;; Time-stamp: <2009-03-23 22:25:34EDT stepping.lisp>
;; Time-stamp: <2009-03-29 12:34:49EDT stepping.lisp>
;; $Id$
;; /usr/include/gsl/gsl_odeiv.h
......@@ -21,14 +21,16 @@
(callback ode-system
(dimension)
(function :success-failure
((:double) ; t (independent variable), input
(:double :cvector dim0)) ; y (dependent variables), input
(:double :cvector dim0)) ; dydt, output
(:input :double) ; t (independent variable)
(:input :double :cvector dim0) ; y (dependent variables)
(:output :double :cvector dim0) ; dydt
:slug)
(jacobian :success-failure
((:double) ; t, input
(:double :cvector dim0)) ; y, input
((:double :cvector dim0 dim0) ; dfdy, output
(:double :cvector dim0)))) ; dfdt, output
(:input :double) ; t (independent variable)
(:input :double :cvector dim0) ; y (dependent variables)
(:output :double :cvector dim0 dim0) ; dfdy
(:output :double :cvector dim0) ; dydt
:slug))
:class-slots-instance (callback)
:initialize-suffix "reset"
:initialize-args nil
......
;; Multivariate minimization.
;; Liam Healy <Tue Jan 8 2008 - 21:28>
;; Time-stamp: <2009-03-28 23:41:15EDT minimization-multi.lisp>
;; Time-stamp: <2009-03-29 12:43:30EDT minimization-multi.lisp>
;; $Id$
(in-package :gsl)
......@@ -63,14 +63,14 @@
tol |p| |g|."
:callbacks
(callback gsl-mfunction-fdf (dimension)
(function :double (:double :marray dim0) :slug)
(function :double (:input :double :marray dim0) :slug)
(df :void
(:double :marray dim0) :slug
(:double :marray dim0 dim0))
(:input :double :marray dim0) :slug
(:output :double :marray dim0 dim0))
(fdf :void
(:double :marray dim0) :slug
(:double :cvector dim0)
(:double :marray dim0 dim0)))
(:input :double :marray dim0) :slug
(:output :double :cvector dim0)
(:output :double :marray dim0 dim0)))
:initialize-suffix "set"
:initialize-args
((callback :pointer) ((mpointer initial) :pointer)
......@@ -355,7 +355,7 @@
(set-all step-size 1.0d0)
(let ((minimizer
(make-multi-dimensional-minimizer-f
method 2 ''paraboloid-scalar
method 2 'paraboloid-scalar
#m(5.0d0 7.0d0) step-size)))
(loop with status = T and size
for iter from 0 below 100
......@@ -379,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.
......
;; Univariate minimization
;; Liam Healy Tue Jan 8 2008 - 21:02
;; Time-stamp: <2009-03-21 23:56:38EDT minimization-one.lisp>
;; Time-stamp: <2009-03-29 12:13:30EDT minimization-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -20,7 +20,8 @@
"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."
:callbacks (callback 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))
......@@ -180,17 +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)))
(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
......
;; Nonlinear least squares fitting.
;; Liam Healy, 2008-02-09 12:59:16EST nonlinear-least-squares.lisp
;; Time-stamp: <2009-03-22 16:09:53EDT nonlinear-least-squares.lisp>
;; Time-stamp: <2009-03-29 12:42:59EDT nonlinear-least-squares.lisp>
;; $Id$
(in-package :gsl)
......@@ -24,8 +24,10 @@
:callbacks
(callback gsl-ffit-function
(number-of-observations number-of-parameters)
(function :success-failure
(:double :marray dim1) (:double :marray dim0)))
(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))
......@@ -38,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))
......@@ -73,12 +64,18 @@
(callback gsl-fdffit-function
(number-of-observations number-of-parameters)
(function :success-failure
(:double :marray dim1) (:double :marray dim0))
(:input :double :marray dim1)
:slug
(:output :double :marray dim0))
(df :success-failure
(:double :marray dim1) (:double :marray dim0 dim1))
(:input :double :marray dim1)
:slug
(:output :double :marray dim0 dim1))
(fdf :success-failure
(:double :marray dim1)
(:double :marray dim0) (:double :marray dim0 dim1)))
(: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)))
......@@ -104,36 +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))
......@@ -387,13 +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)))
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-03-22 00:03:35EDT roots-multi.lisp>
;;; Time-stamp: <2009-03-29 12:22:43EDT roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -30,14 +30,16 @@
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
:callbacks
(callback gsl-mfunction (dimension)
(function :success-failure
(:double :marray dim0) (:double :marray dim0)))
(function
:success-failure
(:input :double :marray dim0) :slug
(:output :double :marray dim0)))
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set) (scalarsp t))
(:type type
:dimensions
(if ,set (dimensions initial) function-or-dimension))
:dimensions
(if ,set (dimensions initial) function-or-dimension))
(:functions
(list function-or-dimension) :initial initial :scalarsp scalarsp)))
:inputs (initial))
......@@ -56,15 +58,18 @@
:callbacks
(callback gsl-mfunction-fdf (dimension)
(function :success-failure
(:double :marray dim0)
(:double :marray dim0))
(:input :double :marray dim0)
:slug
(:output :double :marray dim0))
(df :success-failure
(:double :marray dim0)
(:double :marray dim0 dim0))
(:input :double :marray dim0)
:slug
(:output :double :marray dim0 dim0))
(fdf :success-failure
(:double :marray dim0)
(:double :marray dim0)
(:double :marray dim0 dim0)))
(: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)
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2009-03-21 23:53:41EDT roots-one.lisp>
;; Time-stamp: <2009-03-29 11:50:01EDT roots-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -16,7 +16,8 @@
"one-dimensional root solver with function only"
:initialize-suffix "set"
:initialize-args ((callback :pointer) (lower :double) (upper :double))
:callbacks (callback gsl-function nil (function))
:callbacks
(callback gsl-function nil (function :double (:input :double) :slug))
:singular (function))
(defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver"
......@@ -26,9 +27,10 @@
:initialize-args ((callback :pointer) (root-guess :double))
:callbacks
(callback gsl-function-fdf nil
(function)
(df)
(fdf :void :double (:double :cvector 1) (:double :cvector 1)))
(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)
......
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