Commit 0dbbb5e4 authored by Liam Healy's avatar Liam Healy

Hacked changes define cbstruct in mobject maker

Have the mobject maker build the cbstruct.  This is now hacked in and
works with roots-multi in #'roots-multi-example-no-derivative, but
with #'make-multi-dimensional-root-solver-f having a hardwired
dimension of 2.  No clear way to communicate the dimension(s) from the
other part of the defmobject form.  Started to think/write a subclass
'callback-included of 'mobject, but this may be overkill as all
variables except 'dimensions are exclusive to the cbstruct maker
itself so don't really need to be class slots.
parent 7b9eb8c5
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-02 11:33:32EST callback.lisp>
;; Time-stamp: <2009-02-03 22:34:25EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -200,6 +200,7 @@
;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer)))))))
;;; To be deprecated
(defmacro defcbstruct
(functions &optional (structure 'gsl-function) additional-slots)
"Define a callback-related C struct used by GSL.
......@@ -224,6 +225,16 @@
,name ',structure ',(first slot) ,(second slot)))
,name)))
(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
do (set-slot-function cbstruct struct slot-name function))
(set-parameters cbstruct struct)
(when slots-values
(loop for (slot-name value) on slots-values by #'cddr
do (set-structure-slot cbstruct struct slot-name value)))
cbstruct))
(defun undef-cbstruct (object)
"Free foreign callback function. It is not necessary to do this; think
of the memory taken by an unused foreign function as much
......@@ -276,8 +287,16 @@
(defun cbname-for-cvectors (name)
(intern (format nil "~a-~a" name "CVECTOR")))
(defun callback-function-name (name callback-array-type)
(funcall
(case callback-array-type
(marray 'cbname-for-marrays)
(cvector 'cbname-for-cvectors)
(t 'identity))
name))
(defmacro defun*
(name args (dimensions-in dimensions-out) &body body)
(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)))
......@@ -288,13 +307,46 @@
`((defmcallback ,(cbname-for-marrays name)
:success-failure
((:double ,@dimin))
((:set :double ,@dimout))
,(mapcar (lambda (dims) `(:set :double ,@dims)) dimout)
t
,name)
(defmcallback ,(cbname-for-cvectors name)
:success-failure
((:double ,@dimin))
((:set :double ,@dimout))
,(mapcar (lambda (dims) `(:set :double ,@dims)) dimout)
nil
,name))
`((defmcallback ,name :success-failure :pointer :pointer))))))
;;;;****************************************************************************
;;;; PROPOSAL for including callback information
;;;;****************************************************************************
;;; 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))
(:documentation
"A mobject that includes a callback function or functions to GSL."))
(defmacro def-ci-subclass
(class-name documentation cbstruct-name array-type)
`(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))
(:documentation ,documentation)))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-02-02 11:26:12EST mobject.lisp>
;; Time-stamp: <2009-02-03 22:31:14EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -19,11 +19,13 @@
((mpointer :initarg :mpointer :reader mpointer
:documentation "A pointer to the GSL representation of the object.")))
(defconstant +callback-argument-name+ 'callback)
(defmacro defmobject
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
;;callbacks
callback callback-array-type
(superclasses '(mobject)))
"Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object."
......@@ -37,14 +39,20 @@
(maker (intern (format nil "MAKE-~:@(~a~)" class) :gsl))
(cl-alloc-args (variables-used-in-c-arguments allocation-args))
(cl-initialize-args
(variables-used-in-c-arguments 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)))
(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)))
......@@ -61,7 +69,8 @@
,@(when initializerp
(make-reinitialize-instance
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs))
initialize-suffix initialize-args inputs
callback callback-array-type))
(export ',maker)
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
......@@ -93,23 +102,48 @@
(defun make-reinitialize-instance
(class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs)
`((defmfun reinitialize-instance
((object ,class) &key ,@cl-initialize-args)
,(or initialize-name
(format nil "~a_~a" prefix
(if (listp initialize-suffix)
(first initialize-suffix)
initialize-suffix)))
(((mpointer object) :pointer) ,@initialize-args)
:definition :method
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
:return (object)
,@(when inputs `(:inputs ,inputs))
:export nil
:index (reinitialize-instance ,class))))
initialize-suffix initialize-args inputs
callback callback-array-type)
"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")))
`((defmfun reinitialize-instance
((object ,class)
&key
,@cl-initialize-args
,@(if
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)))))))
,(or initialize-name
(format nil "~a_~a" prefix
(if (listp initialize-suffix)
(first initialize-suffix)
initialize-suffix)))
(((mpointer object) :pointer)
,@(if callback
(subst cbstruct +callback-argument-name+ initialize-args)
initialize-args))
:definition :method
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
:return (object)
,@(when inputs `(:inputs ,inputs))
,@(when callback
`(:after
((trivial-garbage:finalize
object
(lambda ()
(cffi:foreign-free ,cbstruct))))))
:export nil
:index (reinitialize-instance ,class)))))
(defun mobject-maker
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-02-02 11:27:16EST roots-multi.lisp>
;;; Time-stamp: <2009-02-03 22:40:27EST roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -26,7 +26,10 @@
set or reset an existing solver to use the function and the
initial guess gsl-vector."
:initialize-suffix "set"
:initialize-args ((function :pointer) ((mpointer initial) :pointer))
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
:callback
(gsl-mfunction (dimensions 2) function function)
:callback-array-type marray
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
......@@ -47,6 +50,9 @@
:initialize-suffix "set"
:initialize-args
((function-derivative :pointer) ((mpointer initial) :pointer))
:callback
(gsl-mfunction (dimensions 2) function function df df fdf fdf)
:callback-array-type marray
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
......@@ -364,6 +370,7 @@
(defparameter *solver-nodf-cb*
(make-solver-functions rosenbrock nil nil 2))
;;; old way using macro make-solver-functions
(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."
......@@ -395,8 +402,35 @@
(maref fnval 0)
(maref fnval 1))))))
(defun* rosenbrock-df (arg0 arg1)
(2 (2 2))
;;; new way with make-multi-dimensional-root-solver-f making cbstruct
(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."
(let ((max-iter 1000)
(solver (make-multi-dimensional-root-solver-f
method 'rosenbrock #m(-10.0d0 -5.0d0))))
(loop for iter from 0
with fnval and argval
while (and (< iter max-iter)
(not (multiroot-test-residual solver 1.0d-7)))
do
(iterate solver)
(setf fnval (function-value solver)
argval (solution solver))
(when print-steps
(format t "iter=~d~8tx0=~12,8g~24tx1=~12,8g~38tf0=~12,8g~52tf1=~12,8g~&"
iter
(maref argval 0)
(maref argval 1)
(maref fnval 0)
(maref fnval 1)))
finally (return
(values (maref argval 0)
(maref argval 1)
(maref fnval 0)
(maref fnval 1))))))
(defun* rosenbrock-df (arg0 arg1) (2 (2 2))
"The partial derivatives of the Rosenbrock functions."
(declare (ignore arg1))
(values (- *rosenbrock-a*)
......@@ -405,7 +439,7 @@
*rosenbrock-b*))
;;; Why is it necessary to define a function that calls the two other functions?
(defun rosenbrock-fdf (arg0 arg1)
(defun* rosenbrock-fdf (arg0 arg1) (2 (2) (2 2))
(multiple-value-bind (v0 v1)
(rosenbrock arg0 arg1)
(multiple-value-bind (j0 j1 j2 j3)
......
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