Commit 19496d61 authored by liam's avatar liam

Added multivariate minimization in minimization-multi.lisp. Broke

#'def-scalar-function into two macros, #'defmcallback and
#'defcbstruct, which are in turn used in other macros
#'def-solver-functions, #'def-minimization-functions, and
#'def-ode-functions.  Minor bug fixes.


git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3270 a3d8a0fb-c1db-0310-ace7-a616afeb9e30
parent 4e1a73c4
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2008-01-14 22:56:45 liam functions.lisp>
;; Time-stamp: <2008-01-20 18:12:42EST functions.lisp>
;; $Id: $
(in-package :gsl)
......@@ -61,42 +61,95 @@
(parameters :pointer))
;;;;****************************************************************************
;;;; A function of a scalar double
;;;; Macros for defining a callback and placing in a structure
;;;;****************************************************************************
;;; Used by numerical-integration, numerical-differentiation, chebyshev, ntuple.
;;; Usage example for scalar function (e.g. numerical-integration,
;;; numerical-differentiation, chebyshev, ntuple).
;;; (defmcallback myfn :double :double)
;;; Usage example for gsl-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))
(defmacro defmcallback
(name &optional (return-type :double) (argument-types :double)
additional-argument-types)
"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 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."
(flet ((arg-type (types)
(when types
(mapcar (lambda (type) (list (gensym "ARG") type))
(if (listp types) types (list types))))))
(let ((arguments (arg-type argument-types))
(additional-arguments (arg-type additional-argument-types)))
`(cffi:defcallback ,name
,(if (eq return-type :success-failure) :int return-type)
(,@arguments (params :pointer) ,@additional-arguments)
;; Parameters as C argument are always ignored, because we have
;; CL specials to do the same job.
(declare (ignore params))
(,name ,@(mapcar #'first (append arguments additional-arguments)))
,@(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))))))))
(defmacro defcbstruct
(functions &optional (structure 'gsl-function) additional-slots)
"Define a callback-related C struct used by GSL.
This struct is bound to a CL special with the specified name.
This macro can be used whenever a callback is defined and
placed in a struct that has no other functions defined."
(let ((name
;; Bind a CL special under this name to the C structure.
(if (listp functions) (first functions) functions))
(fnlist
;; Make a list of (function slot-name ...) for each function.
(if (listp functions) functions (list `,functions 'function))))
`(progn
;; Create the C structure and bind CL variable to it.
(defparameter ,name (cffi:foreign-alloc ',structure))
;; Set all the function slots.
,@(loop for (fn slot-name) on fnlist by #'cddr collect
`(set-slot-function ,name ',structure ',slot-name ',fn))
;; Set the parameters.
(set-parameters ,name ',structure)
;; Set any additional slots.
,@(loop for slot in additional-slots
collect
`(set-structure-slot
,name ',structure ',(first slot) ,(second slot))))))
(defmacro def-scalar-function
(name
&optional (return-type :double) (argument-type :double)
(structure 'gsl-function)
additional-slots
additional-arguments)
additional-argument-types)
"Define a callback and optionally a related C struct used by GSL.
This struct is bound to a CL special with the specified name.
This macro can be used whenever a callback is defined and
placed in a struct that has no other functions defined."
(let ((argument (gensym "CB")))
`(progn
(cffi:defcallback ,name
,(if (eq return-type :success-failure) :int return-type)
((,argument ,argument-type) (params :pointer) ,@additional-arguments)
(declare (ignore params))
(,name ,argument ,@(mapcar #'first additional-arguments))
,@(when (eq return-type :success-failure)
;; We always return success, because if there was a
;; problem, a CL error would be signalled.
'(success)))
,@(when
structure
;; Assume that defcallback does not bind the variable 'name.
`((defparameter ,name (cffi:foreign-alloc ',structure))
(set-slot-function ,name ',structure 'function ',name)
(set-parameters ,name ',structure)
,@(loop for slot in additional-slots
collect
`(set-structure-slot
,name ',structure ',(first slot) ,(second slot))))))))
`(progn
(defmcallback ,name ,return-type ,argument-type ,additional-argument-types)
,@(when
structure
`((defcbstruct ,name ,structure ,additional-slots)))))
(defun undef-scalar-function (name)
"Free foreign callback function. It is not necessary to do this; think
......
;********************************************************
; file: gsll.asd
; description: Definition of GSLL system
; date:
; author: Liam Healy
; modified: Tue Jan 8 2008 - 22:52
;********************************************************
;;; $Id: $
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2008-01-20 21:12:57EST gsll.asd>
;; $Id: $
(asdf:defsystem "gsll"
:name "gsll"
:description "GNU Scientific Library for Lisp."
:version "0"
:author "Liam M. Healy"
:licence "GPL v3"
:licence "GPL v3, FDL"
:depends-on (cffi)
:components
((:module init
......@@ -175,4 +171,5 @@
(:file "hankel" :depends-on (init data))
(:file "roots-one" :depends-on (init general))
(:file "minimization-one" :depends-on (init general))
(:file "roots-multi" :depends-on (init general))))
(:file "roots-multi" :depends-on (init general))
(:file "minimization-multi" :depends-on (init general))))
......@@ -315,7 +315,7 @@ svn checkout svn://common-lisp.net/project/gsll/subversion/trunk</pre>.</p>
<tr>
<td><a href="Multidimensional-Minimization.html">
Multidimensional Minimization</a></td>
<td>Not started</td>
<td>Done</td>
</tr>
<tr>
<td><a href="Least_002dSquares-Fitting.html">
......@@ -370,7 +370,7 @@ and expect a few failures on amd64 (four), none? on i386. Often, the
<!-- Created: Feb 25 2005 -->
<!-- hhmts start -->
<small>
Time-stamp: <2008-01-19 14:11:28EST index.html>
Time-stamp: <2008-01-20 21:01:45EST index.html>
</small>
<!-- hhmts end -->
</div>
......
;; Macros to interface GSL functions.
;; Liam Healy
;; Time-stamp: <2008-01-19 18:58:42EST interface.lisp>
;; Time-stamp: <2008-01-19 19:54:09EST interface.lisp>
;; $Id: $
(in-package :gsl)
......@@ -112,8 +112,8 @@
)
(defparameter *c-to-cl-types*
'((:double . double-float) (:float . single-float) (:int . fixnum)
(:size . (fixnum 0))))
`((:double . double-float) (:float . single-float) (:int . fixnum)
(:size . (integer 0 ,most-positive-fixnum))))
(defun cl-argument-types (cl-arguments c-arguments-types)
"Create CL argument and types from the C arguments."
......
This diff is collapsed.
;********************************************************
; file: minimization-one.lisp
; description: Univariate minimization
; date: Tue Jan 8 2008 - 21:02
; author: Liam Healy
; modified: Tue Jan 8 2008 - 22:50
;********************************************************
;;; $Id: $
;; Univariate minimization
;; Liam Healy Tue Jan 8 2008 - 21:02
;; Time-stamp: <2008-01-20 17:02:12EST minimization-one.lisp>
;; $Id: $
(in-package :gsl)
......@@ -85,7 +81,7 @@
bounding interval.")
(defun-gsl fminimizer-x-minimum (minimizer)
"gsl_min_fminimizer_x_lower"
"gsl_min_fminimizer_x_minimum"
((minimizer :pointer))
:c-return :double
:documentation
......@@ -137,7 +133,7 @@
"gsl_min_test_interval"
((lower :double) (upper :double)
(absolute-error :double) (relative-error :double))
:c-return :success-failure
:c-return :success-continue ; guess that this is s-c, not s-f
:documentation
"Test for the convergence of the interval [lower,upper]
with absolute error and relative error specified.
......
;********************************************************
; file: ode-example.lisp
; description: Example ODE
; date: Sat Sep 29 2007 - 17:49
; author: Liam Healy
; modified: Sat Jan 5 2008 - 21:41
;********************************************************
;;; $Id: $
;; Example ODE
;; Liam Healy Sat Sep 29 2007 - 17:49
;; Time-stamp: <2008-01-20 17:40:48EST ode-example.lisp>
;; $Id: $
;;; van der Pol as given in Section 25.5 of the GSL manual. To
;;; reproduce that example, (integrate-vanderpol 100.0d0)
......
;; ODE system setup
;; Liam Healy, Sun Apr 15 2007 - 14:19
;; Time-stamp: <2008-01-14 22:58:19 liam ode-system.lisp>
;; Time-stamp: <2008-01-20 18:06:12EST ode-system.lisp>
;; $Id: $
(in-package :gsl)
......@@ -20,42 +20,15 @@
The CL functions name and jacobian should be defined previously
with defuns."
;; The function should take three arguments: time, dependent, derivatives
;; The latter two will be C arrays. To reference them, use #'with-c-vector.
;; The latter two will be C arrays. To reference them, use #'with-c-doubles.
;; To make this more transparent using a normal CL function
;; would require transferring numbers back and forth between C and CL arrays,
;; which could be inefficient.
(let ((time (make-symbol "TIME"))
(dependent (make-symbol "DEP"))
(derivatives (make-symbol "DERIV"))
(dfdy (make-symbol "DFDY"))
(dfdt (make-symbol "DFDT"))
(params (make-symbol "PARAMS")))
`(progn
(cffi:defcallback ,name :int
((,time :double)
(,dependent :pointer)
(,derivatives :pointer)
(,params :pointer))
(declare (ignore ,params))
(,name ,time ,dependent ,derivatives)
success)
;; The function should take four arguments: time, dependent, dfdy, dfdt
;; The last three will be arrays.
(cffi:defcallback ,jacobian :int
((,time :double)
(,dependent :pointer)
(,dfdy :pointer)
(,dfdt :pointer)
(,params :pointer))
(declare (ignore ,params))
(,name ,time ,dependent ,dfdy ,dfdt)
success)
;; Assume that defcallback does not bind the variable 'name.
(defparameter ,name (cffi:foreign-alloc 'ode-system))
(set-slot-function ,name 'ode-system 'function ',name)
(set-slot-function ,name 'ode-system 'jacobian ',jacobian)
(set-structure-slot ,name 'ode-system 'dimension ,dimension)
(set-parameters ,name 'ode-system))))
`(progn
(defmcallback ,name :success-failure (:double :pointer :pointer))
(defmcallback ,jacobian :success-failure (:double :pointer :pointer :pointer))
(defcbstruct (,name function ,jacobian jacobian) ode-system
((dimension ,dimension)))))
(defmacro with-ode-integration
((time step-size dependent dimensions &optional (stepper '*step-rk8pd*)
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2008-01-16 19:31:03EST roots-multi.lisp>
;;; Time-stamp: <2008-01-20 17:18:39EST roots-multi.lisp>
;;; $Id: $
(in-package :gsl)
......@@ -27,7 +27,7 @@
"Define a function for multivariate root solving."
`(def-scalar-function ,name :success-failure :pointer gsl-mfunction
((dimensions ,dimensions))
((returned-value gsl-vector-c))))
(gsl-vector-c)))
(cffi:defcstruct gsl-mfunction-fdf
;; See /usr/include/gsl/gsl_multiroots.h
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2008-01-15 22:57:11 liam roots-one.lisp>
;; Time-stamp: <2008-01-20 17:24:01EST roots-one.lisp>
;; $Id: $
(in-package :gsl)
......@@ -20,51 +20,25 @@
(parameters :pointer))
(export 'def-solver-functions)
(defmacro def-solver-functions (function df fdf &optional dimensions)
"Setup functions for solvers.
The CL functions name and derivative should be defined previously
with defuns. If dimensions is non-nil, set multiroot solver
functions."
(let ((arg (make-symbol "ARG"))
(params (make-symbol "PARAMS"))
(func (make-symbol "F"))
(deriv (make-symbol "DF"))
(struct (if dimensions 'gsl-mfunction-fdf 'gsl-function-fdf))
(let ((struct (if dimensions 'gsl-mfunction-fdf 'gsl-function-fdf))
(argtype (if dimensions :pointer :double))
(rettype (if dimensions :int :double)))
(rettype (if dimensions :success-failure :double)))
`(progn
(cffi:defcallback ,function ,rettype
((,arg ,argtype)
(,params :pointer)
,@(when dimensions `((,func :pointer))))
(declare (ignore ,params))
(,function ,arg ,@(when dimensions `(,func)))
,@(when dimensions '(success)))
(cffi:defcallback ,df ,rettype
((,arg ,argtype)
(,params :pointer)
,@(when dimensions `((,deriv :pointer))))
(declare (ignore ,params))
(,df ,arg ,@(when dimensions `(,deriv)))
,@(when dimensions '(success)))
(cffi:defcallback ,fdf ,(if dimensions :int :pointer)
((,arg ,argtype)
(,params :pointer)
(,func :pointer)
(,deriv :pointer))
(declare (ignore ,params))
(,fdf ,arg ,func ,deriv)
;; fdf function returns sucess code in multivariate case, void
;; pointer in univariate
,(if dimensions 'success
'(cffi:null-pointer)))
(defparameter ,function (cffi:foreign-alloc ',struct))
(set-slot-function ,function ',struct 'function ',function)
(set-slot-function ,function ',struct 'df ',df)
(set-slot-function ,function ',struct 'fdf ',fdf)
,@(when dimensions
`((set-structure-slot ,function ',struct 'dimensions ,dimensions)))
(set-parameters ,function ',struct))))
(defmcallback ,function ,rettype ,argtype
,(when dimensions '(:pointer)))
(defmcallback ,df ,rettype ,argtype
,(when dimensions '(:pointer)))
(defmcallback
,fdf ,(if dimensions :success-failure :pointer)
,argtype (:pointer :pointer))
(defcbstruct (,function 'function ,df 'df ,fdf 'fdf) ,struct
,(when dimensions `((dimensions ,dimensions)))))))
;;;;****************************************************************************
;;;; Initialization
......
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