Commit 88076763 authored by Liam Healy's avatar Liam Healy

Add 'scalarsp, eliminate 'callback-dynamic from callback-included

Add the slot 'scalarsp and eliminate the slot 'callback-dynamic from
the class callback-included, and modify the defmobject uses
accordingly.  All dynamic quantities (function, scalarsp, dimensions)
will be set from slot values at run time.  This works for the objects
ported so far:
 (lisp-unit:run-tests chebyshev)
 CHEBYSHEV: 1 assertions passed, 0 failed.
 (lisp-unit:run-tests roots-one)
 ROOTS-ONE: 6 assertions passed, 0 failed.
 (lisp-unit:run-tests minimization-one)
 MINIMIZATION-ONE: 2 assertions passed, 0 failed.
Started working on roots-multi; it now compiles but does not run.
parent 2a96cfe3
;; Chebyshev Approximations
;; Liam Healy Sat Nov 17 2007 - 20:36
;; Time-stamp: <2009-03-14 19:23:41EDT chebyshev.lisp>
;; Time-stamp: <2009-03-18 20:54:02EDT chebyshev.lisp>
;; $Id$
(in-package :gsl)
......@@ -17,7 +17,6 @@
:documentation ; FDL
"Make a Chebyshev series of specified order."
:callbacks (callback gsl-function (function))
:callback-dynamic ((function))
:initialize-suffix "init"
:initialize-args
((callback :pointer) (lower-limit :double) (upper-limit :double))
......@@ -103,8 +102,6 @@
(defun chebyshev-step (x) (if (< x 0.5d0) 0.25d0 0.75d0))
;; (make-callbacks single-function chebyshev-step)
(defun chebyshev-table-example ()
(let ((steps 100))
(let ((cheb (make-chebyshev 40 'chebyshev-step 0.0d0 1.0d0)))
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-03-16 22:07:35EDT gsll.asd>
;; Time-stamp: <2009-03-18 21:21:18EDT gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -204,7 +204,7 @@
((:file "generic")
(:file "roots-one" :depends-on (generic))
(:file "minimization-one" :depends-on (generic))
;;(:file "roots-multi" :depends-on (roots-one generic))
(:file "roots-multi" :depends-on (roots-one generic))
;;(:file "minimization-multi" :depends-on (generic))
;;(:file "linear-least-squares")
;;(:file "nonlinear-least-squares" :depends-on (generic))
......
;; Definitions for macro expansion
;; Liam Healy 2009-03-15 14:50:28EDT callback-compile-defs.lisp
;; Time-stamp: <2009-03-15 14:53:24EDT callback-compile-defs.lisp>
;; Time-stamp: <2009-03-18 22:46:59EDT callback-compile-defs.lisp>
;; $Id: $
(in-package :gsl)
......@@ -18,17 +18,14 @@
(defun get-callbacks-for-class (class)
(gethash class *callbacks-for-classes*))
;; old dimensions
;; (when (dimension-names object)
;; (mapcan 'list (dimension-names object) (dimensions object)))
(defun make-cbstruct-object (class)
"Make the callback structure based on the mobject definition."
(let ((cbs (get-callbacks-for-class class)))
(unless cbs (error "Class ~a not defined." class))
`(make-cbstruct
',(parse-callback-static cbs 'callback-structure-type)
nil ; dimensions eventually, see above
(when (dimension-names object)
(mapcan 'list (dimension-names object) (dimensions object)))
,@(mapcan
'list
(mapcar
......
;; The mobject that defines callbacks
;; Liam Healy 2009-03-14 11:20:03EDT callback-included.lisp
;; Time-stamp: <2009-03-15 14:53:27EDT callback-included.lisp>
;; Time-stamp: <2009-03-18 20:57:19EDT callback-included.lisp>
;; $Id: $
(in-package :gsl)
......@@ -13,16 +13,17 @@
((callbacks
:initarg :callbacks :reader callbacks
:documentation "The specification form for static callback information.")
(callback-dynamic
:initarg :callback-dynamic :reader callback-dynamic
:documentation "A list of (function scalarsp dimensions &rest dimensions).")
(dimension-names
:initarg :dimension-names :reader dimension-names
:documentation "The names in the GSL struct for dimensions.")
(functions
:initarg :functions :reader functions
:initarg :functions :reader functions :initform nil
:documentation "The names of the function(s) defined by defmcallback.
These should correspond in order to the structure-slot-name list.")
(scalarsp
:initarg :scalarsp :reader scalarsp :initform t
:documentation "Whether the function expect to be passed and return
scalars or arrays.")
(dimensions :initarg :dimensions :reader dimensions))
(:documentation
"A mobject that includes a callback function or functions to GSL."))
......@@ -45,13 +46,22 @@
(class-name superclasses documentation)
`(defclass ,class-name ,superclasses
((dimension-names :initform nil :allocation :class)
(dimensions :initform '(1) :allocation :class))
(dimensions :initform '(1) :allocation :class)
(scalarsp :initform T :allocation :class))
(:documentation ,documentation)))
;;;;****************************************************************************
;;;; For making mobjects
;;;;****************************************************************************
(defun select-dynamic-values (object n)
(list (nth n (functions object))
(if (listp (scalarsp object))
(nth n (scalarsp object))
(scalarsp object))
(dimensions object)))
;;; This is expanded in defmfun to set the dynamic variables.
(defun callback-set-dynamic (callback-object arglist)
"Make a form to set the dynamic variable defining callbacks."
`((setf
......@@ -61,5 +71,4 @@
class
(number-of-callbacks (get-callbacks-for-class class))))
for n from 0
append
`(,symb (nth ,n (callback-dynamic ,callback-object)))))))
append `(,symb (select-dynamic-values ,callback-object ,n))))))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-03-15 14:56:45EDT mobject.lisp>
;; Time-stamp: <2009-03-18 20:19:39EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -51,8 +51,6 @@
;;; ci-class-slots OBSOLETE
;;; callbacks
;;; See callbacks.lisp
;;; callback-dynamic
;;; See callbacks.lisp
;;; superclasses
;;; List of superclasses other than 'mobject.
;;; singular
......@@ -63,7 +61,7 @@
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
class-slots-instance ci-class-slots callbacks callback-dynamic
class-slots-instance ci-class-slots callbacks
(superclasses (if callbacks '(callback-included) '(mobject)))
singular)
"Define the class, the allocate, initialize-instance and
......@@ -118,7 +116,7 @@
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular class-slots-instance callbacks callback-dynamic))
singular class-slots-instance callbacks))
`(progn
(export ',maker)
(defun ,maker (&rest args)
......@@ -183,7 +181,7 @@
(defun mobject-maker
(maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular class-slots-instance callbacks callback-dynamic)
singular class-slots-instance callbacks)
"Make the defun form that makes the mobject."
`(defun ,maker
,(if arglists
......@@ -204,11 +202,7 @@
(make-instance
',class
,@(when
callbacks
`(:callbacks
',callbacks
:callback-dynamic
,(cons 'cl:list (callback-dynamic-lister callback-dynamic))))
callbacks `(:callbacks ',callbacks))
,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance))
,@(when (callback-arg-p class-slots-instance)
(symbol-keyword-symbol 'functions))
......
;; Univariate minimization
;; Liam Healy Tue Jan 8 2008 - 21:02
;; Time-stamp: <2009-03-16 22:38:30EDT minimization-one.lisp>
;; Time-stamp: <2009-03-18 20:47:02EDT minimization-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -21,7 +21,6 @@
set to use the function and the initial search interval [lower,
upper], with a guess for the location of the minimum."
:callbacks (callback gsl-function (function))
:callback-dynamic ((function))
:initialize-suffix "set" ; should use set_with_values?
:initialize-args
((callback :pointer) (minimum :double) (lower :double) (upper :double))
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-02-16 09:56:43EST roots-multi.lisp>
;;; Time-stamp: <2009-03-18 21:23:59EDT roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -27,17 +27,19 @@
initial guess gsl-vector."
:initialize-suffix "set"
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
:superclasses (callback-included)
:ci-class-slots (gsl-mfunction marray (function))
:callbacks
(callback gsl-mfunction
(function :success-failure (:double :marray dim0)))
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
`((type &optional function-or-dimension (initial nil ,set) (scalarsp t))
(:type type
:dimensions
(if ,set (dimensions initial) function-or-dimension))
(:functions (list function-or-dimension) :initial initial)))
:dimensions
(if ,set (dimensions initial) function-or-dimension))
(:functions (list function-or-dimension) :initial initial :scalarsp scalarsp)))
:inputs (initial))
#| OBSOLETE
(def-make-callbacks
multi-dimensional-root-solver-f (function dimension &optional (scalars t))
(if scalars
......@@ -51,6 +53,7 @@
(:pointer) (:pointer)
T
,function)))
|#
(defmobject multi-dimensional-root-solver-fdf "gsl_multiroot_fdfsolver"
((type :pointer) ((first dimensions) sizet))
......@@ -62,8 +65,19 @@
(fdf) and the initial guess."
:initialize-suffix "set"
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
:superclasses (callback-included)
:ci-class-slots (gsl-mfunction-fdf marray (function df fdf))
;;:ci-class-slots (gsl-mfunction-fdf marray (function df fdf))
:callbacks
(callback gsl-mfunction-fdf
(function :success-failure
(:double :marray dim0)
(:double :marray dim0))
(df :success-failure
(:double :marray dim0)
(:double :marray dim0 dim1))
(ddf :success-failure
(:double :marray dim0)
(:double :marray dim0)
(:double :marray dim0 dim1)))
:arglists-function
(lambda (set)
`((type &optional function-or-dimension (initial nil ,set))
......@@ -73,6 +87,7 @@
(:functions function-or-dimension :initial initial)))
:inputs (initial))
#| OBSOLETE
(def-make-callbacks
multi-dimensional-root-solver-fdf
(function df fdf dimension &optional (array t))
......@@ -93,6 +108,7 @@
((:set :double ,dimension) (:set :double ,dimension ,dimension))
,array
,fdf)))
|#
(defmfun name ((solver multi-dimensional-root-solver-f))
"gsl_multiroot_fsolver_name"
......@@ -118,6 +134,7 @@
"gsl_multiroot_fsolver_iterate"
(((mpointer solver) :pointer))
:definition :method
:callback-object solver
:documentation ; FDL
"Perform a single iteration of the solver. The following errors may
be signalled: 'bad-function-supplied, the iteration encountered a
......@@ -130,6 +147,7 @@
"gsl_multiroot_fdfsolver_iterate"
(((mpointer solver) :pointer))
:definition :method
:callback-object solver
:documentation ; FDL
"Perform a single iteration of the solver. The following errors may
be signalled: 'bad-function-supplied, the iteration encountered a
......@@ -142,6 +160,7 @@
"gsl_multiroot_fsolver_root"
(((mpointer solver) :pointer))
:definition :method
:callback-object solver
:c-return (crtn :pointer)
:return ((make-marray 'double-float :from-pointer crtn))
:documentation ; FDL
......@@ -151,6 +170,7 @@
"gsl_multiroot_fdfsolver_root"
(((mpointer solver) :pointer))
:definition :method
:callback-object solver
:c-return (crtn :pointer)
:return ((make-marray 'double-float :from-pointer crtn))
:documentation
......@@ -398,7 +418,7 @@
(* *rosenbrock-a* (- 1 arg0))
(* *rosenbrock-b* (- arg1 (expt arg0 2)))))
(make-callbacks multi-dimensional-root-solver-f rosenbrock 2)
;;(make-callbacks multi-dimensional-root-solver-f rosenbrock 2)
(defun roots-multi-example-no-derivative
(&optional (method +hybrid-scaled+) (print-steps t))
......@@ -443,8 +463,7 @@
(rosenbrock-df arg0 arg1)
(values v0 v1 j0 j1 j2 j3))))
(make-callbacks multi-dimensional-root-solver-fdf
rosenbrock rosenbrock-df rosenbrock-fdf 2)
;;(make-callbacks multi-dimensional-root-solver-fdf rosenbrock rosenbrock-df rosenbrock-fdf 2)
(defun roots-multi-example-derivative
(&optional (method +gnewton-mfdfsolver+) (print-steps t))
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2009-03-16 22:39:39EDT roots-one.lisp>
;; Time-stamp: <2009-03-18 20:20:03EDT roots-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -17,7 +17,6 @@
:initialize-suffix "set"
:initialize-args ((callback :pointer) (lower :double) (upper :double))
:callbacks (callback gsl-function (function))
:callback-dynamic ((function))
:singular (function))
(defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver"
......@@ -30,7 +29,6 @@
(function)
(df)
(fdf :void :double (:double :cvector 1) (:double :cvector 1)))
:callback-dynamic ((function) (df) (fdf t))
:arglists-function
(lambda (set)
`((type &optional (function nil ,set) df fdf root-guess)
......
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