Commit 866e84bd authored by Liam Healy's avatar Liam Healy

Define callbacks with #'make-callbacks form at top level

Defined a new macro #'make-callbacks that is invoked at top level.  It
is given the mobject class name, the function name(s), dimension(s)
and whether it should assume scalar input/output.  It will define the
appropriate callbacks for use in the mobject.  This eliminates the
need for defun* and should work with all CL implementations.  Tested
on both roots-multi only.
parent 5079794d
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-07 10:38:20EST callback.lisp>
;; Time-stamp: <2009-02-07 17:19:18EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -257,6 +257,7 @@
(length (second lambda-form))
dimensions))
;;; To be obsolete
(defmacro make-single-function
(name
&optional (return-type :double) (argument-type :double)
......@@ -281,26 +282,6 @@
`((defcbstruct ,cbsymb ,structure
,(if dim `((dimensions ,dim))))))))))
(defmacro defun*
(name args (dimensions-in . dimensions-out) &body body)
"Define a function as with a defun, and make a callback for it so
that it can be sent to GSL."
(let ((dimin (if (listp dimensions-in) dimensions-in (list dimensions-in)))
(dimout (if (listp dimensions-out) dimensions-out (list dimensions-out))))
`(progn
(defun ,name ,args ,@body)
,@(if dimensions-in
`((defmcallback ,name
:success-failure
((:double ,@dimin))
,(mapcar
(lambda (dims)
`(:set :double ,@(if (listp dims) dims (list dims))))
dimout)
t
,name))
`((defmcallback ,name :success-failure :pointer :pointer))))))
;;;;****************************************************************************
;;;; Classes that include callback information
;;;;****************************************************************************
......@@ -326,9 +307,23 @@
"A mobject that includes a callback function or functions to GSL."))
(defmacro def-ci-subclass
(class-name documentation cbstruct-name array-type callback-labels)
(class-name documentation
cbstruct-name array-type callback-labels)
`(defclass ,class-name (callback-included)
((cbstruct-name :initform ',cbstruct-name :allocation :class)
(array-type :initform ',array-type :allocation :class)
(callback-labels :initform ',callback-labels :allocation :class))
(:documentation ,documentation)))
(defgeneric make-callbacks-fn (class args)
(:documentation "Function to make forms that expand into defmcallback(s)."))
(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."
(make-callbacks-fn class args))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-02-07 09:24:56EST mobject.lisp>
;; Time-stamp: <2009-02-07 14:34:59EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-02-07 11:25:46EST roots-multi.lisp>
;;; Time-stamp: <2009-02-07 17:17:58EST roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -33,11 +33,28 @@
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
(:type type
:dimensions
(if ,set (dimensions initial) (list function-or-dimension)))
:dimensions
(if ,set (dimensions initial) function-or-dimension))
(:functions (list function-or-dimension) :initial initial)))
:inputs (initial))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'multi-dimensional-root-solver-f)) args)
(declare (ignore class))
(destructuring-bind (function dimension &optional (scalars t)) args
(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"
......@@ -49,17 +66,39 @@
:initialize-suffix "set"
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
:superclasses (callback-included)
;; (gsl-mfunction (dimensions 2) function function df df fdf fdf)
:ci-class-slots (gsl-mfunction-fdf marray (function df fdf))
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
(:type type
:dimensions
(if ,set (dimensions initial) (list function-or-dimension)))
(:functions function-or-dimension :initial initial)))
`((type &optional function-or-dimension (initial nil ,set))
(:type type
:dimensions
(if ,set (dimensions initial) function-or-dimension))
(:functions function-or-dimension :initial initial)))
:inputs (initial))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'multi-dimensional-root-solver-fdf)) args)
(declare (ignore class))
(destructuring-bind (function df fdf dimension &optional (array t)) args
`(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))
......@@ -358,12 +397,14 @@
(defparameter *rosenbrock-a* 1.0d0)
(defparameter *rosenbrock-b* 10.0d0)
(defun* rosenbrock (arg0 arg1) (2 2)
(defun rosenbrock (arg0 arg1)
"Rosenbrock test function."
(values
(* *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."
......@@ -391,7 +432,7 @@
(maref fnval 0)
(maref fnval 1))))))
(defun* rosenbrock-df (arg0 arg1) (2 (2 2))
(defun rosenbrock-df (arg0 arg1)
"The partial derivatives of the Rosenbrock functions."
(declare (ignore arg1))
(values (- *rosenbrock-a*)
......@@ -400,13 +441,16 @@
*rosenbrock-b*))
;;; Why is it necessary to define a function that calls the two other functions?
(defun* rosenbrock-fdf (arg0 arg1) (2 2 (2 2))
(defun rosenbrock-fdf (arg0 arg1)
(multiple-value-bind (v0 v1)
(rosenbrock arg0 arg1)
(multiple-value-bind (j0 j1 j2 j3)
(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
......
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