Commit b44593b7 authored by Liam Healy's avatar Liam Healy

One-dimensional root solver ported to callbacks-included

The one-dimensional root solvers in roots-one.lisp now works in the
callbacks-included object, including both examples, with and without
derivatives.  The no-derivative case has been modified to
automatically listify the function name given.  For callbacks-included
classes that do not define 'dimensions (because they are
one-dimensional), there is a new macro def-ci-subclass-1d that makes
'dimensions slot a class slot with '(1).  Defined a print-object
method for callbacks-included classes.
parent 19dbbe90
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-07 17:19:18EST callback.lisp>
;; Time-stamp: <2009-02-08 17:39:32EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -315,6 +315,16 @@
(callback-labels :initform ',callback-labels :allocation :class))
(:documentation ,documentation)))
(defmacro def-ci-subclass-1d
(class-name documentation
cbstruct-name array-type callback-labels)
`(defclass ,class-name (callback-included)
((cbstruct-name :initform ',cbstruct-name :allocation :class)
(array-type :initform ',array-type :allocation :class)
(callback-labels :initform ',callback-labels :allocation :class)
(dimensions :initform '(1) :allocation :class))
(:documentation ,documentation)))
(defgeneric make-callbacks-fn (class args)
(:documentation "Function to make forms that expand into defmcallback(s)."))
......@@ -327,3 +337,10 @@
be called with two arguments; it should read the values from the first
array and write the answer in the second array."
(make-callbacks-fn class args))
(defmethod print-object ((object callback-included) stream)
(print-unreadable-object (object stream :type t :identity t)
(princ "for " stream)
(princ (first (functions object)) stream)
(princ ", dimensions " stream)
(princ (dimensions object) stream)))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-02-07 21:37:24EST mobject.lisp>
;; Time-stamp: <2009-02-08 18:36:40EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -48,7 +48,9 @@
(if (have-at-least-gsl-version gsl-version)
`(progn
,(if callbackp
`(def-ci-subclass ,class
`(,(if (member 'dimensions cl-alloc-args)
'def-ci-subclass 'def-ci-subclass-1d)
,class
,(format nil "The GSL representation of the ~a." description)
,@ci-class-slots)
`(defclass ,class ,superclasses
......
;; Generic functions for optimization
;; Liam Healy 2009-01-03 12:59:07EST generic.lisp
;; Time-stamp: <2009-01-24 20:09:47EST generic.lisp>
;; Time-stamp: <2009-02-08 15:15:15EST generic.lisp>
;; $Id: $
(in-package :gsl)
......@@ -59,6 +59,7 @@
(fdf :pointer)
(parameters :pointer))
;;; To be obsolete
(export 'make-solver-functions)
(defmacro make-solver-functions (function &optional df fdf dimensions array)
"Setup functions for solvers.
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2009-02-07 21:36:44EST roots-one.lisp>
;; Time-stamp: <2009-02-08 18:35:44EST roots-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -17,7 +17,12 @@
:superclasses (callback-included)
:ci-class-slots (gsl-function nil (function))
:initialize-suffix "set"
:initialize-args ((callback :pointer) (lower :double) (upper :double)))
:initialize-args ((callback :pointer) (lower :double) (upper :double))
:arglists-function
(lambda (set)
`((type &optional (function nil ,set) lower upper)
(:type type)
(:functions (list function) :lower lower :upper upper))))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
......@@ -34,8 +39,32 @@
(defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver"
((type :pointer))
"one-dimensional root solver with function and derivative"
:superclasses (callback-included)
:ci-class-slots (gsl-function-fdf nil (function df fdf))
:initialize-suffix "set"
:initialize-args ((function-derivative :pointer) (root-guess :double)))
:initialize-args ((callback :pointer) (root-guess :double)))
(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((class (eql 'one-dimensional-root-solver-fdf)) args)
;; This is "make-solver-functions"
(declare (ignore class))
(destructuring-bind (function df fdf) args
`(progn
(defmcallback ,function
:double :double
nil
nil
,function)
(defmcallback ,df
:double :double
nil
nil
,df)
(defmcallback ,fdf
:void :double ((:set :double 1) (:set :double 1))
nil
,fdf)))))
(defmfun name ((solver one-dimensional-root-solver-f))
"gsl_root_fsolver_name"
......@@ -295,17 +324,15 @@
(+ (* 2 a x) b))))
(make-callbacks one-dimensional-root-solver-f quadratic)
#+callback-toplevel-only
(defparameter *roots-one-noderiv-cb*
(make-single-function quadratic))
(make-callbacks one-dimensional-root-solver-fdf
quadratic quadratic-derivative quadratic-and-derivative)
(defun roots-one-example-no-derivative
(&optional (method *brent-fsolver*) (print-steps t))
"Solving a quadratic, the example given in Sec. 32.10 of the GSL manual."
(let ((max-iter 50)
(solver
(make-one-dimensional-root-solver-f method '(quadratic) 0.0d0 5.0d0)))
(make-one-dimensional-root-solver-f method 'quadratic 0.0d0 5.0d0)))
(when print-steps
(format t "iter ~6t [lower ~24tupper] ~36troot ~44terr ~54terr(est)~&"))
(loop for iter from 0
......@@ -323,11 +350,6 @@
(- upper lower)))
finally (return root))))
#+callback-toplevel-only
(defparameter *roots-one-deriv-cb*
(make-solver-functions
quadratic quadratic-derivative quadratic-and-derivative))
(defun roots-one-example-derivative
(&optional (method *newton-fdfsolver*) (print-steps t))
"Solving a quadratic, the example given in Sec. 32.10 of the GSL manual."
......@@ -335,11 +357,7 @@
(initial 5.0d0)
(solver (make-one-dimensional-root-solver-fdf
method
#-callback-toplevel-only
(make-solver-functions
quadratic quadratic-derivative quadratic-and-derivative)
#+callback-toplevel-only
*roots-one-deriv-cb*
'(quadratic quadratic-derivative quadratic-and-derivative)
initial)))
(when print-steps
(format t "iter ~6t ~8troot ~22terr ~34terr(est)~&"))
......
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