Commit ddee5998 authored by liam's avatar liam

New macro names #'defgo, #'defgo-s (formerely #'defun-letm,

#'set-asf); minor bug fixes.


git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3282 a3d8a0fb-c1db-0310-ace7-a616afeb9e30
parent 46514f3f
;; Chebyshev Approximations
;; Liam Healy Sat Nov 17 2007 - 20:36
;; Time-stamp: <2008-02-02 19:13:03EST chebyshev.lisp>
;; Time-stamp: <2008-02-03 13:22:58EST chebyshev.lisp>
;; $Id: $
(in-package :gsl)
......@@ -9,7 +9,7 @@
;;;; Creation and calculation of Chebyshev series
;;;;****************************************************************************
(set-asf (chebyshev order function lower-limit upper-limit)
(defgo-s (chebyshev order function lower-limit upper-limit)
allocate-chebyshev free-chebyshev initialize-chebyshev)
(defun-gsl allocate-chebyshev (order)
......
;; Using GSL storage.
;; Liam Healy, Sun Mar 26 2006 - 16:32
;; Time-stamp: <2008-02-02 23:37:58EST data.lisp>
;; Time-stamp: <2008-02-03 13:17:10EST data.lisp>
;; $Id: $
(in-package :gsl)
......@@ -103,11 +103,11 @@
;;(LONG-DOUBLE . "_long_double")
(COMPLEX . "_complex")))
(defmacro data-letm (type size-spec-is-list)
(defmacro data-go (type size-spec-is-list)
"Define the letm function for data types."
(let ((size-spec (if size-spec-is-list 'listp 'numberp))
(init-spec (if size-spec-is-list 'array-dimensions 'length)))
`(defun-letm ,type (size-or-initial &optional zero)
`(defgo ,type (size-or-initial &optional zero)
(let ((argsymb (gensym "ARG")))
(list
`(make-data ',',type ,zero
......@@ -132,7 +132,7 @@
collect `((nth ,i (storage-size object)) :size)))
(object-name (make-symbol-from-strings *gsl-prefix* cl-symbol)))
`(progn
(data-letm ,cl-symbol ,(eq superclass 'gsl-matrix))
(data-go ,cl-symbol ,(eq superclass 'gsl-matrix))
(defclass ,object-name (,superclass)
((cl-base-type :initform ',cl-base-type :reader cl-base-type
:allocation :class)))
......
;; Eigenvectors and eigenvalues
;; Liam Healy, Sun May 21 2006 - 19:52
;; Time-stamp: <2008-02-02 21:08:35EST eigensystems.lisp>
;; Time-stamp: <2008-02-03 13:22:47EST eigensystems.lisp>
;; $Id: $
(in-package :gsl)
......@@ -9,7 +9,7 @@
;;;; Real Symmetric Matrices
;;;;****************************************************************************
(set-asf (eigen-symm n) eigen-symm-alloc eigen-symm-free)
(defgo-s (eigen-symm n) eigen-symm-alloc eigen-symm-free)
(defun-gsl eigen-symm-alloc (n)
"gsl_eigen_symm_alloc" ((n :size))
......@@ -29,7 +29,7 @@
:documentation ; FDL
"Free the memory associated with the workspace w.")
(set-asf (eigen-symmv n) eigen-symmv-alloc eigen-symmv-free)
(defgo-s (eigen-symmv n) eigen-symmv-alloc eigen-symmv-free)
(defun-gsl eigen-symmv-alloc (n)
"gsl_eigen_symmv_alloc" ((n :size))
......@@ -82,7 +82,7 @@
;;;; Complex Hermitian Matrices
;;;;****************************************************************************
(set-asf (eigen-herm n) eigen-herm-alloc eigen-herm-free)
(defgo-s (eigen-herm n) eigen-herm-alloc eigen-herm-free)
(defun-gsl eigen-herm-alloc (n)
"gsl_eigen_herm_alloc" ((n :size))
......@@ -112,7 +112,7 @@
:invalidate (eval A)
:return (eval))
(set-asf (eigen-hermv n) eigen-hermv-alloc eigen-hermv-free)
(defgo-s (eigen-hermv n) eigen-hermv-alloc eigen-hermv-free)
(defun-gsl eigen-hermv-alloc (n)
"gsl_eigen_hermv_alloc" ((n :size))
......
;; Discrete Hankel Transforms.
;; Liam Healy, Sat Dec 8 2007 - 16:50
;; Time-stamp: <2008-02-02 19:24:27EST hankel.lisp>
;; Time-stamp: <2008-02-03 13:22:56EST hankel.lisp>
;; $Id: $
(in-package :gsl)
;;; Everything compiles, but not tested -- need example.
(set-asf (hankel size nu xmax) allocate-hankel free-hankel init-hankel)
(defgo-s (hankel size nu xmax) allocate-hankel free-hankel init-hankel)
(defun-gsl allocate-hankel (size)
"gsl_dht_alloc"
......
;; Utility definitions
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2008-02-02 23:22:56EST utility.lisp>
;; Time-stamp: <2008-02-03 13:31:47EST utility.lisp>
;; $Id: $
(in-package :gsl)
......@@ -11,7 +11,9 @@
(defparameter *gsl-prefix* 'gsl)
;;;;;;;;;;;; GSL objects
;;;;****************************************************************************
;;;; GSL objects
;;;;****************************************************************************
;;; Each object has a defun named after it. This function is used
;;; only internally by #'letm, but it is exported so that
......@@ -23,6 +25,10 @@
(defvar *not-for-users* nil)
(defmacro letm (bindings &body body)
"A macro to bind variables to GSL objects, possibly setting
initial values, and freeing them when done. The binding is as
in a let*; any bindings for non-GSL objects are done as in
a let*."
(let* (setters ; save setting forms
freers ; save freeing forms
assigns ; save global assignements
......@@ -65,7 +71,7 @@
form)))
;;; General definition for object creation
(defmacro defun-letm (symbol arglist &body body)
(defmacro defgo (symbol arglist &body body)
"Define a GSL object to be bound in a letm.
The body should return a list of two to four values.
The first is the allocation form, the second is
......@@ -84,11 +90,11 @@
,@body)))
;;; Specific, simple and common types of object creation
(defmacro set-asf (form allocate free &optional set (num-alloc-args 1))
(defmacro defgo-s (form allocate free &optional set (num-alloc-args 1))
"Make an object usable in letm with the arglist is the allocate
and set arglists appended."
(let ((symb (gensym "SASF")))
`(defun-letm ,(first form)
`(defgo ,(first form)
(,@(subseq (rest form) 0 num-alloc-args)
&optional
,@(when set `((,(nth num-alloc-args (rest form))
......
;; Interpolation allocation, initialization, and freeing.
;; Liam Healy, Sun Nov 4 2007 - 17:24
;; Time-stamp: <2008-02-02 22:22:59EST interpolation.lisp>
;; Time-stamp: <2008-02-03 13:17:11EST interpolation.lisp>
;; $Id: $
(in-package :gsl)
......@@ -8,7 +8,7 @@
;;; A spline is an interpolation that also stores the arrays xa and ya,
;;; so they need not be supplied on each call.
(defun-letm interpolation (type xa-or-size &optional ya)
(defgo interpolation (type xa-or-size &optional ya)
(list
`(allocate-interpolation ,type ,(if ya `(dim0 ,ya) xa-or-size))
'free-spline
......@@ -47,7 +47,7 @@
:documentation
"Frees the interpolation object @var{interp}.")
(defun-letm spline (type xa-or-size &optional ya)
(defgo spline (type xa-or-size &optional ya)
(list
`(allocate-spline ,type ,(if ya `(dim0 ,ya) xa-or-size))
'free-spline
......
......@@ -9,7 +9,7 @@
(in-package :gsl)
(set-asf (acceleration) allocate-acceleration free-acceleration nil 0)
(defgo-s (acceleration) allocate-acceleration free-acceleration nil 0)
(defun-gsl interpolation-search (x-array x low-index high-index)
"gsl_interp_bsearch"
......
;; Linear least squares, or linear regression
;; Liam Healy <2008-01-21 12:41:46EST linear-least-squares.lisp>
;; Time-stamp: <2008-02-03 11:31:47EST linear-least-squares.lisp>
;; Time-stamp: <2008-02-03 13:23:36EST linear-least-squares.lisp>
;; $Id: $
(in-package :gsl)
......@@ -125,7 +125,7 @@
;;;; Multiparameter fitting
;;;;****************************************************************************
(set-asf (fit-workspace number-of-observations number-of-parameters)
(defgo-s (fit-workspace number-of-observations number-of-parameters)
allocate-fit-workspace free-fit-workspace nil 2)
(defun-gsl allocate-fit-workspace (number-of-observations number-of-parameters)
......
;; Multivariate minimization.
;; Liam Healy <Tue Jan 8 2008 - 21:28>
;; Time-stamp: <2008-02-02 21:17:03EST minimization-multi.lisp>
;; Time-stamp: <2008-02-03 13:22:54EST minimization-multi.lisp>
;; $Id: $
(in-package :gsl)
......@@ -49,9 +49,9 @@
;;;;****************************************************************************
;;; Could have one fewer argument: dimension=(dim0 initial)
(set-asf (mfminimizer type dimension function intial step-size)
(defgo-s (mfminimizer type dimension function intial step-size)
allocate-mfminimizer free-mfminimizer set-mfminimizer 2)
(set-asf (mfdfminimizer type dimension function-derivative intitial step-size tolerance)
(defgo-s (mfdfminimizer type dimension function-derivative intitial step-size tolerance)
allocate-mfdfminimizer free-mfdfminimizer set-mfdfminimizer 2)
(defun-gsl allocate-mfminimizer (type dimension)
......
;; Univariate minimization
;; Liam Healy Tue Jan 8 2008 - 21:02
;; Time-stamp: <2008-02-02 21:12:20EST minimization-one.lisp>
;; Time-stamp: <2008-02-03 13:22:51EST minimization-one.lisp>
;; $Id: $
(in-package :gsl)
......@@ -9,7 +9,7 @@
;;;; Initialization
;;;;****************************************************************************
(set-asf (fminimizer type function minimum lower upper)
(defgo-s (fminimizer type function minimum lower upper)
allocate-fminimizer free-fminimizer set-fminimizer)
(defun-gsl allocate-fminimizer (type)
......
;; Monte Carlo Integration
;; Liam Healy Sat Feb 3 2007 - 17:42
;; Time-stamp: <2008-02-03 11:35:59EST monte-carlo.lisp>
;; Time-stamp: <2008-02-03 13:25:30EST monte-carlo.lisp>
;; $Id: $
(in-package :gsl)
......@@ -13,7 +13,7 @@
(dim :size)
(x :pointer))
(set-asf (monte-carlo-plain dim) monte-carlo-plain-alloc monte-carlo-plain-free)
(defgo-s (monte-carlo-plain dim) monte-carlo-plain-alloc monte-carlo-plain-free)
(defun-gsl monte-carlo-plain-alloc (dim)
"gsl_monte_plain_alloc"
......@@ -96,7 +96,7 @@
(hits-l :pointer)
(hits-r :pointer))
(set-asf (monte-carlo-miser dim) monte-carlo-miser-alloc monte-carlo-miser-free)
(defgo-s (monte-carlo-miser dim) monte-carlo-miser-alloc monte-carlo-miser-free)
(defun-gsl monte-carlo-miser-alloc (dim)
"gsl_monte_miser_alloc"
......@@ -198,7 +198,7 @@
(calls-per-box :uint)
(ostream :pointer))
(set-asf (monte-carlo-vegas dim) monte-carlo-vegas-alloc monte-carlo-vegas-free)
(defgo-s (monte-carlo-vegas dim) monte-carlo-vegas-alloc monte-carlo-vegas-free)
(defun-gsl monte-carlo-vegas-alloc (dim)
"gsl_monte_vegas_alloc"
......@@ -292,21 +292,21 @@
(lower (vector-double #(0.0d0 0.0d0 0.0d0)))
(upper (vector-double (vector pi pi pi)))
(rng (random-number-generator *mt19937* 0)))
(monte-carlo-integrate-plain monte-carlo-g lower upper nsamples rng ws)))))
(monte-carlo-integrate-plain monte-carlo-g lower upper nsamples rng ws)))
(defun random-walk-miser-example (&optional (nsamples 500000))
(letm ((ws (monte-carlo-miser 3))
(lower (vector-double #(0.0d0 0.0d0 0.0d0)))
(upper (vector-double (vector pi pi pi)))
(rng (random-number-generator *mt19937* 0)))
(monte-carlo-integrate-miser monte-carlo-g lower upper nsamples rng ws)))))
(monte-carlo-integrate-miser monte-carlo-g lower upper nsamples rng ws)))
(defun random-walk-vegas-example (&optional (nsamples 500000))
(letm ((ws (monte-carlo-vegas 3))
(lower (vector-double #(0.0d0 0.0d0 0.0d0)))
(upper (vector-double (vector pi pi pi)))
(rng (random-number-generator *mt19937* 0)))
(monte-carlo-integrate-vegas monte-carlo-g lower upper nsamples rng ws)))))
(monte-carlo-integrate-vegas monte-carlo-g lower upper nsamples rng ws)))
(lisp-unit:define-test monte-carlo
(lisp-unit:assert-first-fp-equal
......
;; Numerical integration
;; Liam Healy, Wed Jul 5 2006 - 23:14
;; Time-stamp: <2008-02-02 21:06:00EST numerical-integration.lisp>
;; Time-stamp: <2008-02-03 13:22:48EST numerical-integration.lisp>
;; $Id: $
;;; To do: QAWS, QAWO, QAWF, more tests
......@@ -36,7 +36,7 @@
;;;; QAG adaptive Gauss-Kronrod integration
;;;;****************************************************************************
(set-asf (integration-workspace size)
(defgo-s (integration-workspace size)
integration-workspace-alloc integration-workspace-free)
(defun-gsl integration-workspace-alloc (size)
......
......@@ -130,7 +130,7 @@
;;;; General Polynomial Equations
;;;;****************************************************************************
(set-asf (complex-workspace n)
(defgo-s (complex-workspace n)
allocate-complex-workspace free-complex-workspace)
(defun-gsl allocate-complex-workspace (n)
......
;; Discrete random variables
;; Liam Healy, Sat Nov 11 2006 - 21:51
;; Time-stamp: <2008-02-03 10:58:16EST discrete.lisp>
;; Time-stamp: <2008-02-03 13:22:45EST discrete.lisp>
;; $Id: $
(in-package :gsl)
......@@ -11,7 +11,7 @@
(A :pointer)
(F :pointer))
(set-asf (discrete-random probabilities) discrete-preprocess discrete-free)
(defgo-s (discrete-random probabilities) discrete-preprocess discrete-free)
(defun-gsl discrete-preprocess (probabilities)
"gsl_ran_discrete_preproc"
......
;; Generators of random numbers.
;; Liam Healy, Sat Jul 15 2006 - 14:43
;; Time-stamp: <2008-02-03 11:36:39EST generators.lisp>
;; Time-stamp: <2008-02-03 13:22:46EST generators.lisp>
;; $Id: $
(in-package :gsl)
......@@ -38,7 +38,7 @@
:generator generator)))
(if (eq generator t) (alloc instance) instance)))
(set-asf (random-number-generator type value)
(defgo-s (random-number-generator type value)
make-random-number-generator free rng-set 1)
;;;;****************************************************************************
......
;; Quasi-random sequences in arbitrary dimensions.
;; Liam Healy, Sun Jul 16 2006 - 15:54
;; Time-stamp: <2008-02-02 22:01:47EST quasi.lisp>
;; Time-stamp: <2008-02-03 13:22:46EST quasi.lisp>
;; $Id: $
(in-package :gsl)
......@@ -11,7 +11,7 @@
(defparameter *default-quasi-random-number-generator* nil)
(set-asf (quasi-random-number-generator dimension type)
(defgo-s (quasi-random-number-generator dimension type)
make-quasi-random-number-generator free nil 2)
(defun make-quasi-random-number-generator
......
;; Tdist distribution
;; Liam Healy, Sat Oct 7 2006 - 16:13
;; Time-stamp: <2008-02-03 11:27:51EST tdist.lisp>
;; Time-stamp: <2008-02-03 13:27:31EST tdist.lisp>
;; $Id: $
(in-package :gsl)
......@@ -59,11 +59,12 @@
"-0.160088628258d+01" "-0.170109355058d+01" "-0.437095974981d-01"
"0.127611592766d+00" "-0.197312182555d-01" "-0.653466611720d+00"
"0.203577132452d+00" "0.177650300478d+01")
(letm ((rng (random-number-generator *mt19937* 0)))
(rng-set rng 0)
(loop for i from 0 to 10
collect
(tdist rng 10.0d0)))))
(lisp-unit:fp-sequence
(letm ((rng (random-number-generator *mt19937* 0)))
(rng-set rng 0)
(loop for i from 0 to 10
collect
(tdist rng 10.0d0)))))
(lisp-unit:assert-first-fp-equal
"0.254647908947d+00"
(tdist-pdf 0.5d0 1.0d0))
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2008-02-02 22:22:20EST roots-multi.lisp>
;;; Time-stamp: <2008-02-03 13:17:08EST roots-multi.lisp>
;;; $Id: $
(in-package :gsl)
......@@ -43,14 +43,14 @@
;;;; Initialization
;;;;****************************************************************************
(defun-letm mfsolver (type function-derivative initial)
(defgo mfsolver (type function-derivative initial)
(list
`(allocate-mfsolver ,type (dim0 ,initial))
'free-mfsolver
(lambda (symb)
`(set-mfsolver ,symb ,function-derivative ,initial))))
(defun-letm mfdfsolver (type function-derivative initial)
(defgo mfdfsolver (type function-derivative initial)
(list
`(allocate-mfdfsolver ,type (dim0 ,initial))
'free-mfdfsolver
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2008-02-02 19:29:21EST roots-one.lisp>
;; Time-stamp: <2008-02-03 13:22:55EST roots-one.lisp>
;; $Id: $
(in-package :gsl)
......@@ -44,8 +44,8 @@
;;;; Initialization
;;;;****************************************************************************
(set-asf (fsolver type function lower upper) allocate-fsolver free-fsolver set-fsolver)
(set-asf (fdfsolver type function-derivative root-guess)
(defgo-s (fsolver type function lower upper) allocate-fsolver free-fsolver set-fsolver)
(defgo-s (fdfsolver type function-derivative root-guess)
allocate-fdfsolver free-fdfsolver set-fdfsolver)
(defun-gsl allocate-fsolver (type)
......
;; Series acceleration.
;; Liam Healy, Wed Nov 21 2007 - 18:41
;; Time-stamp: <2008-02-02 19:33:39EST series-acceleration.lisp>
;; Time-stamp: <2008-02-03 13:22:57EST series-acceleration.lisp>
;; $Id: $
(in-package :gsl)
......@@ -21,7 +21,7 @@
(dq-den :pointer)
(dsum :pointer))
(set-asf (levin order) allocate-levin free-levin)
(defgo-s (levin order) allocate-levin free-levin)
(defun-gsl allocate-levin (order)
"gsl_sum_levin_u_alloc"
......@@ -61,7 +61,7 @@
;;;; Acceleration with error estimation from truncation
;;;;****************************************************************************
(set-asf (levin-truncated order) allocate-levin-truncated free-levin-truncated)
(defgo-s (levin-truncated order) allocate-levin-truncated free-levin-truncated)
(defun-gsl allocate-levin-truncated (order)
"gsl_sum_levin_utrunc_alloc"
......
;; Wavelet transforms.
;; Liam Healy, Mon Nov 26 2007 - 20:43
;; Time-stamp: <2008-02-02 21:12:08EST wavelet.lisp>
;; Time-stamp: <2008-02-03 13:22:53EST wavelet.lisp>
;; $Id: $
(in-package :gsl)
......@@ -11,7 +11,7 @@
;;;; Allocation of wavelets
;;;;****************************************************************************
(set-asf (wavelet type member) allocate-wavelet free-wavelet nil 2)
(defgo-s (wavelet type member) allocate-wavelet free-wavelet nil 2)
(defun-gsl allocate-wavelet (type member)
"gsl_wavelet_alloc"
......@@ -69,7 +69,7 @@
:documentation
"The name of the wavelet family.")
(set-asf (wavelet-workspace size) allocate-wavelet-workspace free-wavelet-workspace)
(defgo-s (wavelet-workspace size) allocate-wavelet-workspace free-wavelet-workspace)
(defun-gsl allocate-wavelet-workspace (size)
"gsl_wavelet_workspace_alloc"
......
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