Commit 5aafab66 authored by liam's avatar liam
Browse files

Multivariate root solving with derivative now functions. Symbol macro

'success returns the GSL_SUCCESS code, required for many callback
definitions.  Introduced macros vref and mref (setfable) to get
components of GSL vector doubles and matrix doubles directly from the
pointers.


git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3265 a3d8a0fb-c1db-0310-ace7-a616afeb9e30
parent 9f0886b5
;******************************************************** ;; Using GSL storage.
; file: data.lisp ;; Liam Healy, Sun Mar 26 2006 - 16:32
; description: Using GSL storage. ;; Time-stamp: <2008-01-14 21:09:15 liam data.lisp>
; date: Sun Mar 26 2006 - 16:32 ;; $Id: $
; author: Liam M. Healy
; modified: Sun Jan 13 2008 - 22:49
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -234,14 +230,6 @@ ...@@ -234,14 +230,6 @@
(progn ,@body) (progn ,@body)
(free ,symbol)))) (free ,symbol))))
(defun make-data-from-pointer (pointer &optional (class 'gsl-vector-double) size)
"Given a C pointer to a GSL data type, make the CL object."
(make-instance
class
:pointer pointer
:storage-size
(or size (cffi:foreign-slot-value pointer 'gsl-vector-c 'size))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Getting values into CL ;;;; Getting values into CL
;;;;**************************************************************************** ;;;;****************************************************************************
......
;******************************************************** ;; Matrices
; file: matrix.lisp ;; Liam Healy, Sun Mar 26 2006 - 11:51
; description: Matrices ;; Time-stamp: <2008-01-15 19:34:56 liam matrix.lisp>
; date: Sun Mar 26 2006 - 11:51 ;; $Id: $
; author: Liam M. Healy
; modified: Sun Dec 3 2006 - 18:53
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -51,6 +47,12 @@ ...@@ -51,6 +47,12 @@
(defmethod gsl-array ((object gsl-matrix)) (defmethod gsl-array ((object gsl-matrix))
(foreign-slot-value (pointer object) 'gsl-matrix-c 'data)) (foreign-slot-value (pointer object) 'gsl-matrix-c 'data))
(export 'matrix-data)
(defun matrix-data (pointer)
"A pointer to the GSL array with the data contents, from the
sruct pointer."
(cffi:foreign-slot-value pointer 'gsl-matrix-c 'data))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Getting values ;;;; Getting values
;;;;**************************************************************************** ;;;;****************************************************************************
...@@ -63,6 +65,13 @@ ...@@ -63,6 +65,13 @@
:c-return :c-base-type :c-return :c-base-type
:documentation "The (i,j)-th element of the matrix.") :documentation "The (i,j)-th element of the matrix.")
(defun-gsl mref (pointer index0 index1)
"gsl_matrix_get"
((pointer :pointer) (index0 :size) (index1 :size))
:c-return :double
:index nil
:documentation "An element of the matrix of doubles, computed from the pointer.")
(defun-gsl-mdsfc gsl-matrix-ptr ((matrix gsl-matrix) i j) (defun-gsl-mdsfc gsl-matrix-ptr ((matrix gsl-matrix) i j)
"gsl_matrix_ptr" (((pointer matrix) :pointer) (i :size) (j :size)) "gsl_matrix_ptr" (((pointer matrix) :pointer) (i :size) (j :size))
:c-return :pointer :c-return :pointer
...@@ -96,6 +105,13 @@ ...@@ -96,6 +105,13 @@
:c-return :void :c-return :void
:documentation "Set the (i,j)-th element of the matrix.") :documentation "Set the (i,j)-th element of the matrix.")
(defun-gsl (setf mref) (value pointer index0 index1)
"gsl_matrix_set"
((pointer :pointer) (index0 :size) (index1 :size) (value :double))
:c-return :void
:index nil
:documentation "Set an element of the matrix of doubles, using its pointer.")
(defmethod (setf data) (array (object gsl-matrix)) (defmethod (setf data) (array (object gsl-matrix))
(loop for i from 0 (loop for i from 0
below below
......
;******************************************************** ;; Vectors
; file: vector.lisp ;; Liam Healy, Sun Mar 26 2006 - 11:51
; description: Vectors ;; Time-stamp: <2008-01-15 19:01:37 liam vector.lisp>
; date: Sun Mar 26 2006 - 11:51 ;; $Id: $
; author: Liam M. Healy
; modified: Sun Jan 13 2008 - 22:40
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -79,7 +75,16 @@ deallocated with the vector. ...@@ -79,7 +75,16 @@ deallocated with the vector.
(defmethod gsl-array ((object gsl-vector)) (defmethod gsl-array ((object gsl-vector))
(cffi:foreign-slot-value (pointer object) 'gsl-vector-c 'data)) (cffi:foreign-slot-value (pointer object) 'gsl-vector-c 'data))
(defun gsl-array-p (pointer) (defun make-data-from-pointer (pointer &optional (class 'gsl-vector-double) size)
"Given a C pointer to a GSL data type, make the CL object."
(make-instance
class
:pointer pointer
:storage-size
(or size (cffi:foreign-slot-value pointer 'gsl-vector-c 'size))))
(export 'vector-data)
(defun vector-data (pointer)
"A pointer to the GSL array with the data contents, from the "A pointer to the GSL array with the data contents, from the
sruct pointer." sruct pointer."
(cffi:foreign-slot-value pointer 'gsl-vector-c 'data)) (cffi:foreign-slot-value pointer 'gsl-vector-c 'data))
...@@ -94,6 +99,13 @@ deallocated with the vector. ...@@ -94,6 +99,13 @@ deallocated with the vector.
:c-return :c-base-type :c-return :c-base-type
:documentation "The ith element of the vector.") :documentation "The ith element of the vector.")
(defun-gsl vref (pointer index)
"gsl_vector_get"
((pointer :pointer) (index :size))
:c-return :double
:index nil
:documentation "An element of the vector of doubles, computed from the pointer.")
(defun-gsl gsl-vector-ptr (vector i) (defun-gsl gsl-vector-ptr (vector i)
"gsl_vector_ptr" (((pointer vector) :pointer) (i :size)) "gsl_vector_ptr" (((pointer vector) :pointer) (i :size))
:c-return :pointer :c-return :pointer
...@@ -107,7 +119,14 @@ deallocated with the vector. ...@@ -107,7 +119,14 @@ deallocated with the vector.
"gsl_vector_set" "gsl_vector_set"
(((pointer vector) :pointer) ((first indices) :size) (value :c-base-type)) (((pointer vector) :pointer) ((first indices) :size) (value :c-base-type))
:c-return :void :c-return :void
:documentation "Set the ith element of the vector.") :documentation "Set an element of the vector.")
(defun-gsl (setf vref) (value pointer index)
"gsl_vector_set"
((pointer :pointer) (index :size) (value :double))
:c-return :void
:index nil
:documentation "Set an element of the vector of doubles, using its pointer.")
(defun-gsl-vdsfc set-all ((object gsl-vector) value) (defun-gsl-vdsfc set-all ((object gsl-vector) value)
"gsl_vector_set_all" "gsl_vector_set_all"
......
;******************************************************** ;; GSL errors
; file: conditions.lisp ;; Liam Healy Sat Mar 4 2006 - 18:33
; description: GSL errors ;; Time-stamp: <2008-01-14 22:22:55 liam conditions.lisp>
; date: Sat Mar 4 2006 - 18:33 ;; $Id: $
; author: Liam M. Healy
; modified: Sun Apr 2 2006 - 15:56
;********************************************************
(in-package :gsl) (in-package :gsl)
...@@ -98,3 +95,11 @@ ...@@ -98,3 +95,11 @@
(cffi:foreign-funcall (cffi:foreign-funcall
"gsl_set_error_handler" "gsl_set_error_handler"
:pointer (cffi:callback gsl-error)) :pointer (cffi:callback gsl-error))
(defmacro gsl-errorno-sm (keyword)
`(define-symbol-macro
,(intern (symbol-name keyword) (find-package :gsl))
(cffi:foreign-enum-value 'gsl-errorno ,keyword)))
(gsl-errorno-sm :success)
;******************************************************** ;; Foreign callback functions.
; file: functions.lisp ;; Liam Healy
; description: Foreign callback functions. ;; Time-stamp: <2008-01-14 22:56:45 liam functions.lisp>
; date: Sun Dec 9 2007 - 22:08 ;; $Id: $
; author: Liam Healy
; modified: Sun Jan 13 2008 - 13:26
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -90,7 +86,7 @@ ...@@ -90,7 +86,7 @@
,@(when (eq return-type :success-failure) ,@(when (eq return-type :success-failure)
;; We always return success, because if there was a ;; We always return success, because if there was a
;; problem, a CL error would be signalled. ;; problem, a CL error would be signalled.
'((cffi:foreign-enum-value 'gsl-errorno :SUCCESS)))) '(success)))
,@(when ,@(when
structure structure
;; Assume that defcallback does not bind the variable 'name. ;; Assume that defcallback does not bind the variable 'name.
......
...@@ -313,7 +313,7 @@ svn checkout svn://common-lisp.net/project/gsll/subversion/trunk</pre> ...@@ -313,7 +313,7 @@ svn checkout svn://common-lisp.net/project/gsll/subversion/trunk</pre>
<tr> <tr>
<td><a href="Multidimensional-Root_Finding.html"> <td><a href="Multidimensional-Root_Finding.html">
Multidimensional Root Finding</a></td> Multidimensional Root Finding</a></td>
<td>Started</td> <td>Done</td>
</tr> </tr>
<tr> <tr>
<td><a href="Multidimensional-Minimization.html"> <td><a href="Multidimensional-Minimization.html">
...@@ -357,7 +357,7 @@ svn checkout svn://common-lisp.net/project/gsll/subversion/trunk</pre> ...@@ -357,7 +357,7 @@ svn checkout svn://common-lisp.net/project/gsll/subversion/trunk</pre>
<!-- Created: Feb 25 2005 --> <!-- Created: Feb 25 2005 -->
<!-- hhmts start --> <!-- hhmts start -->
<small> <small>
Time-stamp: <2008-01-13 16:51:23 liam index.html> Time-stamp: <2008-01-15 22:37:31 liam index.html>
</small> </small>
<!-- hhmts end --> <!-- hhmts end -->
</div> </div>
......
;******************************************************** ;; Macros to interface GSL functions.
; file: interface.lisp ;; Liam Healy
; description: Macros to interface GSL functions. ;; Time-stamp: <2008-01-15 18:55:45 liam interface.lisp>
; date: Mon Mar 6 2006 - 22:35 ;; $Id: $
; author: Liam M. Healy
; modified: Sun Jan 6 2008 - 13:48
;********************************************************
(in-package :gsl) (in-package :gsl)
...@@ -101,7 +98,7 @@ ...@@ -101,7 +98,7 @@
(defun success-continue (value) (defun success-continue (value)
"If status indicates success, return T, othewise return NIL." "If status indicates success, return T, othewise return NIL."
(eql value (cffi:foreign-enum-value 'gsl-errorno :SUCCESS))) (eql value success))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Macro defun-gsl ;;;; Macro defun-gsl
...@@ -125,7 +122,8 @@ ...@@ -125,7 +122,8 @@
;;; or its derivatives. ;;; or its derivatives.
;;; Default are allocated quantities in c-arguments, or :c-return if none. ;;; Default are allocated quantities in c-arguments, or :c-return if none.
;;; type :function or :method ;;; type :function or :method
;;; index Name under which this function should be cross-referenced ;;; index Name under which this function should be cross-referenced; t
;;; to use name, nil to not index.
;;; export Whether to export the symbol. ;;; export Whether to export the symbol.
;;; null-pointer-info Return value if C function returns a null pointer. ;;; null-pointer-info Return value if C function returns a null pointer.
;;; documentation ;;; documentation
...@@ -136,7 +134,7 @@ ...@@ -136,7 +134,7 @@
(name arglist gsl-name c-arguments (name arglist gsl-name c-arguments
&key (c-return :error-code) &key (c-return :error-code)
(return nil return-supplied-p) (return nil return-supplied-p)
(type :function) index (export (not (eq type :method))) (type :function) (index t) (export (not (eq type :method)))
null-pointer-info documentation invalidate after enumeration) null-pointer-info documentation invalidate after enumeration)
(let* ((cargs (substitute '(mode sf-mode) :mode c-arguments)) (let* ((cargs (substitute '(mode sf-mode) :mode c-arguments))
(carg-symbs (carg-symbs
...@@ -164,69 +162,69 @@ ...@@ -164,69 +162,69 @@
(unless (eq c-return :void) (unless (eq c-return :void)
(list cret-name))))) (list cret-name)))))
`(progn `(progn
(,(if (eq type :function) 'defun 'defmethod) (,(if (eq type :function) 'defun 'defmethod)
,name ,name
,(if (member :mode c-arguments) ,(if (member :mode c-arguments)
`(,@clargs &optional (mode :double-prec)) `(,@clargs &optional (mode :double-prec))
`(,@clargs)) `(,@clargs))
,@(when documentation (list documentation)) ,@(when documentation (list documentation))
(,@(if allocated (,@(if allocated
`(cffi:with-foreign-objects `(cffi:with-foreign-objects
,(mapcar #'wfo-declare allocated-decl)) ,(mapcar #'wfo-declare allocated-decl))
'(let ())) '(let ()))
(let ((,cret-name (let ((,cret-name
(cffi:foreign-funcall (cffi:foreign-funcall
,gsl-name ,gsl-name
,@(mapcan ,@(mapcan
(lambda (arg) (lambda (arg)
(list (if (member (st-symbol arg) allocated) (list (if (member (st-symbol arg) allocated)
:pointer :pointer
(st-type arg)) (st-type arg))
(st-symbol arg))) (st-symbol arg)))
cargs) cargs)
,cret-type))) ,cret-type)))
,@(case c-return ,@(case c-return
(:void `((declare (ignore ,cret-name)))) (:void `((declare (ignore ,cret-name))))
(:error-code ; fill in arguments (:error-code ; fill in arguments
`((check-gsl-status ,cret-name ',name)))) `((check-gsl-status ,cret-name ',name))))
,@(when invalidate `((cl-invalidate ,@invalidate))) ,@(when invalidate `((cl-invalidate ,@invalidate)))
,@(when (or null-pointer-info (eq c-return :pointer)) ,@(when (or null-pointer-info (eq c-return :pointer))
`((check-null-pointer ,cret-name `((check-null-pointer ,cret-name
,@(or null-pointer-info ,@(or null-pointer-info
'(:ENOMEM "No memory allocated"))))) '(:ENOMEM "No memory allocated")))))
,@after ,@after
(values (values
,@(case c-return ,@(case c-return
(:number-of-answers (:number-of-answers
(mapcan (mapcan
(lambda (vbl seq) (lambda (vbl seq)
`((when (> ,cret-name ,seq) ,vbl))) `((when (> ,cret-name ,seq) ,vbl)))
clret clret
(loop for i below (length clret) collect i))) (loop for i below (length clret) collect i)))
(:success-failure (:success-failure
(if (equal clret invalidate) (if (equal clret invalidate)
;; success-failure more important than passed-in ;; success-failure more important than passed-in
`(success-failure ,@clret) `(success-failure ,@clret)
(remove cret-name ; don't return c-return itself (remove cret-name ; don't return c-return itself
`(,@clret (success-failure ,cret-name))))) `(,@clret (success-failure ,cret-name)))))
(:success-continue (:success-continue
(if (equal clret invalidate) (if (equal clret invalidate)
;; success-failure more important than passed-in ;; success-failure more important than passed-in
`(success-continue ,@clret) `(success-continue ,@clret)
(remove cret-name ; don't return c-return itself (remove cret-name ; don't return c-return itself
`(,@clret (success-continue ,cret-name))))) `(,@clret (success-continue ,cret-name)))))
(:true-false (:true-false
`((not (zerop ,cret-name)))) `((not (zerop ,cret-name))))
(:enumerate (:enumerate
`((cffi:foreign-enum-keyword ',enumeration ,cret-name))) `((cffi:foreign-enum-keyword ',enumeration ,cret-name)))
(t (unless (t (unless
(or (or
(and (eq c-return :error-code) (and (eq c-return :error-code)
(not allocated)) (not allocated))
(and (null return) return-supplied-p)) (and (null return) return-supplied-p))
clret))))))) clret)))))))
(map-name ',(or index name) ,gsl-name) ,@(when index `((map-name ',(if (eql index t) name index) ,gsl-name)))
,@(when export `((export ',name)))))) ,@(when export `((export ',name))))))
(defmacro defun-optionals (defmacro defun-optionals
(name arglist no-optional optionals &optional documentation) (name arglist no-optional optionals &optional documentation)
......
;******************************************************** ;; ODE system setup
; file: ode-system.lisp ;; Liam Healy, Sun Apr 15 2007 - 14:19
; description: ODE system setup ;; Time-stamp: <2008-01-14 22:58:19 liam ode-system.lisp>
; date: Sun Apr 15 2007 - 14:19 ;; $Id: $
; author: Liam Healy
; modified: Sat Jan 5 2008 - 21:39
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -42,7 +38,7 @@ ...@@ -42,7 +38,7 @@
(,params :pointer)) (,params :pointer))
(declare (ignore ,params)) (declare (ignore ,params))
(,name ,time ,dependent ,derivatives) (,name ,time ,dependent ,derivatives)
(cffi:foreign-enum-value 'gsl-errorno :SUCCESS)) success)
;; The function should take four arguments: time, dependent, dfdy, dfdt ;; The function should take four arguments: time, dependent, dfdy, dfdt
;; The last three will be arrays. ;; The last three will be arrays.
(cffi:defcallback ,jacobian :int (cffi:defcallback ,jacobian :int
...@@ -53,7 +49,7 @@ ...@@ -53,7 +49,7 @@
(,params :pointer)) (,params :pointer))
(declare (ignore ,params)) (declare (ignore ,params))
(,name ,time ,dependent ,dfdy ,dfdt) (,name ,time ,dependent ,dfdy ,dfdt)
(cffi:foreign-enum-value 'gsl-errorno :SUCCESS)) success)
;; Assume that defcallback does not bind the variable 'name. ;; Assume that defcallback does not bind the variable 'name.
(defparameter ,name (cffi:foreign-alloc 'ode-system)) (defparameter ,name (cffi:foreign-alloc 'ode-system))
(set-slot-function ,name 'ode-system 'function ',name) (set-slot-function ,name 'ode-system 'function ',name)
......
;;; Multivariate roots. ;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08 ;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2008-01-13 22:51:02 liam roots-multi.lisp> ;;; Time-stamp: <2008-01-15 22:44:27 liam roots-multi.lisp>
;;; $Id: $ ;;; $Id: $
(in-package :gsl) (in-package :gsl)
;;; I don't like using make-data-from-pointer. ;;; I don't like using make-data-from-pointer, but it's the only way
;;; to have access to the GSL functions when given a pointer.
;;; Alternatively, I could provide the GSL pointer and then the only
;;; thing the user could use is vref, or, of course
;;; make-data-from-pointer.
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Function definition ;;;; Function definition
...@@ -25,6 +29,16 @@ ...@@ -25,6 +29,16 @@
((dimensions ,dimensions)) ((dimensions ,dimensions))
((returned-value gsl-vector-c)))) ((returned-value gsl-vector-c))))
(cffi:defcstruct gsl-mfunction-fdf
;; See /usr/include/gsl/gsl_multiroots.h
"The definition of a function and its derivatives for multiroot
finding in GSL."
(function :pointer)
(df :pointer)
(fdf :pointer)
(dimensions :size)
(parameters :pointer))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Initialization ;;;; Initialization
;;;;**************************************************************************** ;;;;****************************************************************************
...@@ -55,7 +69,7 @@ ...@@ -55,7 +69,7 @@
(defun-gsl set-mfdfsolver (solver function-derivative initial) (defun-gsl set-mfdfsolver (solver function-derivative initial)
"gsl_multiroot_fdfsolver_set" "gsl_multiroot_fdfsolver_set"
((solver :pointer) (function-derivative :pointer) ((solver :pointer) (function-derivative :pointer)
((gsl-array initial) :pointer)) ((pointer initial) :pointer))
:documentation :documentation
"Set or reset an existing solver to use the function and derivative "Set or reset an existing solver to use the function and derivative
(fdf) and the initial guess.") (fdf) and the initial guess.")
...@@ -383,13 +397,22 @@ ...@@ -383,13 +397,22 @@
(defparameter *gsl-vector* (defparameter *gsl-vector*
(make-instance 'gsl-vector-double :pointer nil :storage-size nil)) (make-instance 'gsl-vector-double :pointer nil :storage-size nil))
;;; One alternative way of writing the function, not recommended.
(defun rosenbrock (argument return) (defun rosenbrock (argument return)
"Rosenbrock test function." "Rosenbrock test function."
(with-c-doubles (((gsl-array-p argument) x0 x1) (with-c-doubles (((vector-data argument) x0 x1)
((gsl-array-p return) f0 f1)) ((vector-data return) f0 f1))
(setf f0 (* *rosenbrock-a* (- 1 x0)) (setf f0 (* *rosenbrock-a* (- 1 x0))
f1 (* *rosenbrock-b* (- x1 (expt x0 2)))))) f1 (* *rosenbrock-b* (- x1 (expt x0 2))))))
;;; The recommended alternative
(defun rosenbrock (argument return)
"Rosenbrock test function."
(setf (vref return 0)
(* *rosenbrock-a* (- 1 (vref argument 0)))
(vref return 1)
(* *rosenbrock-b* (- (vref argument 1) (expt (vref argument 0) 2)))))
(def-mfunction rosenbrock 2) (def-mfunction rosenbrock 2)
(defun roots-multi-example () (defun roots-multi-example ()
...@@ -416,3 +439,51 @@ ...@@ -416,3 +439,51 @@
(gsl-aref argval 1) (gsl-aref argval 1)
(gsl-aref fnval 0) (gsl-aref fnval 0)
(gsl-aref fnval 1))))))))) (gsl-aref fnval 1)))))))))
(defun rosenbrock-df (argument jacobian)
"The partial derivatives of the Rosenbrock functions."
(setf (mref jacobian 0 0) (- *rosenbrock-a*)
(mref jacobian 0 1) 0.0d0
(mref jacobian 1 0) (* -2 *rosenbrock-b* (vref argument 0))
(mref jacobian 1 1) *rosenbrock-b*))
(defun rosenbrock-fdf (argument value jacobian)
(rosenbrock argument value)
(rosenbrock-df argument jacobian))
;;; Because def-solver-functions and def-scalar-function bind a symbol
;;; of the same name as the first function, and we want both to run,
;;; we'll make an alias function so we can use both.
(eval-when (:load-toplevel :execute)
(setf (fdefinition 'rosenbrock-f) #'rosenbrock))
(def-solver-functions rosenbrock-f rosenbrock-df rosenbrock-fdf 2)
(defun roots-multi-example-df ()