Skip to content
Snippets Groups Projects
Commit 13703fa9 authored by Liam M. Healy's avatar Liam M. Healy
Browse files

Arrays passed to and received from callbacks are foreign-arrays

Using the new function faify-form, pointers passed by GSL to callbacks
are converted to foreign-array objects if scalarsp is nil.  This has
been tested on multidimensional minimization only so far, and works.
Note that this is potentially inefficient, as each time the callback
is called, new objects are made and in the callback itself any grefs
involve a generic function dispatch.  However, it is easier to write
the callback than dealing with the raw pointer.
parent 336f1ceb
No related branches found
No related tags found
No related merge requests found
;; A grid:foreign-array with added metadata for GSL.
;; Liam Healy 2008-04-06 21:23:41EDT
;; Time-stamp: <2010-07-01 19:38:35EDT foreign-array.lisp>
;; Time-stamp: <2010-07-13 10:24:43EDT foreign-array.lisp>
;;
;; Copyright 2008, 2009, 2010 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -80,16 +80,16 @@
gsl-vector-c or gsl-matrix-c is given."
(let* ((cstruct
(case category
(:vector 'gsl-vector-c)
(:matrix 'gsl-matrix-c)
((vector :vector 1) 'gsl-vector-c)
((matrix :matrix 2) 'gsl-matrix-c)
(t (error "Unrecognized category ~a" category))))
(fa
(grid:make-grid
(case category
(:vector
((vector :vector 1)
`((foreign-array ,(cffi:foreign-slot-value mpointer cstruct 'size))
,element-type))
(:matrix
((matrix :matrix 2)
`((foreign-array
,(cffi:foreign-slot-value mpointer cstruct 'size0)
,(cffi:foreign-slot-value mpointer cstruct 'size1))
......
;; Generate a lambda that calls the user function; will be called by callback.
;; Liam Healy
;; Time-stamp: <2010-07-12 21:09:21EDT funcallable.lisp>
;; Time-stamp: <2010-07-13 10:37:28EDT funcallable.lisp>
;;
;; Copyright 2009, 2010 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -61,6 +61,21 @@
arg))
argspecs))
(defun faify-form (ptr argspec)
"Make the form that turns the mpointer into a foreign-array."
(ecase (parse-callback-argspec argspec 'array-type)
(:foreign-array ; a GSL mpointer
`(make-foreign-array-from-mpointer
,ptr
',(grid:cffi-cl (parse-callback-argspec argspec 'element-type))
,(length (parse-callback-argspec argspec 'dimensions))))
(:cvector ; a raw C vector
`(grid:make-foreign-array-from-pointer
,ptr
',(parse-callback-argspec argspec 'dimensions)
',(grid:cffi-cl (parse-callback-argspec argspec 'element-type))
t))))
;;;;****************************************************************************
;;;; Reference foreign elements and make multiple-value-bind form
;;;;****************************************************************************
......@@ -168,9 +183,10 @@
call-form))
`(funcall ,function-designator
,@(if outarrayp
(append inargs-names outargs-names)
(append (mapcar 'faify-form inargs-names inargs-specs)
(mapcar 'faify-form outargs-names outarrayp))
;; no arrays to return, just return the value
inargs-names)))
(mapcar 'faify-form inargs-names inargs-specs))))
,@(case
(parse-callback-fnspec fnspec 'return-spec)
(:success-failure
......
;; Multivariate minimization.
;; Liam Healy <Tue Jan 8 2008 - 21:28>
;; Time-stamp: <2010-07-12 21:28:04EDT minimization-multi.lisp>
;; Time-stamp: <2010-07-13 10:33:06EDT minimization-multi.lisp>
;;
;; Copyright 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -397,42 +397,47 @@
;;; vector-double-float. They could as well have been written to
;;; accept the correct number of scalar double-floats.
(defun paraboloid-vector (mpointer)
(defun paraboloid-vector (xy)
"A paraboloid function of two arguments, given in GSL manual Sec. 35.4.
This version takes a vector-double-float argument."
;; An alternative access to the passed-in vector would be to
;; bind a variable to
;; (make-foreign-array-from-mpointer mpointer 'double-float :vector)
;; and then call grid:gref on it.
(let ((x (get-value 'grid:vector-double-float mpointer 0))
(y (get-value 'grid:vector-double-float mpointer 1))
(let ((x (grid:gref xy 0))
(y (grid:gref xy 1))
(dp0 (aref *paraboloid-center* 0))
(dp1 (aref *paraboloid-center* 1)))
(+ (* 10 (expt (- x dp0) 2))
(* 20 (expt (- y dp1) 2))
30)))
(defun paraboloid-derivative
(arguments-gv-pointer derivative-gv-pointer)
(let ((x (get-value 'grid:vector-double-float arguments-gv-pointer 0))
(y (get-value 'grid:vector-double-float arguments-gv-pointer 1))
(defun paraboloid-derivative (xy output)
(let ((x (grid:gref xy 0))
(y (grid:gref xy 1))
(dp0 (aref *paraboloid-center* 0))
(dp1 (aref *paraboloid-center* 1)))
(setf (get-value 'grid:vector-double-float derivative-gv-pointer 0)
(setf (grid:gref output 0)
(* 20 (- x dp0))
(get-value 'grid:vector-double-float derivative-gv-pointer 1)
(grid:gref output 1)
(* 40 (- y dp1)))))
(defun paraboloid-and-derivative
(arguments-gv-pointer value-pointer derivative-gv-pointer)
(lu:print-variables arguments-gv-pointer value-pointer derivative-gv-pointer)
(prog1
(setf (grid:dcref value-pointer)
(setf (grid:gref value-pointer 0)
(paraboloid-vector arguments-gv-pointer))
(paraboloid-derivative
arguments-gv-pointer derivative-gv-pointer)))
(defun multimin-example-derivative
(&optional (method +conjugate-fletcher-reeves+) (print-steps t))
"This is an example solving the multidimensional minimization problem
of a paraboloid using the derivative. The callback functions
paraboloid-vector and paraboloid-derivative expect vectors.
Contrast this with multimin-example-derivative-scalars, which
expects and returns the scalar components."
(let* ((initial #m(5.0d0 7.0d0))
(minimizer
(make-multi-dimensional-minimizer-fdf
......@@ -472,6 +477,11 @@
(defun multimin-example-derivative-scalars
(&optional (method +conjugate-fletcher-reeves+) (print-steps t))
"This is an example solving the multidimensional minimization problem
of a paraboloid using the derivative. The callback functions
paraboloid-scalar and paraboloid-derivative-scalar expect scalars.
Contrast this with multimin-example-derivative, which
expects and returns vectors."
(let* ((initial #m(5.0d0 7.0d0))
(minimizer
(make-multi-dimensional-minimizer-fdf
......@@ -497,8 +507,6 @@
(let ((x (solution minimizer)))
(values (grid:gref x 0) (grid:gref x 1) (function-value minimizer)))))))
(save-test minimization-multi
(multimin-example-no-derivative +simplex-nelder-mead-on2+ nil)
(multimin-example-derivative +conjugate-fletcher-reeves+ nil)
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2010-06-30 19:57:28EDT roots-multi.lisp>
;;; Time-stamp: <2010-07-13 09:52:54EDT roots-multi.lisp>
;;
;; Copyright 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -376,6 +376,13 @@
;;;; Examples
;;;;****************************************************************************
;;; This is the example given in GSL manual, Sec. 35.8.
;;; http://www.gnu.org/software/gsl/manual/html_node/Example-programs-for-Multidimensional-Root-finding.html
;;; These examples use use scalarsp=T in the
;;; multi-dimensional-root-solver argument. To see how vectors would
;;; be used, see minimization-multi.
(defparameter *powell-A* 1.0d4)
(defun powell (arg0 arg1)
"Powell's test function."
......@@ -384,8 +391,6 @@
(+ (exp (- arg0)) (exp (- arg1)) (- (1+ (/ *powell-A*))))))
;; not used?
;;; This is the example given in Sec. 34.8.
(defparameter *rosenbrock-a* 1.0d0)
(defparameter *rosenbrock-b* 10.0d0)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment