Commit 42e73fd8 authored by Liam Healy's avatar Liam Healy

Class 'callback-included has slots with struct information

The class 'callback-included has the following slots:
cbstruct-name, array-type, callback-labels, functions, dimensions;
the first three will be :allocation :class in all subclasses.
This has been implemented and tested with the 
'multi-dimensional-root-solver-f object in roots-multi.lisp.  The
example #'roots-multi-example-no-derivative works.
parent 0dbbb5e4
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-03 22:34:25EST callback.lisp>
;; Time-stamp: <2009-02-05 22:46:20EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -227,7 +227,7 @@
(defun make-cbstruct (struct slots-values &rest function-slotnames)
(let ((cbstruct (cffi:foreign-alloc struct)))
(loop for (function slot-name) on function-slotnames by #'cddr
(loop for (slot-name function) on function-slotnames by #'cddr
do (set-slot-function cbstruct struct slot-name function))
(set-parameters cbstruct struct)
(when slots-values
......@@ -325,28 +325,29 @@
;;; Adding these slots would require a signficant modification to
(defclass callback-included (mobject)
((cbstruct-name :initarg :cbstruct-name :reader cbstruct-name
:documentation "The name of the GSL structure
representing the callback(s).")
(array-type :initarg :array-type :reader array-type
:documentation "A symbol 'marray or 'cvector.")
(functions :initarg :functions :reader functions
:documentation "The names of the function(s) put into
the callback. These should be the same as the slot
names in the struct.")
(dimensions :initarg dimensions :reader dimensions))
((cbstruct-name
:initarg :cbstruct-name :reader cbstruct-name
:documentation
"The name of the GSL structure representing the callback(s).")
(array-type
:initarg :array-type :reader array-type
:documentation "A symbol 'marray or 'cvector.")
(callback-labels
:initarg :callback-labels :reader callback-labels
:documentation "The labels in the GSL struct for each callback function.")
(functions
:initarg :functions :reader functions
:documentation "The names of the function(s) put into
the callback. These should correspond in order to
callback-labels.")
(dimensions :initarg :dimensions :reader dimensions))
(:documentation
"A mobject that includes a callback function or functions to GSL."))
(defmacro def-ci-subclass
(class-name documentation cbstruct-name array-type)
(class-name documentation cbstruct-name array-type callback-labels)
`(defclass ,class-name (callback-included)
((cbstruct-name :initarg ',cbstruct-name :reader cbstruct-name
:documentation "The name of the GSL structure
representing the callback(s)."
:allocation :class)
(array-type :initarg ',array-type :reader array-type
:documentation "A symbol 'marray or 'cvector."
:allocation :class))
((cbstruct-name :initform ',cbstruct-name :allocation :class)
(array-type :initform ',array-type :allocation :class)
(callback-labels :initform ',callback-labels :allocation :class))
(:documentation ,documentation)))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-02-03 22:31:14EST mobject.lisp>
;; Time-stamp: <2009-02-07 09:24:56EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -25,36 +25,36 @@
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
callback callback-array-type
(superclasses '(mobject)))
(superclasses '(mobject))
ci-class-slots)
"Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object."
;; Argument 'initialize-suffix: string appended to prefix to form
;; GSL function name or a list of such a string and the c-return
;; argument.
(let* ((settingp (make-symbol "SETTINGP"))
(callbackp (member 'callback-included superclasses))
(arglists
(when arglists-function
(funcall (coerce arglists-function 'function) settingp)))
(maker (intern (format nil "MAKE-~:@(~a~)" class) :gsl))
(cl-alloc-args (variables-used-in-c-arguments allocation-args))
(cl-initialize-args
(let ((vbls (variables-used-in-c-arguments initialize-args)))
(if (and callback (member +callback-argument-name+ vbls))
(append
(remove +callback-argument-name+ vbls)
(loop for (fn nil) on (cddr callback) by #'cddr
collect fn))
vbls)))
(remove +callback-argument-name+
(variables-used-in-c-arguments initialize-args)))
(initializerp (or initialize-name initialize-suffix))
(initargs ; arguments that are exclusively for reinitialize-instance
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
(if (have-at-least-gsl-version gsl-version)
`(progn
(defclass ,class ,superclasses
nil
(:documentation
,(format nil "The GSL representation of the ~a." description)))
,(if callbackp
`(def-ci-subclass ,class
,(format nil "The GSL representation of the ~a." description)
,@ci-class-slots)
`(defclass ,class ,superclasses
nil
(:documentation
,(format nil "The GSL representation of the ~a." description))))
(defmfun allocate ((object ,class) &key ,@cl-alloc-args)
,(or allocator (format nil "~a_alloc" prefix))
......@@ -70,7 +70,7 @@
(make-reinitialize-instance
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
callback callback-array-type))
callbackp))
(export ',maker)
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
......@@ -103,7 +103,7 @@
(defun make-reinitialize-instance
(class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
callback callback-array-type)
callback)
"Expand the reinitialize-instance form. In the GSL arglist, the callback
structure pointer should be named the value of +callback-argument-name+."
(let ((cbstruct (make-symbol "CBSTRUCT")))
......@@ -115,12 +115,10 @@
callback
`(&aux
(,cbstruct
(make-cbstruct
',(first callback) ',(second callback)
,@(loop for (function slotname) on (cddr callback) by #'cddr
append
`((callback-function-name ,function ',callback-array-type)
',slotname)))))))
(apply
'make-cbstruct
(cbstruct-name object) `(dimensions ,@(dimensions object))
(mapcan 'list (callback-labels object) (functions object)))))))
,(or initialize-name
(format nil "~a_~a" prefix
(if (listp initialize-suffix)
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-02-03 22:40:27EST roots-multi.lisp>
;;; Time-stamp: <2009-02-07 09:28:21EST roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -18,7 +18,7 @@
;;;;****************************************************************************
(defmobject multi-dimensional-root-solver-f "gsl_multiroot_fsolver"
((type :pointer) (dimension sizet))
((type :pointer) ((first dimensions) sizet))
"multi-dimensional root solver with function only"
:documentation ; FDL
"Make an instance of a solver of the type specified for a system of
......@@ -27,16 +27,15 @@
initial guess gsl-vector."
:initialize-suffix "set"
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
:callback
(gsl-mfunction (dimensions 2) function function)
:callback-array-type marray
:superclasses (callback-included)
:ci-class-slots (gsl-mfunction marray (function))
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
(:type type
:dimension
(if ,set (dim0 initial) function-or-dimension))
(:function function-or-dimension :initial initial)))
:dimensions
(if ,set (dimensions initial) (list function-or-dimension)))
(:functions (list function-or-dimension) :initial initial)))
:inputs (initial))
(defmobject multi-dimensional-root-solver-fdf "gsl_multiroot_fdfsolver"
......@@ -366,6 +365,9 @@
(* *rosenbrock-a* (- 1 arg0))
(* *rosenbrock-b* (- arg1 (expt arg0 2)))))
(DEFMCALLBACK ROSENBROCK :SUCCESS-FAILURE ((:DOUBLE 2))
((:SET :DOUBLE 2)) T ROSENBROCK)
#+callback-toplevel-only
(defparameter *solver-nodf-cb*
(make-solver-functions rosenbrock nil nil 2))
......
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