diff --git a/chebyshev.lisp b/chebyshev.lisp index 51b8a48003a916146e13b4838209e7ed24d1d661..272c382912a50299c81e76e213cf9c326101a881 100644 --- a/chebyshev.lisp +++ b/chebyshev.lisp @@ -1,6 +1,6 @@ ;; Chebyshev Approximations ;; Liam Healy Sat Nov 17 2007 - 20:36 -;; Time-stamp: <2008-02-03 13:22:58EST chebyshev.lisp> +;; Time-stamp: <2008-02-17 18:02:26EST chebyshev.lisp> ;; $Id: $ (in-package :gsl) @@ -12,36 +12,36 @@ (defgo-s (chebyshev order function lower-limit upper-limit) allocate-chebyshev free-chebyshev initialize-chebyshev) -(defun-gsl allocate-chebyshev (order) +(defmfun allocate-chebyshev (order) "gsl_cheb_alloc" - ((order :size)) + ((order size)) :c-return :pointer :export nil :index (letm chebyshev) - :documentation + :documentation ; FDL "Allocate a Chebyshev series of specified order and return a pointer to it.") -(defun-gsl free-chebyshev (chebyshev) +(defmfun free-chebyshev (chebyshev) "gsl_cheb_free" ((chebyshev :pointer)) :c-return :void :export nil :index (letm chebyshev) - :documentation + :documentation ; FDL "Free a previously allocated Chebyshev series.") -(defun-gsl initialize-chebyshev (chebyshev function lower-limit upper-limit) +(defmfun initialize-chebyshev (chebyshev function lower-limit upper-limit) "gsl_cheb_init" ((chebyshev :pointer) (function :pointer) (lower-limit :double) (upper-limit :double)) :export nil :index (letm chebyshev) - :documentation + :documentation ; FDL "Compute the Chebyshev approximation for the function over the range (lower-limit, upper-limit) to the previously specified order. The - computation of the Chebyshev approximation is an @math{O(n^2)} - process, and requires @math{n} function evaluations.") + computation of the Chebyshev approximation is an O(n^2) + process, and requires n function evaluations.") ;;;;**************************************************************************** ;;;; Chebyshev series evaluation @@ -51,45 +51,45 @@ ;;; to use the functions that do return error (and ignore it if ;;; desired) in the form of #'evaluate-chebyshev. -(defun-gsl evaluate-chebyshev-noerror (chebyshev x) +(defmfun evaluate-chebyshev-noerror (chebyshev x) "gsl_cheb_eval" ((chebyshev :pointer) (x :double)) :c-return :double :index evaluate-chebyshev :export nil - :documentation + :documentation ; FDL "Evaluate the Chebyshev series at a point x.") -(defun-gsl evaluate-chebyshev-noerror-order (chebyshev x order) +(defmfun evaluate-chebyshev-noerror-order (chebyshev x order) "gsl_cheb_eval_n" - ((chebyshev :pointer) (order :size) (x :double)) + ((chebyshev :pointer) (order size) (x :double)) :c-return :double :index evaluate-chebyshev :export nil - :documentation + :documentation ; FDL "Evaluate the Chebyshev series at a point x to at most the given order.") -(defun-gsl evaluate-chebyshev-full (chebyshev x) +(defmfun evaluate-chebyshev-full (chebyshev x) "gsl_cheb_eval_err" ((chebyshev :pointer) (x :double) (result :double) (abserr :double)) :index evaluate-chebyshev :export nil - :documentation + :documentation ; FDL "Evaluate the Chebyshev series at a point x, returning result and an estimate of its absolute error.") -(defun-gsl evaluate-chebyshev-order (chebyshev x order) +(defmfun evaluate-chebyshev-order (chebyshev x order) "gsl_cheb_eval_n_err" - ((chebyshev :pointer) (order :size) (x :double) (result :double) (abserr :double)) + ((chebyshev :pointer) (order size) (x :double) (result :double) (abserr :double)) :index evaluate-chebyshev :export nil - :documentation + :documentation ; FDL "Evaluate the Chebyshev series at a point x to at most the given order, returning result and an estimate of its absolute error.") (export 'evaluate-chebyshev) (defun-optionals evaluate-chebyshev (chebyshev x &optional order) - -full -order + -full -order ; FDL "Evaluate the Chebyshev series at a point x to at most the given order, returning result and an estimate of its absolute error.") @@ -97,18 +97,18 @@ ;;;; Derivatives and integrals ;;;;**************************************************************************** -(defun-gsl derivative-chebyshev (derivative chebyshev) +(defmfun derivative-chebyshev (derivative chebyshev) "gsl_cheb_calc_deriv" ((derivative :pointer) (chebyshev :pointer)) - :documentation + :documentation ; FDL "Compute the derivative of the Chebyshev series, storing the derivative coefficients in the previously allocated series. The two series must have been allocated with the same order.") -(defun-gsl integral-chebyshev (integral chebyshev) +(defmfun integral-chebyshev (integral chebyshev) "gsl_cheb_calc_integ" ((integral :pointer) (chebyshev :pointer)) - :documentation + :documentation ; FDL "Compute the integral of the Chebyshev series, storing the integral coefficients in the previously allocated series. The two series must have been allocated with the same order. @@ -147,7 +147,16 @@ (evaluate-chebyshev deriv x) (evaluate-chebyshev integ x)))) -(lisp-unit:define-test chebyshev - (lisp-unit:assert-equal - '("0.715920990169d+00" "-0.150199666581d+01" "0.172397194040d+00") - (lisp-unit:fp-sequence (chebyshev-point-example 0.55d0)))) + +#| +(make-tests chebyshev + (chebyshev-point-example 0.55d0)) +|# + +(LISP-UNIT:DEFINE-TEST CHEBYSHEV + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.7159209901689866d0 -1.5019966658054353d0 + 0.17239719403979925d0)) + (MULTIPLE-VALUE-LIST (CHEBYSHEV-POINT-EXAMPLE 0.55d0)))) + diff --git a/data/block.lisp b/data/block.lisp index 707781346c8fe3d8860bcc8224b050d7008fda60..0380173a9e2094483f75892d76d59cf9a78be181 100644 --- a/data/block.lisp +++ b/data/block.lisp @@ -1,17 +1,13 @@ -;******************************************************** -; file: block.lisp -; description: Blocks of data -; date: Mon Mar 27 2006 - 12:28 -; author: Liam M. Healy -; modified: Wed May 31 2006 - 19:00 -;******************************************************** -;;; $Id: $ +;; Blocks of data +;; Liam Healy, Mon Mar 27 2006 - 12:28 +;; Time-stamp: <2008-02-17 09:18:05EST block.lisp> +;; $Id: $ (in-package :gsl) ;;; Block definition (cffi:defcstruct block - (size :size) + (size size) (data :pointer)) (defdata "block" block-double double-float) diff --git a/data/combination.lisp b/data/combination.lisp index 8826f2f276e28cb9ee76a04f6d54e48ebe074808..a5e43b2b99046e023b0547deccfd509394672cba 100644 --- a/data/combination.lisp +++ b/data/combination.lisp @@ -1,6 +1,6 @@ ;; Combinations ;; Liam Healy, Sun Mar 26 2006 - 11:51 -;; Time-stamp: <2008-02-04 19:25:57EST combination.lisp> +;; Time-stamp: <2008-02-17 10:01:38EST combination.lisp> ;; $Id: $ (in-package :gsl) @@ -11,8 +11,8 @@ ;;; GSL-combination definition (cffi:defcstruct gsl-combination-c - (n :size) - (k :size) + (n size) + (k size) (data :pointer)) ;;; Allocation, freeing, reading and writing @@ -25,11 +25,11 @@ ;;;; Getting values ;;;;**************************************************************************** -(defun-gsl gsl-aref ((combination gsl-combination) &rest indices) +(defmfun gsl-aref ((combination gsl-combination) &rest indices) "gsl_combination_get" - (((pointer combination) :pointer) ((first indices) :size)) + (((pointer combination) :pointer) ((first indices) size)) :type :method - :c-return :size + :c-return size :documentation ; FDL "The ith element of the combination.") @@ -45,7 +45,7 @@ ;;;; Setting values ;;;;**************************************************************************** -(defun-gsl init-first (combination) +(defmfun init-first (combination) "gsl_combination_init_first" (((pointer combination) gsl-combination-c)) :c-return :void @@ -54,7 +54,7 @@ "Initialize the combination c to the lexicographically first combination, i.e. (0,1,2,...,k-1).") -(defun-gsl init-last (combination) +(defmfun init-last (combination) "gsl_combination_init_last" (((pointer combination) gsl-combination-c)) :c-return :void @@ -63,7 +63,7 @@ "Initialize the combination c to the lexicographically last combination, i.e. (n-k,n-k+1,...,n-1).") -(defun-gsl copy (destination source) +(defmfun copy (destination source) "gsl_combination_memcpy" (((pointer destination) gsl-combination-c) ((pointer source) gsl-combination-c)) @@ -77,23 +77,23 @@ ;;;; Combination properties ;;;;**************************************************************************** -(defun-gsl combination-range (c) +(defmfun combination-range (c) "gsl_combination_n" (((pointer c) gsl-combination-c)) - :c-return :size + :c-return size :documentation ; FDL "The range (n) of the combination c.") -(defun-gsl combination-size (c) +(defmfun combination-size (c) "gsl_combination_k" (((pointer c) gsl-combination-c)) - :c-return :size + :c-return size :documentation ; FDL "The number of elements (k) in the combination c.") #| ;;; Unnecessary, gsl-array serves this function. -(defun-gsl combination-data (c) +(defmfun combination-data (c) "gsl_combination_data" (((pointer c) gsl-combination-c)) :c-return :pointer @@ -101,7 +101,7 @@ "A pointer to the array of elements in the combination.") |# -(defun-gsl data-valid ((combination gsl-combination)) +(defmfun data-valid ((combination gsl-combination)) "gsl_combination_valid" (((pointer combination) :pointer)) :type :method @@ -115,7 +115,7 @@ ;;;; Combination functions ;;;;**************************************************************************** -(defun-gsl combination-next (c) +(defmfun combination-next (c) "gsl_combination_next" (((pointer c) gsl-combination-c)) :c-return :success-failure :invalidate (c) @@ -127,7 +127,7 @@ repeatedly applying this function will iterate through all possible combinations of a given order.") -(defun-gsl combination-previous (c) +(defmfun combination-previous (c) "gsl_combination_prev" (((pointer c) gsl-combination-c)) :c-return :success-failure @@ -142,33 +142,64 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test combination - (lisp-unit:assert-eql ; combination-range - 4 - (letm ((comb (combination 4 2 t))) - (combination-range comb))) - (lisp-unit:assert-eql ; combination-size - 2 - (letm ((comb (combination 4 2 t))) - (combination-size comb))) - (lisp-unit:assert-equal ; init-first, combination-next - '((0 1) (0 2) (0 3) (1 2) (1 3) (2 3)) - (letm ((comb (combination 4 2 t))) - (init-first comb) - (loop collect (data comb) - while (combination-next comb)))) - (lisp-unit:assert-equal ; init-last, combination-previous - '((2 3) (1 3) (1 2) (0 3) (0 2) (0 1)) - (letm ((comb (combination 4 2 t))) - (init-last comb) - (loop collect (data comb) - while (combination-previous comb)))) - (lisp-unit:assert-equal ; combination-next - '(NIL (0) (1) (2) (3) (0 1) (0 2) (0 3) (1 2) (1 3) (2 3) - (0 1 2) (0 1 3) (0 2 3) (1 2 3) (0 1 2 3)) - (loop for i from 0 to 4 - append - (letm ((comb (combination 4 i t))) - (init-first comb) - (loop collect (data comb) - while (combination-next comb)))))) +#| +(make-tests combination + (letm ((comb (combination 4 2 t))) ; combination-range + (combination-range comb)) + (letm ((comb (combination 4 2 t))) ; combination-size + (combination-size comb)) + (letm ((comb (combination 4 2 t))) ; init-first, combination-next + (init-first comb) + (loop collect (data comb) + while (combination-next comb))) + (letm ((comb (combination 4 2 t))) ; init-last, combination-previous + (init-last comb) + (loop collect (data comb) + while (combination-previous comb))) + (loop for i from 0 to 4 ; combination-next + append + (letm ((comb (combination 4 i t))) + (init-first comb) + (loop collect (data comb) + while (combination-next comb))))) +|# + +(LISP-UNIT:DEFINE-TEST COMBINATION + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 4) + (MULTIPLE-VALUE-LIST + (LETM ((COMB (COMBINATION 4 2 T))) + (COMBINATION-RANGE COMB)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2) + (MULTIPLE-VALUE-LIST + (LETM ((COMB (COMBINATION 4 2 T))) + (COMBINATION-SIZE COMB)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST (LIST 0 1) (LIST 0 2) (LIST 0 3) (LIST 1 2) + (LIST 1 3) (LIST 2 3))) + (MULTIPLE-VALUE-LIST + (LETM ((COMB (COMBINATION 4 2 T))) (INIT-FIRST COMB) + (LOOP COLLECT (DATA COMB) WHILE + (COMBINATION-NEXT COMB))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST (LIST 2 3) (LIST 1 3) (LIST 1 2) (LIST 0 3) + (LIST 0 2) (LIST 0 1))) + (MULTIPLE-VALUE-LIST + (LETM ((COMB (COMBINATION 4 2 T))) (INIT-LAST COMB) + (LOOP COLLECT (DATA COMB) WHILE + (COMBINATION-PREVIOUS COMB))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST (LIST) (LIST 0) (LIST 1) (LIST 2) (LIST 3) + (LIST 0 1) (LIST 0 2) (LIST 0 3) (LIST 1 2) + (LIST 1 3) (LIST 2 3) (LIST 0 1 2) (LIST 0 1 3) + (LIST 0 2 3) (LIST 1 2 3) (LIST 0 1 2 3))) + (MULTIPLE-VALUE-LIST + (LOOP FOR I FROM 0 TO 4 APPEND + (LETM ((COMB (COMBINATION 4 I T))) + (INIT-FIRST COMB) + (LOOP COLLECT (DATA COMB) WHILE + (COMBINATION-NEXT COMB))))))) + diff --git a/data/data.lisp b/data/data.lisp index 21863cb8ab46297c32fb6bf3a48cf4185094d781..a513c7aaef86bec56862c249fb1983e6c887a0bc 100644 --- a/data/data.lisp +++ b/data/data.lisp @@ -1,6 +1,6 @@ -;; Using GSL storage. +;; Using GSL bulk data (vectors, matrices, etc.) storage. ;; Liam Healy, Sun Mar 26 2006 - 16:32 -;; Time-stamp: <2008-02-10 15:30:20EST data.lisp> +;; Time-stamp: <2008-02-17 09:18:27EST data.lisp> ;; $Id: $ (in-package :gsl) @@ -94,7 +94,7 @@ (setf (pointer object) pointer)) ;;; (args (loop for i below dimensions collect (intern (format nil "I~d" i)))) -;;; (mapcar (lambda (v) `(,v :size)) args) +;;; (mapcar (lambda (v) `(,v size)) args) (defparameter *data-name-alist* '((FIXNUM . "_int") @@ -163,7 +163,7 @@ (flet ((gsl-name (function-name) (format nil "gsl_~a_~a" c-string function-name))) (let* ((cargs (loop for i below dimensions - collect `((nth ,i (storage-size object)) :size))) + collect `((nth ,i (storage-size object)) size))) (object-name (make-symbol-from-strings *gsl-prefix* cl-symbol))) `(progn (defclass ,object-name (,superclass) @@ -171,31 +171,31 @@ :allocation :class))) (data-go ,cl-symbol ,(or (member superclass '(gsl-matrix)) (member object-name '(gsl-combination)))) - (defun-gsl alloc ((object ,object-name)) + (defmfun alloc ((object ,object-name)) ,(gsl-name "alloc") ,cargs :type :method :c-return (cr :pointer) :return ((assign-pointer object cr))) - (defun-gsl calloc ((object ,object-name)) + (defmfun calloc ((object ,object-name)) ,(gsl-name "calloc") ,cargs :type :method :c-return (cr :pointer) :return ((assign-pointer object cr))) - (defun-gsl free ((object ,object-name)) + (defmfun free ((object ,object-name)) ,(gsl-name "free") (((pointer object) :pointer)) :type :method :c-return :void) - (defun-gsl write-binary ((object ,object-name) stream) + (defmfun write-binary ((object ,object-name) stream) ,(gsl-name "fwrite") ((stream :pointer) ((pointer object) :pointer)) :type :method) - (defun-gsl read-binary ((object ,object-name) stream) + (defmfun read-binary ((object ,object-name) stream) ,(gsl-name "fread") ((stream :pointer) ((pointer object) :pointer)) :type :method) - (defun-gsl write-formatted ((object ,object-name) stream format) + (defmfun write-formatted ((object ,object-name) stream format) ,(gsl-name "fprintf") ((stream :pointer) ((pointer object) :pointer) (format :string)) :type :method) - (defun-gsl read-formatted ((object ,object-name) stream format) + (defmfun read-formatted ((object ,object-name) stream format) ,(gsl-name "fscanf") ((stream :pointer) ((pointer object) :pointer) (format :string)) :type :method))))) @@ -213,13 +213,13 @@ ;;; (make-symbol-from-strings *gsl-prefix* 'vector-fixnum) ;;; GSL-VECTOR-FIXNUM -(defun defun-gsl-all (types ctypes string general-class args) - "A defun-gsl for each of the declared data types." +(defun defmfun-all (types ctypes string general-class args) + "A defmfun for each of the declared data types." `(progn ,@(loop for type in types for ctype in ctypes collect - `(defun-gsl ,(first args) + `(defmfun ,(first args) ;; Set the class name for the arglist ,(mapcar (lambda (x) diff --git a/data/matrix.lisp b/data/matrix.lisp index e36e6b9b8872d89ced1c185d561fa120188b5d89..ad7d1bb5c959fbf7290cf06979062b512536ad8d 100644 --- a/data/matrix.lisp +++ b/data/matrix.lisp @@ -1,6 +1,6 @@ ;; Matrices ;; Liam Healy, Sun Mar 26 2006 - 11:51 -;; Time-stamp: <2008-02-05 22:38:36EST matrix.lisp> +;; Time-stamp: <2008-02-17 09:45:48EST matrix.lisp> ;; $Id: $ (in-package :gsl) @@ -21,9 +21,9 @@ ;;; GSL-matrix definition (cffi:defcstruct gsl-matrix-c - (size1 :size) - (size2 :size) - (tda :size) + (size1 size) + (size2 size) + (tda size) (data :pointer) (block :pointer) (owner :int)) @@ -36,18 +36,18 @@ (defdata "matrix_int" matrix-fixnum fixnum gsl-matrix 2) (defdata "matrix_complex" matrix-complex complex gsl-matrix 2) -(defmacro defun-gsl-mdsfc (&rest args) - "A defun-gsl for matrices of double, single, fixnum, and complex." - (defun-gsl-all +(defmacro defmfun-mdsfc (&rest args) + "A defmfun for matrices of double, single, fixnum, and complex." + (defmfun-all '(double single fixnum complex) '(:double :float :int gsl-complex) "matrix" 'gsl-matrix args)) -(defmacro defun-gsl-mdsf (&rest args) - "A defun-gsl for matrices of double, single, and fixnum." - (defun-gsl-all +(defmacro defmfun-mdsf (&rest args) + "A defmfun for matrices of double, single, and fixnum." + (defmfun-all '(double single fixnum) '(:double :float :int) "matrix" @@ -67,18 +67,18 @@ ;;;; Getting values ;;;;**************************************************************************** -(defun-gsl-mdsfc gsl-aref ((matrix gsl-matrix) &rest indices) +(defmfun-mdsfc gsl-aref ((matrix gsl-matrix) &rest indices) "gsl_matrix_get" (((pointer matrix) :pointer) - ((first indices) :size) - ((second indices) :size)) + ((first indices) size) + ((second indices) size)) :c-return :c-base-type :documentation ; FDL "The (i,j)-th element of the matrix.") -(defun-gsl mref (pointer index0 index1) +(defmfun mref (pointer index0 index1) "gsl_matrix_get" - ((pointer :pointer) (index0 :size) (index1 :size)) + ((pointer :pointer) (index0 size) (index1 size)) :c-return :double :index nil :documentation ; FDL @@ -89,8 +89,8 @@ (:documentation "A pointer to the i,j-th element of a matrix.")) -(defun-gsl-mdsfc gsl-matrix-ptr ((matrix gsl-matrix) i j) - "gsl_matrix_ptr" (((pointer matrix) :pointer) (i :size) (j :size)) +(defmfun-mdsfc gsl-matrix-ptr ((matrix gsl-matrix) i j) + "gsl_matrix_ptr" (((pointer matrix) :pointer) (i size) (j size)) :c-return :pointer) (defmethod data ((object gsl-matrix) &optional array) @@ -111,19 +111,19 @@ ;;;; Setting values ;;;;**************************************************************************** -(defun-gsl-mdsfc (setf gsl-aref) (value (matrix gsl-matrix) &rest indices) +(defmfun-mdsfc (setf gsl-aref) (value (matrix gsl-matrix) &rest indices) "gsl_matrix_set" (((pointer matrix) :pointer) - ((first indices) :size) - ((second indices) :size) + ((first indices) size) + ((second indices) size) (value :c-base-type)) :c-return :void :documentation ; FDL "Set the (i,j)-th element of the matrix.") -(defun-gsl (setf mref) (value pointer index0 index1) +(defmfun (setf mref) (value pointer index0 index1) "gsl_matrix_set" - ((pointer :pointer) (index0 :size) (index1 :size) (value :double)) + ((pointer :pointer) (index0 size) (index1 size) (value :double)) :c-return :void :index nil :documentation ; FDL @@ -140,17 +140,17 @@ do (setf (gsl-aref object i j) (aref array i j))))) -(defun-gsl-mdsfc set-all ((object gsl-matrix) value) +(defmfun-mdsfc set-all ((object gsl-matrix) value) "gsl_matrix_set_all" (((pointer object) :pointer) (value :c-base-type)) :c-return :void) -(defun-gsl-mdsfc set-zero ((object gsl-matrix)) +(defmfun-mdsfc set-zero ((object gsl-matrix)) "gsl_matrix_set_zero" (((pointer object) :pointer)) :c-return :void) -(defun-gsl-mdsfc set-identity ((matrix gsl-matrix)) +(defmfun-mdsfc set-identity ((matrix gsl-matrix)) "gsl_matrix_set_identity" (((pointer matrix) gsl-matrix-c)) :c-return :void :documentation ; FDL @@ -175,9 +175,9 @@ rows and n2 columns. The physical number of columns in memory is unchanged.")) -(defun-gsl-mdsfc submatrix ((matrix gsl-matrix) k1 k2 n1 n2) +(defmfun-mdsfc submatrix ((matrix gsl-matrix) k1 k2 n1 n2) "gsl_matrix_submatrix" - (((pointer matrix) gsl-matrix-c) (k1 :size) (k2 :size) (n1 :size) (n2 :size)) + (((pointer matrix) gsl-matrix-c) (k1 size) (k2 size) (n1 size) (n2 size)) :c-return gsl-matrix-view) (export 'matrix-array) @@ -187,9 +187,9 @@ matrix has n1 rows and n2 columns. The physical number of columns in memory is also given by n2.")) -(defun-gsl-mdsfc matrix-array ((matrix gsl-matrix) n1 n2) +(defmfun-mdsfc matrix-array ((matrix gsl-matrix) n1 n2) "gsl_matrix_view_array" - (((pointer matrix) gsl-matrix-c) (n1 :size) (n2 :size)) + (((pointer matrix) gsl-matrix-c) (n1 size) (n2 size)) :c-return gsl-matrix-view) (export 'matrix-array-tda) @@ -201,15 +201,15 @@ columns, and the physical number of columns in memory is given by tda.")) -(defun-gsl-mdsfc matrix-array-tda ((matrix gsl-matrix) n1 n2 tda) +(defmfun-mdsfc matrix-array-tda ((matrix gsl-matrix) n1 n2 tda) "gsl_matrix_view_array_with_tda" - (((pointer matrix) gsl-matrix-c) (n1 :size) (n2 :size) (tda :size)) + (((pointer matrix) gsl-matrix-c) (n1 size) (n2 size) (tda size)) :c-return gsl-matrix-view) -(defmacro defun-gsl-mvdsfc (&rest args) - "A defun-gsl for vectors of double, single, fixnum, and complex, +(defmacro defmfun-mvdsfc (&rest args) + "A defmfun for vectors of double, single, fixnum, and complex, translating to a GSL function named matrix_*." - (defun-gsl-all + (defmfun-all '(double single fixnum complex) '(:double :float :int gsl-complex) "matrix" @@ -232,9 +232,9 @@ vector. Of course, the original vector should not be deallocated while the view is still in use.")) -(defun-gsl-mvdsfc matrix-vector ((v gsl-vector) n1 n2) +(defmfun-mvdsfc matrix-vector ((v gsl-vector) n1 n2) "gsl_matrix_view_vector" - (((pointer v) gsl-vector-c) (n1 :size) (n2 :size)) + (((pointer v) gsl-vector-c) (n1 size) (n2 size)) :c-return gsl-matrix-view) (export 'matrix-vector-tda) @@ -255,9 +255,9 @@ vector. Of course, the original vector should not be deallocated while the view is still in use.")) -(defun-gsl-mvdsfc matrix-vector-tda ((v gsl-vector) n1 n2 tda) +(defmfun-mvdsfc matrix-vector-tda ((v gsl-vector) n1 n2 tda) "gsl_matrix_view_vector_with_tda" - (((pointer v) gsl-vector-c) (n1 :size) (n2 :size) (tda :size)) + (((pointer v) gsl-vector-c) (n1 size) (n2 size) (tda size)) :c-return gsl-matrix-view) ;;;;**************************************************************************** @@ -269,8 +269,8 @@ (:documentation ; FDL "A vector view of the ith row of the matrix.")) -(defun-gsl-mdsfc row-view ((matrix gsl-matrix) i) - "gsl_matrix_row" (((pointer matrix) gsl-matrix-c) (i :size)) +(defmfun-mdsfc row-view ((matrix gsl-matrix) i) + "gsl_matrix_row" (((pointer matrix) gsl-matrix-c) (i size)) :c-return gsl-vector-view :null-pointer-info (:EFAULT (format nil "index ~d out of range" i))) @@ -279,8 +279,8 @@ (:documentation ; FDL "A vector view of the jth column of the matrix.")) -(defun-gsl-mdsfc column-view ((matrix gsl-matrix) j) - "gsl_matrix_column" ((matrix gsl-matrix-c) (j :size)) +(defmfun-mdsfc column-view ((matrix gsl-matrix) j) + "gsl_matrix_column" ((matrix gsl-matrix-c) (j size)) :c-return gsl-matrix-view :null-pointer-info (:EFAULT (format nil "index ~d out of range" j))) @@ -292,7 +292,7 @@ For a rectangular matrix the length of the diagonal is the same as the smaller dimension of the matrix.")) -(defun-gsl-mdsfc diagonal-view ((matrix gsl-matrix)) +(defmfun-mdsfc diagonal-view ((matrix gsl-matrix)) "gsl_matrix_diagonal" ((matrix gsl-matrix-c)) :c-return gsl-matrix-view) @@ -303,8 +303,8 @@ required to be square. The diagonal of the matrix corresponds to k = 0.")) -(defun-gsl-mdsfc subdiagonal-view ((matrix gsl-matrix) k) - "gsl_matrix_subdiagonal" ((matrix gsl-matrix-c) (k :size)) +(defmfun-mdsfc subdiagonal-view ((matrix gsl-matrix) k) + "gsl_matrix_subdiagonal" ((matrix gsl-matrix-c) (k size)) :c-return gsl-matrix-view) (export 'superdiagonal-view) @@ -313,16 +313,16 @@ "A vector view of the kth superdiagonal of the matrix; it is not required to be square. The diagonal of the matrix corresponds to k = 0.")) -(defun-gsl-mdsfc superdiagonal-view ((matrix gsl-matrix) k) +(defmfun-mdsfc superdiagonal-view ((matrix gsl-matrix) k) "gsl_matrix_superdiagonal" - ((matrix gsl-matrix-c) (k :size)) + ((matrix gsl-matrix-c) (k size)) :c-return gsl-matrix-view) ;;;;**************************************************************************** ;;;; Copying ;;;;**************************************************************************** -(defun-gsl-mdsfc copy ((destination gsl-matrix) (source gsl-matrix)) +(defmfun-mdsfc copy ((destination gsl-matrix) (source gsl-matrix)) "gsl_matrix_memcpy" (((pointer destination) gsl-matrix-c) ((pointer source) gsl-matrix-c)) :invalidate (destination) @@ -330,7 +330,7 @@ "Copy the elements of the matrix source into the matrix destination. The two matrices must have the same size.") -(defun-gsl-mdsfc swap ((m1 gsl-matrix) (m2 gsl-matrix)) +(defmfun-mdsfc swap ((m1 gsl-matrix) (m2 gsl-matrix)) "gsl_matrix_swap" (((pointer m1) gsl-matrix-c) ((pointer m2) gsl-matrix-c)) :invalidate (m1 m2) @@ -349,9 +349,9 @@ into the vector. The length of the vector must be the same as the length of the row.")) -(defun-gsl-mdsfc row ((vector gsl-vector) (matrix gsl-matrix) i) +(defmfun-mdsfc row ((vector gsl-vector) (matrix gsl-matrix) i) "gsl_matrix_get_row" - (((pointer vector) gsl-vector-c) ((pointer matrix) gsl-matrix-c) (i :size)) + (((pointer vector) gsl-vector-c) ((pointer matrix) gsl-matrix-c) (i size)) :invalidate (vector)) (export 'column) @@ -361,9 +361,9 @@ into the vector. The length of the vector must be the same as the length of the column.")) -(defun-gsl-mdsfc column ((vector gsl-vector) (matrix gsl-matrix) j) +(defmfun-mdsfc column ((vector gsl-vector) (matrix gsl-matrix) j) "gsl_matrix_get_col" - (((pointer vector) gsl-vector-c) ((pointer matrix) gsl-matrix-c) (j :size)) + (((pointer vector) gsl-vector-c) ((pointer matrix) gsl-matrix-c) (j size)) :invalidate (vector)) (export 'set-row) @@ -373,9 +373,9 @@ ith row of the matrix. The length of the vector must be the same as the length of the row.")) -(defun-gsl-mdsfc set-row ((matrix gsl-matrix) i (vector gsl-vector)) +(defmfun-mdsfc set-row ((matrix gsl-matrix) i (vector gsl-vector)) "gsl_matrix_set_row" - (((pointer matrix) gsl-matrix-c) (i :size) ((pointer vector) gsl-vector-c)) + (((pointer matrix) gsl-matrix-c) (i size) ((pointer vector) gsl-vector-c)) :invalidate (matrix)) (export 'set-column) @@ -384,9 +384,9 @@ "Copy the elements of the vector into the jth column of the matrix. The length of the vector must be the same as the length of the column.")) -(defun-gsl-mdsfc set-column ((matrix gsl-matrix) j (vector gsl-vector)) +(defmfun-mdsfc set-column ((matrix gsl-matrix) j (vector gsl-vector)) "gsl_matrix_set_col" - (((pointer matrix) gsl-matrix-c) (j :size) ((pointer vector) gsl-vector-c)) + (((pointer matrix) gsl-matrix-c) (j size) ((pointer vector) gsl-vector-c)) :invalidate (matrix)) (defun (setf row) (vector matrix i) (set-row matrix i vector)) @@ -401,9 +401,9 @@ (:documentation ; FDL "Exchange the ith and jth rows of the matrix in-place.")) -(defun-gsl-mdsfc swap-rows ((matrix gsl-matrix) i j) +(defmfun-mdsfc swap-rows ((matrix gsl-matrix) i j) "gsl_matrix_swap_rows" - (((pointer matrix) gsl-matrix-c) (i :size) (j :size)) + (((pointer matrix) gsl-matrix-c) (i size) (j size)) :invalidate (matrix)) (export 'swap-columns) @@ -411,9 +411,9 @@ (:documentation ; FDL "Exchange the ith and jth columns of the matrix in-place.")) -(defun-gsl-mdsfc swap-columns ((matrix gsl-matrix) i j) +(defmfun-mdsfc swap-columns ((matrix gsl-matrix) i j) "gsl_matrix_swap_columns" - (((pointer matrix) gsl-matrix-c) (i :size) (j :size)) + (((pointer matrix) gsl-matrix-c) (i size) (j size)) :invalidate (matrix)) (export 'swap-rowcol) @@ -423,9 +423,9 @@ matrix in-place. The matrix must be square for this operation to be possible.")) -(defun-gsl-mdsfc swap-rowcol ((matrix gsl-matrix) i j) +(defmfun-mdsfc swap-rowcol ((matrix gsl-matrix) i j) "gsl_matrix_swap_rowcol" - (((pointer matrix) gsl-matrix-c) (i :size) (j :size)) + (((pointer matrix) gsl-matrix-c) (i size) (j size)) :invalidate (matrix)) (export 'matrix-transpose-copy) @@ -435,7 +435,7 @@ by copying the elements. The dimensions of the destination matrix must match the transposed dimensions of the source.")) -(defun-gsl-mdsfc matrix-transpose-copy +(defmfun-mdsfc matrix-transpose-copy ((destination gsl-matrix) (source gsl-matrix)) "gsl_matrix_transpose_memcpy" (((pointer destination) gsl-matrix-c) ((pointer source) gsl-matrix-c)) @@ -448,7 +448,7 @@ of the matrix in-place. The matrix must be square for this operation to be possible.")) -(defun-gsl-mdsfc matrix-transpose ((matrix gsl-matrix)) +(defmfun-mdsfc matrix-transpose ((matrix gsl-matrix)) "gsl_matrix_transpose" (((pointer matrix) gsl-matrix-c)) :invalidate (matrix)) @@ -457,7 +457,7 @@ ;;;; Arithmetic operations ;;;;**************************************************************************** -(defun-gsl-mdsfc gsl+ ((a gsl-matrix) (b gsl-matrix)) +(defmfun-mdsfc gsl+ ((a gsl-matrix) (b gsl-matrix)) "gsl_matrix_add" (((pointer a) gsl-matrix-c) ((pointer b) gsl-matrix-c)) :invalidate (a) @@ -466,7 +466,7 @@ a'_i = a_i + b_i. The two matrices must have the same dimensions.") -(defun-gsl-mdsfc gsl- ((a gsl-matrix) (b gsl-matrix)) +(defmfun-mdsfc gsl- ((a gsl-matrix) (b gsl-matrix)) "gsl_matrix_sub" (((pointer a) gsl-matrix-c) ((pointer b) gsl-matrix-c)) :invalidate (a) :documentation ; FDL @@ -474,7 +474,7 @@ a, a'_i = a_i - b_i. The two matrices must have the same dimensions.") -(defun-gsl-mdsfc gsl* ((a gsl-matrix) (b gsl-matrix)) +(defmfun-mdsfc gsl* ((a gsl-matrix) (b gsl-matrix)) "gsl_matrix_mul_elements" (((pointer a) gsl-matrix-c) ((pointer b) gsl-matrix-c)) :invalidate (a) @@ -483,7 +483,7 @@ matrix b, a'(i,j) = a(i,j) * b(i,j). The two matrices must have the same dimensions.") -(defun-gsl-mdsfc gsl/ ((a gsl-matrix) (b gsl-matrix)) +(defmfun-mdsfc gsl/ ((a gsl-matrix) (b gsl-matrix)) "gsl_matrix_div_elements" (((pointer a) gsl-matrix-c) ((pointer b) gsl-matrix-c)) :invalidate (a) @@ -492,14 +492,14 @@ matrix b, a'(i,j) = a(i,j) / b(i,j). The two matrices must have the same dimensions.") -(defun-gsl-mdsfc gsl*c ((a gsl-matrix) x) +(defmfun-mdsfc gsl*c ((a gsl-matrix) x) "gsl_matrix_scale" (((pointer a) gsl-matrix-c) (x :c-base-type)) :invalidate (a) :documentation ; FDL "Multiply the elements of matrix a by the constant factor x, a'(i,j) = x a(i,j).") -(defun-gsl-mdsfc gsl+c ((a gsl-matrix) x) +(defmfun-mdsfc gsl+c ((a gsl-matrix) x) "gsl_matrix_add_constant" (((pointer a) gsl-matrix-c) (x :c-base-type)) :invalidate (a) :documentation ; FDL @@ -510,28 +510,28 @@ ;;;; Maximum and minimum elements ;;;;**************************************************************************** -(defun-gsl-mdsf gsl-max ((m gsl-matrix)) +(defmfun-mdsf gsl-max ((m gsl-matrix)) "gsl_matrix_max" (((pointer m) gsl-matrix-c)) :documentation ; FDL "The maximum value in the matrix m." :c-return :c-base-type) -(defun-gsl-mdsf gsl-min ((m gsl-matrix)) +(defmfun-mdsf gsl-min ((m gsl-matrix)) "gsl_matrix_min" (((pointer m) gsl-matrix-c)) :documentation ; FDL "The minimum value in the matrix m." :c-return :c-base-type) -(defun-gsl-mdsf gsl-minmax ((m gsl-matrix)) +(defmfun-mdsf gsl-minmax ((m gsl-matrix)) "gsl_matrix_minmax" (((pointer m) gsl-matrix-c) (min :c-base-type) (max :c-base-type)) :documentation ; FDL "The minimum and maximum values in the matrix m." :c-return :void) -(defun-gsl-mdsf gsl-max-index ((m gsl-matrix)) +(defmfun-mdsf gsl-max-index ((m gsl-matrix)) "gsl_matrix_max_index" - (((pointer m) gsl-matrix-c) (imax :size) (jmax :size)) + (((pointer m) gsl-matrix-c) (imax size) (jmax size)) :documentation ; FDL "The index of the maximum value in the matrix m When there are several equal maximum elements then the lowest index is @@ -539,9 +539,9 @@ :c-return :void :return ((list (scref imax) (scref jmax)))) -(defun-gsl-mdsf gsl-min-index ((m gsl-matrix)) +(defmfun-mdsf gsl-min-index ((m gsl-matrix)) "gsl_matrix_min_index" - (((pointer m) gsl-matrix-c) (imin :size) (jmin :size)) + (((pointer m) gsl-matrix-c) (imin size) (jmin size)) :documentation ; FDL "The index of the minimum value in the matrix m When there are several equal minimum elements then the @@ -549,10 +549,10 @@ :c-return :void :return ((list (scref imin) (scref jmin)))) -(defun-gsl-mdsf gsl-minmax-index ((m gsl-matrix)) +(defmfun-mdsf gsl-minmax-index ((m gsl-matrix)) "gsl_matrix_minmax_index" (((pointer m) gsl-matrix-c) - (imin :size) (jmin :size) (imax :size) (jmax :size)) + (imin size) (jmin size) (imax size) (jmax size)) :documentation ; FDL "The indices of the minimum and maximum values in the matrix m. When there are several equal minimum elements then the lowest index is @@ -565,7 +565,7 @@ ;;;; Properties ;;;;**************************************************************************** -(defun-gsl-mdsfc gsl-zerop ((m gsl-matrix)) +(defmfun-mdsfc gsl-zerop ((m gsl-matrix)) "gsl_matrix_isnull" ((m gsl-matrix-c)) :documentation ; FDL "All elements of matrix m are zero." @@ -575,122 +575,212 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test matrix-fixnum - (lisp-unit:assert-eql ;(setf gsl-aref), gsl-aref - 77 - (letm ((intmat (matrix-fixnum 2 2))) - (setf (gsl-aref intmat 0 1) 77) - (gsl-aref intmat 0 1))) - (lisp-unit:assert-equalp ;(setf data) - #2A((4 6) (8 2)) - (letm ((intmat (matrix-fixnum 2 2))) - (setf (data intmat) #2A((4 6) (8 2))) - (data intmat))) - (lisp-unit:assert-equalp ;set-zero - #2A((0 0) (0 0)) - (letm ((intmat (matrix-fixnum 2 2))) - (set-zero intmat) - (data intmat))) - (lisp-unit:assert-equalp ;set-all - #2A((44 44)(44 44)) - (letm ((intmat (matrix-fixnum 2 2))) - (set-all intmat 44) - (data intmat))) - (lisp-unit:assert-equalp ;set-identity - #2A((1 0)(0 1)) - (letm ((intmat (matrix-fixnum 2 2))) - (set-identity intmat) - (data intmat))) - (lisp-unit:assert-equalp ;row - #(4 6) - (letm ((intmat (matrix-fixnum #2A((4 6) (8 2)))) - (vect (vector-fixnum 2))) - (row vect intmat 0) - (data vect))) - (lisp-unit:assert-equalp ;column - #(6 2) - (letm ((intmat (matrix-fixnum #2A((4 6) (8 2)))) - (vect (vector-fixnum 2))) - (column vect intmat 1) - (data vect))) - (lisp-unit:assert-eql ;gsl-min - -12 - (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) - (gsl-min intmat))) - (lisp-unit:assert-eql ;gsl-max - 8 - (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) - (gsl-max intmat))) - (lisp-unit:assert-equal ;gsl-minmax - '(-12 8) - (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) - (multiple-value-list (gsl-minmax intmat)))) - (lisp-unit:assert-equal ;gsl-min-index - '(0 1) - (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) - (gsl-min-index intmat))) - (lisp-unit:assert-equal ;gsl-max-index - '(1 0) - (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) - (gsl-max-index intmat))) - (lisp-unit:assert-equal ;gsl-minmax-index - '((0 1) (1 0)) - (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) - (multiple-value-list (gsl-minmax-index intmat)))) - (lisp-unit:assert-equalp ;copy - #2A((1 2)(3 4)) - (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))) - (intmat2 (matrix-fixnum 2 2))) - (copy intmat2 intmat1) - (data intmat2))) - (lisp-unit:assert-equalp ;swap - #2A((5 6) (7 8)) - (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))) - (intmat2 (matrix-fixnum #2A((5 6) (7 8))))) - (swap intmat1 intmat2) - (data intmat1))) - (lisp-unit:assert-equalp ;swap-rows - #2A((3 4) (1 2)) - (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))) - (swap-rows intmat1 0 1) - (data intmat1))) - (lisp-unit:assert-equalp ;swap-columns - #2A((2 1) (4 3)) - (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))) - (swap-columns intmat1 0 1) - (data intmat1))) - (lisp-unit:assert-equalp ;swap-rowcol - #2A((2 4) (3 1)) - (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))) - (swap-rowcol intmat1 0 1) - (data intmat1)))) - -(lisp-unit:define-test matrix-double - (lisp-unit:assert-equalp - #2A((0.23d0 1.23d0 2.23d0) - (100.23d0 101.23d0 102.23d0) - (200.23d0 201.23d0 202.23d0) - (300.23d0 301.23d0 302.23d0) - (400.23d0 401.23d0 402.23d0) - (500.23d0 501.23d0 502.23d0) - (600.23d0 601.23d0 602.23d0) - (700.23d0 701.23d0 702.23d0) - (800.23d0 801.23d0 802.23d0) - (900.23d0 901.23d0 902.23d0)) - (letm ((mat (matrix-double 10 3))) - (loop for i from 0 below 10 - do - (loop for j from 0 below 3 - do (setf (gsl-aref mat i j) (+ 0.23d0 j (* 100 i))))) - (data mat))) - (lisp-unit:assert-equalp - #2A((1.0d0 2.0d0) (3.0d0 4.0d0)) - (letm ((mat (matrix-double #2A((1.0d0 2.0d0) (3.0d0 4.0d0)))) - (ans (matrix-double 2 2))) - (copy ans mat) - (data ans)) - (lisp-unit:assert-equalp - #2A((1.0d0 4.0d0) (9.0d0 16.0d0)) - (letm ((mat (matrix-double #2A((1.0d0 2.0d0) (3.0d0 4.0d0))))) - (gsl* mat mat) - (data mat))))) +#| +(make-tests matrix-fixnum + (letm ((intmat (matrix-fixnum 2 2))) ;(setf gsl-aref), gsl-aref + (setf (gsl-aref intmat 0 1) 77) + (gsl-aref intmat 0 1)) + (letm ((intmat (matrix-fixnum 2 2))) ;(setf data) + (setf (data intmat) #2A((4 6) (8 2))) + (data intmat)) + (letm ((intmat (matrix-fixnum 2 2))) ;set-zero + (set-zero intmat) + (data intmat)) + (letm ((intmat (matrix-fixnum 2 2))) ;set-all + (set-all intmat 44) + (data intmat)) + (letm ((intmat (matrix-fixnum 2 2))) ;set-identity + (set-identity intmat) + (data intmat)) + (letm ((intmat (matrix-fixnum #2A((4 6) (8 2)))) ;row + (vect (vector-fixnum 2))) + (row vect intmat 0) + (data vect)) + (letm ((intmat (matrix-fixnum #2A((4 6) (8 2)))) ;column + (vect (vector-fixnum 2))) + (column vect intmat 1) + (data vect)) + (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) ;gsl-min + (gsl-min intmat)) + (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) ;gsl-max + (gsl-max intmat)) + (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) ;gsl-minmax + (multiple-value-list (gsl-minmax intmat))) + (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) ;gsl-min-index + (gsl-min-index intmat)) + (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) ;gsl-max-index + (gsl-max-index intmat)) + (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3))))) ;gsl-minmax-index + (multiple-value-list (gsl-minmax-index intmat))) + (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))) ;copy + (intmat2 (matrix-fixnum 2 2))) + (copy intmat2 intmat1) + (data intmat2)) + (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))) ;swap + (intmat2 (matrix-fixnum #2A((5 6) (7 8))))) + (swap intmat1 intmat2) + (data intmat1)) + (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))) ;swap-rows + (swap-rows intmat1 0 1) + (data intmat1)) + (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))) ;swap-columns + (swap-columns intmat1 0 1) + (data intmat1)) + (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))) ;swap-rowcol + (swap-rowcol intmat1 0 1) + (data intmat1))) +|# + +(LISP-UNIT:DEFINE-TEST + MATRIX-FIXNUM + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 77) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM 2 2))) + (SETF (GSL-AREF INTMAT 0 1) 77) + (GSL-AREF INTMAT 0 1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((4 6) (8 2))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM 2 2))) + (SETF (DATA INTMAT) #2A((4 6) (8 2))) + (DATA INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((0 0) (0 0))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM 2 2))) (SET-ZERO INTMAT) + (DATA INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((44 44) (44 44))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM 2 2))) + (SET-ALL INTMAT 44) (DATA INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((1 0) (0 1))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM 2 2))) + (SET-IDENTITY INTMAT) (DATA INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(4 6)) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((4 6) (8 2)))) + (VECT (VECTOR-FIXNUM 2))) + (ROW VECT INTMAT 0) + (DATA VECT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(6 2)) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((4 6) (8 2)))) + (VECT (VECTOR-FIXNUM 2))) + (COLUMN VECT INTMAT 1) + (DATA VECT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST -12) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((-1 -12) (8 3))))) + (GSL-MIN INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 8) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((-1 -12) (8 3))))) + (GSL-MAX INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST -12 8)) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((-1 -12) (8 3))))) + (MULTIPLE-VALUE-LIST (GSL-MINMAX INTMAT))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 0 1)) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((-1 -12) (8 3))))) + (GSL-MIN-INDEX INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 1 0)) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((-1 -12) (8 3))))) + (GSL-MAX-INDEX INTMAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST (LIST 0 1) (LIST 1 0))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT (MATRIX-FIXNUM #2A((-1 -12) (8 3))))) + (MULTIPLE-VALUE-LIST + (GSL-MINMAX-INDEX INTMAT))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((1 2) (3 4))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT1 (MATRIX-FIXNUM #2A((1 2) (3 4)))) + (INTMAT2 (MATRIX-FIXNUM 2 2))) + (COPY INTMAT2 INTMAT1) (DATA INTMAT2)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((5 6) (7 8))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT1 (MATRIX-FIXNUM #2A((1 2) (3 4)))) + (INTMAT2 (MATRIX-FIXNUM #2A((5 6) (7 8))))) + (SWAP INTMAT1 INTMAT2) (DATA INTMAT1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((3 4) (1 2))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT1 (MATRIX-FIXNUM #2A((1 2) (3 4))))) + (SWAP-ROWS INTMAT1 0 1) (DATA INTMAT1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((2 1) (4 3))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT1 (MATRIX-FIXNUM #2A((1 2) (3 4))))) + (SWAP-COLUMNS INTMAT1 0 1) (DATA INTMAT1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((2 4) (3 1))) + (MULTIPLE-VALUE-LIST + (LETM ((INTMAT1 (MATRIX-FIXNUM #2A((1 2) (3 4))))) + (SWAP-ROWCOL INTMAT1 0 1) (DATA INTMAT1))))) + + +#| +(make-tests + matrix-double + (letm ((mat (matrix-double 10 3))) + (loop for i from 0 below 10 + do + (loop for j from 0 below 3 + do (setf (gsl-aref mat i j) (+ 0.23d0 j (* 100 i))))) + (data mat)) + (letm ((mat (matrix-double #2A((1.0d0 2.0d0) (3.0d0 4.0d0)))) + (ans (matrix-double 2 2))) + (copy ans mat) + (data ans)) + (letm ((mat (matrix-double #2A((1.0d0 2.0d0) (3.0d0 4.0d0))))) + (gsl* mat mat) + (data mat))) +|# + +(LISP-UNIT:DEFINE-TEST MATRIX-DOUBLE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + #2A((0.23d0 1.23d0 2.23d0) + (100.23d0 101.23d0 102.23d0) + (200.23d0 201.23d0 202.23d0) + (300.23d0 301.23d0 302.23d0) + (400.23d0 401.23d0 402.23d0) + (500.23d0 501.23d0 502.23d0) + (600.23d0 601.23d0 602.23d0) + (700.23d0 701.23d0 702.23d0) + (800.23d0 801.23d0 802.23d0) + (900.23d0 901.23d0 902.23d0))) + (MULTIPLE-VALUE-LIST + (LETM ((MAT (MATRIX-DOUBLE 10 3))) + (LOOP FOR I FROM 0 BELOW 10 DO + (LOOP FOR J FROM 0 BELOW 3 DO + (SETF (GSL-AREF MAT I J) + (+ 0.23d0 J (* 100 I))))) + (DATA MAT)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((1.0d0 2.0d0) (3.0d0 4.0d0))) + (MULTIPLE-VALUE-LIST + (LETM ((MAT (MATRIX-DOUBLE #2A((1.0d0 2.0d0) (3.0d0 4.0d0)))) + (ANS (MATRIX-DOUBLE 2 2))) + (COPY ANS MAT) (DATA ANS)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #2A((1.0d0 4.0d0) (9.0d0 16.0d0))) + (MULTIPLE-VALUE-LIST + (LETM ((MAT (MATRIX-DOUBLE #2A((1.0d0 2.0d0) (3.0d0 4.0d0))))) + (GSL* MAT MAT) (DATA MAT))))) + diff --git a/data/permutation.lisp b/data/permutation.lisp index a4e77df41b181f4d8b611debcf0e6d3347030db2..a8a2e7bf24356033b0dd9af579f44aca5704c5c7 100644 --- a/data/permutation.lisp +++ b/data/permutation.lisp @@ -1,6 +1,6 @@ ;; Permutations ;; Liam Healy, Sun Mar 26 2006 - 11:51 -;; Time-stamp: <2008-02-03 23:33:15EST permutation.lisp> +;; Time-stamp: <2008-02-17 09:56:49EST permutation.lisp> ;; $Id: $ (in-package :gsl) @@ -11,7 +11,7 @@ ;;; GSL-permutation definition (cffi:defcstruct gsl-permutation-c - (size :size) + (size size) (data :pointer)) ;;; Allocation, freeing, reading and writing @@ -24,27 +24,27 @@ ;;;; Getting values ;;;;**************************************************************************** -(defun-gsl gsl-aref ((permutation gsl-permutation) &rest indices) +(defmfun gsl-aref ((permutation gsl-permutation) &rest indices) "gsl_permutation_get" - (((pointer permutation) :pointer) ((first indices) :size)) + (((pointer permutation) :pointer) ((first indices) size)) :type :method - :c-return :size + :c-return size :documentation "The ith element of the permutation.") ; FDL ;;;;**************************************************************************** ;;;; Setting values ;;;;**************************************************************************** -(defun-gsl set-identity ((permutation gsl-permutation)) +(defmfun set-identity ((permutation gsl-permutation)) "gsl_permutation_init" (((pointer permutation) :pointer)) :type :method :c-return :void :documentation ; FDL "Initialize the permutation p to the identity, i.e. - (0,1,2,@dots{},n-1).") + (0,1,2,...,n-1).") -(defun-gsl copy ((destination gsl-permutation) (source gsl-permutation)) +(defmfun copy ((destination gsl-permutation) (source gsl-permutation)) "gsl_permutation_memcpy" (((pointer destination) gsl-permutation-c) ((pointer source) gsl-permutation-c)) @@ -54,9 +54,9 @@ "Copy the elements of the permutation source into the permutation destination. The two permutations must have the same size.") -(defun-gsl swap-elements ((p gsl-permutation) i j) +(defmfun swap-elements ((p gsl-permutation) i j) "gsl_permutation_swap" - (((pointer p) gsl-permutation-c) (i :size) (j :size)) + (((pointer p) gsl-permutation-c) (i size) (j size)) :type :method :invalidate (p) :documentation ; FDL @@ -66,14 +66,14 @@ ;;;; Permutation properties ;;;;**************************************************************************** -(defun-gsl permutation-size (p) +(defmfun permutation-size (p) "gsl_permutation_size" (((pointer p) gsl-permutation-c)) - :c-return :size + :c-return size :documentation ; FDL "The size of the permutation p.") -(defun-gsl permutation-data (p) +(defmfun permutation-data (p) "gsl_permutation_data" (((pointer p) gsl-permutation-c)) :c-return :pointer @@ -81,7 +81,7 @@ "A pointer to the array of elements in the permutation p.") -(defun-gsl data-valid ((permutation gsl-permutation)) +(defmfun data-valid ((permutation gsl-permutation)) "gsl_permutation_valid" (((pointer permutation) :pointer)) :type :method @@ -95,7 +95,7 @@ ;;;; Permutation functions ;;;;**************************************************************************** -(defun-gsl permutation-reverse (p) +(defmfun permutation-reverse (p) "gsl_permutation_reverse" (((pointer p) gsl-permutation-c)) :invalidate (p) @@ -103,14 +103,14 @@ :documentation ; FDL "Reverse the order of the elements of the permutation p.") -(defun-gsl permutation-inverse (inv p) +(defmfun permutation-inverse (inv p) "gsl_permutation_inverse" (((pointer inv) gsl-permutation-c) ((pointer p) gsl-permutation-c)) :invalidate (inv) :documentation ; FDL "Find the inverse of the permutation p.") -(defun-gsl permutation-next (p) +(defmfun permutation-next (p) "gsl_permutation_next" (((pointer p) gsl-permutation-c)) :c-return :success-failure @@ -123,7 +123,7 @@ repeatedly applying this function will iterate through all possible permutations of a given order.") -(defun-gsl permutation-previous (p) +(defmfun permutation-previous (p) "gsl_permutation_prev" (((pointer p) gsl-permutation-c)) :c-return :success-failure @@ -138,16 +138,16 @@ ;;;; Applying Permutations ;;;;**************************************************************************** -(defun-gsl permute (p data stride n) +(defmfun permute (p data stride n) "gsl_permute" - (((pointer p) gsl-permutation-c) (data :pointer) (stride :size) (n :size)) + (((pointer p) gsl-permutation-c) (data :pointer) (stride size) (n size)) :documentation ; FDL "Apply the permutation p to the array data of size n with stride stride.") -(defun-gsl permute-inverse (p data stride n) +(defmfun permute-inverse (p data stride n) "gsl_permute_inverse" - (((pointer p) gsl-permutation-c) (data :pointer) (stride :size) (n :size)) + (((pointer p) gsl-permutation-c) (data :pointer) (stride size) (n size)) :documentation ; FDL "Apply the inverse of the permutation p to the array data of size n with stride.") @@ -162,7 +162,7 @@ identity matrix. The permutation p and the vector v must have the same length.")) -(defun-gsl-vdsfc permute-vector (p (v gsl-vector)) +(defmfun-vdsfc permute-vector (p (v gsl-vector)) "gsl_permute_vector" (((pointer p) gsl-permutation-c) ((pointer v) gsl-vector-c)) :invalidate (v)) @@ -178,12 +178,12 @@ the p_j-th column of the identity matrix. The permutation p and the vector v must have the same length.")) -(defun-gsl-vdsfc permute-vector-inverse (p (v gsl-vector)) +(defmfun-vdsfc permute-vector-inverse (p (v gsl-vector)) "gsl_permute_vector_inverse" (((pointer p) gsl-permutation-c) ((pointer v) gsl-vector-c)) :invalidate (v)) -(defun-gsl permutation* (p pa pb) +(defmfun permutation* (p pa pb) "gsl_permutation_mul" (((pointer p) gsl-permutation-c) ((pointer pa) gsl-permutation-c) @@ -198,7 +198,7 @@ ;;;; Permutations in cyclic form ;;;;**************************************************************************** -(defun-gsl linear-to-canonical (q p) +(defmfun linear-to-canonical (q p) "gsl_permutation_linear_to_canonical" (((pointer q) gsl-permutation-c) ((pointer p) gsl-permutation-c)) :invalidate (q) @@ -206,7 +206,7 @@ "Compute the canonical form of the permutation p and stores it in the output argument q.") -(defun-gsl canonical-to-linear (p q) +(defmfun canonical-to-linear (p q) "gsl_permutation_canonical_to_linear" (((pointer p) gsl-permutation-c) ((pointer q) gsl-permutation-c)) :invalidate (p) @@ -214,9 +214,9 @@ "Convert a permutation q in canonical form back into linear form storing it in the output argument p.") -(defun-gsl inversions (p) +(defmfun inversions (p) "gsl_permutation_inversions" (((pointer p) gsl-permutation-c)) - :c-return :size + :c-return size :documentation ; FDL "Count the number of inversions in the permutation p. An inversion is any pair of elements that are not in order. @@ -224,16 +224,16 @@ the pairs (2,0) (2,1) and (3,1). The identity permutation has no inversions.") -(defun-gsl linear-cycles (p) +(defmfun linear-cycles (p) "gsl_permutation_linear_cycles" (((pointer p) gsl-permutation-c)) - :c-return :size + :c-return size :documentation ; FDL "Count the number of cycles in the permutation p, given in linear form.") -(defun-gsl canonical-cycles (p) +(defmfun canonical-cycles (p) "gsl_permutation_canonical_cycles" (((pointer p) gsl-permutation-c)) - :c-return :size + :c-return size :documentation ; FDL "Count the number of cycles in the permutation q, given in canonical form.") @@ -247,62 +247,121 @@ (loop collect (data perm 'list) while (permutation-next perm)))) -(lisp-unit:define-test permutation - (lisp-unit:assert-eql ;gsl-aref - 2 - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (gsl-aref perm-1 2))) - (lisp-unit:assert-equalp ;data - #(0 1 2 3) - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (data perm-1))) - (lisp-unit:assert-equalp ;permutation-reverse - #(3 2 1 0) - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (data (permutation-reverse perm-1)))) - (lisp-unit:assert-equalp ;permutation-next, permutation-inverse - #(0 3 1 2) - (letm ((perm-1 (permutation 4 t)) (perm-2 (permutation 4 t))) - (set-identity perm-1) - (permutation-next perm-1) - (permutation-next perm-1) - (permutation-next perm-1) - (permutation-inverse perm-2 perm-1) - (data perm-2))) - (lisp-unit:assert-equalp ;swap-elements - #(0 3 2 1) - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (swap-elements perm-1 1 3) - (data perm-1))) - (lisp-unit:assert-equalp ;permute-vector - #(33 44 11 22) - (letm ((perm-1 (permutation 4 t)) - (intvec (vector-fixnum #(11 22 33 44)))) - (set-identity perm-1) - (swap-elements perm-1 1 3) - (swap-elements perm-1 0 2) - (permute-vector perm-1 intvec) - (data intvec))) - (lisp-unit:assert-eql ;inversions - 3 - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (swap-elements perm-1 1 3) - (inversions perm-1))) - (lisp-unit:assert-eql ;linear-cycles - 3 - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (swap-elements perm-1 1 3) - (linear-cycles perm-1))) - (lisp-unit:assert-eql ;canonical-cycles - 2 - (letm ((perm-1 (permutation 4 t))) - (set-identity perm-1) - (swap-elements perm-1 1 3) - (swap-elements perm-1 0 2) - (canonical-cycles perm-1)))) +#| +(make-tests + permutation + (letm ((perm-1 (permutation 4 t))) ;gsl-aref + (set-identity perm-1) + (gsl-aref perm-1 2)) + (letm ((perm-1 (permutation 4 t))) ;data + (set-identity perm-1) + (data perm-1)) + (letm ((perm-1 (permutation 4 t))) ;permutation-reverse + (set-identity perm-1) + (data (permutation-reverse perm-1))) + (letm ;permutation-next, permutation-inverse + ((perm-1 (permutation 4 t)) (perm-2 (permutation 4 t))) + (set-identity perm-1) + (permutation-next perm-1) + (permutation-next perm-1) + (permutation-next perm-1) + (permutation-inverse perm-2 perm-1) + (data perm-2)) + (letm ((perm-1 (permutation 4 t))) ;swap-elements + (set-identity perm-1) + (swap-elements perm-1 1 3) + (data perm-1)) + (letm ((perm-1 (permutation 4 t)) ;permute-vector + (intvec (vector-fixnum #(11 22 33 44)))) + (set-identity perm-1) + (swap-elements perm-1 1 3) + (swap-elements perm-1 0 2) + (permute-vector perm-1 intvec) + (data intvec)) + (letm ((perm-1 (permutation 4 t))) ;inversions + (set-identity perm-1) + (swap-elements perm-1 1 3) + (inversions perm-1)) + (letm ((perm-1 (permutation 4 t))) ;linear-cycles + (set-identity perm-1) + (swap-elements perm-1 1 3) + (linear-cycles perm-1)) + (letm ((perm-1 (permutation 4 t))) ;canonical-cycles + (set-identity perm-1) + (swap-elements perm-1 1 3) + (swap-elements perm-1 0 2) + (canonical-cycles perm-1))) +|# + +(LISP-UNIT:DEFINE-TEST PERMUTATION + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (GSL-AREF PERM-1 2)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(0 1 2 3)) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (DATA PERM-1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(3 2 1 0)) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY + PERM-1) + (DATA (PERMUTATION-REVERSE PERM-1))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(0 3 1 2)) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T)) + (PERM-2 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (PERMUTATION-NEXT PERM-1) + (PERMUTATION-NEXT PERM-1) + (PERMUTATION-NEXT PERM-1) + (PERMUTATION-INVERSE PERM-2 PERM-1) + (DATA PERM-2)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(0 3 2 1)) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (SWAP-ELEMENTS PERM-1 1 3) + (DATA PERM-1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(33 44 11 22)) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T)) + (INTVEC (VECTOR-FIXNUM + #(11 22 33 44)))) + (SET-IDENTITY PERM-1) + (SWAP-ELEMENTS PERM-1 1 3) + (SWAP-ELEMENTS PERM-1 0 2) + (PERMUTE-VECTOR PERM-1 INTVEC) + (DATA INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 3) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (SWAP-ELEMENTS PERM-1 1 3) + (INVERSIONS PERM-1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 3) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (SWAP-ELEMENTS PERM-1 1 3) + (LINEAR-CYCLES PERM-1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2) + (MULTIPLE-VALUE-LIST + (LETM ((PERM-1 (PERMUTATION 4 T))) + (SET-IDENTITY PERM-1) + (SWAP-ELEMENTS PERM-1 1 3) + (SWAP-ELEMENTS PERM-1 0 2) + (CANONICAL-CYCLES PERM-1))))) + diff --git a/data/vector.lisp b/data/vector.lisp index 0aa4b457eed62b3d1047cc7628a9997e6427b499..9a0453896d46221773e35c73899424157b1882d0 100644 --- a/data/vector.lisp +++ b/data/vector.lisp @@ -1,6 +1,6 @@ ;; Vectors ;; Liam Healy, Sun Mar 26 2006 - 11:51 -;; Time-stamp: <2008-02-10 11:06:54EST vector.lisp> +;; Time-stamp: <2008-02-17 16:19:47EST vector.lisp> ;; $Id: $ (in-package :gsl) @@ -49,8 +49,8 @@ deallocated with the vector. ;;; GSL-vector definition (cffi:defcstruct gsl-vector-c - (size :size) - (stride :size) + (size size) + (stride size) (data :pointer) (block :pointer) (owner :int)) @@ -70,18 +70,18 @@ deallocated with the vector. ;;; doesn't work either 2008-02-10. -(defmacro defun-gsl-vdsfc (&rest args) - "A defun-gsl for vectors of double, single, fixnum, and complex." - (defun-gsl-all +(defmacro defmfun-vdsfc (&rest args) + "A defmfun for vectors of double, single, fixnum, and complex." + (defmfun-all '(double single fixnum complex) '(:double :float :int gsl-complex) "vector" 'gsl-vector args)) -(defmacro defun-gsl-vdsf (&rest args) - "A defun-gsl for vectors of double, single, and fixnum." - (defun-gsl-all +(defmacro defmfun-vdsf (&rest args) + "A defmfun for vectors of double, single, and fixnum." + (defmfun-all '(double single fixnum) '(:double :float :int) "vector" @@ -105,26 +105,33 @@ deallocated with the vector. sruct pointer." (cffi:foreign-slot-value pointer 'gsl-vector-c 'data)) +(defun element-size (object) + "The size of each element as stored in C." + (cffi:foreign-type-size + (rest (assoc (cl-base-type object) + '((double . :double) (single . :float) + (fixnum . :int) (complex . gsl-complex)))))) + ;;;;**************************************************************************** ;;;; Getting values ;;;;**************************************************************************** -(defun-gsl-vdsfc gsl-aref ((vector gsl-vector) &rest indices) +(defmfun-vdsfc gsl-aref ((vector gsl-vector) &rest indices) "gsl_vector_get" - (((pointer vector) :pointer) ((first indices) :size)) + (((pointer vector) :pointer) ((first indices) size)) :c-return :c-base-type :documentation ; FDL "The ith element of the vector.") -(defun-gsl vref (pointer index) +(defmfun vref (pointer index) "gsl_vector_get" - ((pointer :pointer) (index :size)) + ((pointer :pointer) (index size)) :c-return :double :index nil :documentation "An element of the vector of doubles, computed from the pointer.") -(defun-gsl gsl-vector-ptr (vector i) - "gsl_vector_ptr" (((pointer vector) :pointer) (i :size)) +(defmfun gsl-vector-ptr (vector i) + "gsl_vector_ptr" (((pointer vector) :pointer) (i size)) :c-return :pointer :documentation ; FDL "The ith element of the vector as a pointer.") @@ -133,32 +140,32 @@ deallocated with the vector. ;;;; Setting values ;;;;**************************************************************************** -(defun-gsl-vdsfc (setf gsl-aref) (value (vector gsl-vector) &rest indices) +(defmfun-vdsfc (setf gsl-aref) (value (vector gsl-vector) &rest indices) "gsl_vector_set" - (((pointer vector) :pointer) ((first indices) :size) (value :c-base-type)) + (((pointer vector) :pointer) ((first indices) size) (value :c-base-type)) :c-return :void :documentation ; FDL "Set an element of the vector.") -(defun-gsl (setf vref) (value pointer index) +(defmfun (setf vref) (value pointer index) "gsl_vector_set" - ((pointer :pointer) (index :size) (value :double)) + ((pointer :pointer) (index size) (value :double)) :c-return :void :index nil :documentation ; FDL "Set an element of the vector of doubles, using its pointer.") -(defun-gsl-vdsfc set-all ((object gsl-vector) value) +(defmfun-vdsfc set-all ((object gsl-vector) value) "gsl_vector_set_all" (((pointer object) :pointer) (value :c-base-type)) :c-return :void) -(defun-gsl-vdsfc set-zero ((object gsl-vector)) +(defmfun-vdsfc set-zero ((object gsl-vector)) "gsl_vector_set_zero" (((pointer object) :pointer)) :c-return :void) -(defun-gsl-vdsfc set-basis ((vector gsl-vector) index) - "gsl_vector_set_basis" (((pointer vector) gsl-vector-c) (index :size)) +(defmfun-vdsfc set-basis ((vector gsl-vector) index) + "gsl_vector_set_basis" (((pointer vector) gsl-vector-c) (index size)) :invalidate (vector) :documentation ; FDL "Set the index element to 1, and the rest to 0.") @@ -195,42 +202,42 @@ deallocated with the vector. Note that subvector views give direct access to the underlying elements of the original vector.")) -(defun-gsl-vdsfc subvector ((vector gsl-vector) offset size) +(defmfun-vdsfc subvector ((vector gsl-vector) offset size) "gsl_vector_subvector" - (((pointer vector) gsl-vector-c) (offset :size) (size :size)) + (((pointer vector) gsl-vector-c) (offset size) (size size)) :c-return :pointer) -(defun-gsl-vdsfc subvector-stride ((vector gsl-vector) offset stride size) +(defmfun-vdsfc subvector-stride ((vector gsl-vector) offset stride size) "gsl_vector_subvector_with_stride" (((pointer vector) gsl-vector-c) - (offset :size) (stride :size) (size :size)) + (offset size) (stride size) (size size)) :c-return :pointer) ;;; These require that the gsl-vector-complex structure be defined. #| -(defun-gsl vector-complex-real (vector) +(defmfun vector-complex-real (vector) "gsl_vector_complex_real" ((vector gsl-vector-complex)) :c-return :pointer :documentation "A vector view of the real parts of the complex vector v.") -(defun-gsl vector-complex-imag (vector) +(defmfun vector-complex-imag (vector) "gsl_vector_complex_imag"((vector gsl-vector-complex)) :c-return :pointer :documentation "A vector view of the imaginary parts of the complex vector v.") |# -(defun-gsl vector-array (base size) - "gsl_vector_view_array" ((base :pointer) (size :size)) +(defmfun vector-array (base size) + "gsl_vector_view_array" ((base :pointer) (size size)) :c-return :pointer :documentation ; FDL "A vector view of an array. The start of the new vector is given by base and has n elements.") -(defun-gsl vector-array-stride (base stride size) +(defmfun vector-array-stride (base stride size) "gsl_vector_view_array_with_stride" - ((base :pointer) (stride :size) (size :size)) + ((base :pointer) (stride size) (size size)) :c-return :pointer :documentation ; FDL "A vector view of an array with stride. The start of the new @@ -240,7 +247,7 @@ deallocated with the vector. ;;;; Copying ;;;;**************************************************************************** -(defun-gsl-vdsfc copy ((destination gsl-vector) (source gsl-vector)) +(defmfun-vdsfc copy ((destination gsl-vector) (source gsl-vector)) "gsl_vector_memcpy" (((pointer destination) gsl-vector-c) ((pointer source) gsl-vector-c)) :invalidate (destination) @@ -248,7 +255,7 @@ deallocated with the vector. "Copy the elements of the vector source into the vector destination. The two vectors must have the same length.") -(defun-gsl-vdsfc swap ((v gsl-vector) (w gsl-vector)) +(defmfun-vdsfc swap ((v gsl-vector) (w gsl-vector)) "gsl_vector_swap" (((pointer v) gsl-vector-c) ((pointer w) gsl-vector-c)) :invalidate (v w) :documentation ; FDL @@ -269,14 +276,14 @@ deallocated with the vector. (:documentation "Exchange the i-th and j-th elements of the vector vec in-place.")) -(defun-gsl-vdsfc swap-elements ((vec gsl-vector) i j) - "gsl_vector_swap_elements" (((pointer vec) gsl-vector-c) (i :size) (j :size)) +(defmfun-vdsfc swap-elements ((vec gsl-vector) i j) + "gsl_vector_swap_elements" (((pointer vec) gsl-vector-c) (i size) (j size)) :after ((when (listp (cl-invalid vec)) (push (list i) (cl-invalid vec)) (push (list j) (cl-invalid vec)))) :return (vec)) -(defun-gsl-vdsfc vector-reverse ((vec gsl-vector)) +(defmfun-vdsfc vector-reverse ((vec gsl-vector)) "gsl_vector_reverse" (((pointer vec) gsl-vector-c)) :invalidate (vec) :documentation ; FDL @@ -286,7 +293,7 @@ deallocated with the vector. ;;;; Arithmetic operations ;;;;**************************************************************************** -(defun-gsl-vdsf gsl+ ((a gsl-vector) (b gsl-vector)) +(defmfun-vdsf gsl+ ((a gsl-vector) (b gsl-vector)) "gsl_vector_add" (((pointer a) gsl-vector-c) ((pointer b) gsl-vector-c)) :invalidate (a) :documentation ; FDL @@ -294,34 +301,34 @@ deallocated with the vector. vector a, a'_i = a_i + b_i. The two vectors must have the same length.") -(defun-gsl-vdsf gsl- ((a gsl-vector) (b gsl-vector)) +(defmfun-vdsf gsl- ((a gsl-vector) (b gsl-vector)) "gsl_vector_sub" (((pointer a) gsl-vector-c) ((pointer b) gsl-vector-c)) :invalidate (a) :documentation ; FDL "Subtract the elements of vector b from the elements of vector a, a'_i = a_i - b_i. The two vectors must have the same length.") -(defun-gsl-vdsf gsl* ((a gsl-vector) (b gsl-vector)) +(defmfun-vdsf gsl* ((a gsl-vector) (b gsl-vector)) "gsl_vector_mul" (((pointer a) gsl-vector-c) ((pointer b) gsl-vector-c)) :invalidate (a) :documentation ; FDL "Multiply the elements of vector a by the elements of vector b, a'_i = a_i * b_i. The two vectors must have the same length.") -(defun-gsl-vdsf gsl/ ((a gsl-vector) (b gsl-vector)) +(defmfun-vdsf gsl/ ((a gsl-vector) (b gsl-vector)) "gsl_vector_div" (((pointer a) gsl-vector-c) ((pointer b) gsl-vector-c)) :invalidate (a) :documentation ; FDL "Divide the elements of vector a by the elements of vector b, a'_i = a_i / b_i. The two vectors must have the same length.") -(defun-gsl-vdsf gsl*c ((a gsl-vector) x) +(defmfun-vdsf gsl*c ((a gsl-vector) x) "gsl_vector_scale" (((pointer a) gsl-vector-c) (x :double)) :invalidate (a) :documentation ; FDL "Multiply the elements of vector a by the constant factor x, a'_i = x a_i.") -(defun-gsl-vdsf gsl+c ((a gsl-vector) x) +(defmfun-vdsf gsl+c ((a gsl-vector) x) "gsl_vector_add_constant" (((pointer a) gsl-vector-c) (x :double)) :invalidate (a) :documentation ; FDL @@ -331,43 +338,43 @@ deallocated with the vector. ;;;; Maximum and minimum elements ;;;;**************************************************************************** -(defun-gsl-vdsf gsl-max ((v gsl-vector)) +(defmfun-vdsf gsl-max ((v gsl-vector)) "gsl_vector_max" (((pointer v) gsl-vector-c)) :c-return :c-base-type :documentation ; FDL "The maximum value in the vector v.") -(defun-gsl-vdsf gsl-min ((v gsl-vector)) +(defmfun-vdsf gsl-min ((v gsl-vector)) "gsl_vector_min" (((pointer v) gsl-vector-c)) :c-return :c-base-type :documentation ; FDL "The minimum value in the vector v.") -(defun-gsl-vdsf gsl-minmax ((v gsl-vector)) +(defmfun-vdsf gsl-minmax ((v gsl-vector)) "gsl_vector_minmax" (((pointer v) gsl-vector-c) (min :c-base-type) (max :c-base-type)) :c-return :void :documentation ; FDL "The minimum and maximum values in the vector v.") -(defun-gsl-vdsf gsl-max-index ((v gsl-vector)) +(defmfun-vdsf gsl-max-index ((v gsl-vector)) "gsl_vector_max_index" (((pointer v) gsl-vector-c)) - :c-return :size + :c-return size :documentation ; FDL "The index of the maximum value in the vector v. When there are several equal minimum elements then the lowest index is returned.") -(defun-gsl-vdsf gsl-min-index ((v gsl-vector)) +(defmfun-vdsf gsl-min-index ((v gsl-vector)) "gsl_vector_min_index" (((pointer v) gsl-vector-c)) - :c-return :size + :c-return size :documentation ; FDL "The index of the minimum value in the vector v. When there are several equal minimum elements then the lowest index is returned.") -(defun-gsl-vdsf gsl-minmax-index ((v gsl-vector)) +(defmfun-vdsf gsl-minmax-index ((v gsl-vector)) "gsl_vector_minmax_index" - (((pointer v) gsl-vector-c) (imin :size) (imax :size)) + (((pointer v) gsl-vector-c) (imin size) (imax size)) :c-return :void :documentation ; FDL "The indices of the minimum and maximum values in the vector v. @@ -378,7 +385,7 @@ deallocated with the vector. ;;;; Properties ;;;;**************************************************************************** -(defun-gsl-vdsfc gsl-zerop ((v gsl-vector)) +(defmfun-vdsfc gsl-zerop ((v gsl-vector)) "gsl_vector_isnull" (((pointer v) gsl-vector-c)) :c-return :boolean :documentation ; FDL @@ -388,111 +395,196 @@ deallocated with the vector. ;;;; Examples and unit tests ;;;;**************************************************************************** -(lisp-unit:define-test vector-fixnum - (lisp-unit:assert-eql ;(setf gsl-aref), gsl-aref - 77 - (letm ((intvec (vector-fixnum 4))) - (setf (gsl-aref intvec 1) 77) - (gsl-aref intvec 1))) - (lisp-unit:assert-equalp ;(setf data) - #(4 6 8 2) - (letm ((intvec (vector-fixnum 4))) - (setf (data intvec) #(4 6 8 2)) - (data intvec))) - (lisp-unit:assert-equalp ;set-zero - #(0 0 0 0) - (letm ((intvec (vector-fixnum 4))) - (set-zero intvec) - (data intvec))) - (lisp-unit:assert-equalp ;set-all - #(44 44 44 44) - (letm ((intvec (vector-fixnum 4))) - (set-all intvec 44) - (data intvec))) - (lisp-unit:assert-equalp ;set-basis - #(0 1 0 0) - (letm ((intvec (vector-fixnum 4))) - (set-basis intvec 1) - (data intvec))) - (lisp-unit:assert-equalp ;vector-reverse - #(4 3 2 1) - (letm ((intvec (vector-fixnum #(1 2 3 4)))) - (vector-reverse intvec) - (data intvec))) - (lisp-unit:assert-eql ;gsl-min - -12 - (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) - (gsl-min intvec))) - (lisp-unit:assert-eql ;gsl-max - 8 - (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) - (gsl-max intvec))) - (lisp-unit:assert-equal ;gsl-minmax - '(-12 8) - (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) - (multiple-value-list (gsl-minmax intvec)))) - (lisp-unit:assert-eql ;gsl-min-index - 1 - (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) - (gsl-min-index intvec))) - (lisp-unit:assert-eql ;gsl-max-index - 2 - (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) - (gsl-max-index intvec))) - (lisp-unit:assert-equal ;gsl-minmax-index - '(1 2) - (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) - (multiple-value-list (gsl-minmax-index intvec)))) - (lisp-unit:assert-equalp ;copy - #(1 2 3 4) - (letm ((intvec1 (vector-fixnum #(1 2 3 4))) - (intvec2 (vector-fixnum 4))) - (copy intvec2 intvec1) - (data intvec2))) - (lisp-unit:assert-equalp ;swap - #(5 6 7 8 1 2 3 4) - (letm ((intvec1 (vector-fixnum #(1 2 3 4))) - (intvec2 (vector-fixnum #(5 6 7 8)))) - (swap intvec2 intvec1) - (concatenate 'vector (data intvec1) (data intvec2)))) - (lisp-unit:assert-equalp ;swap-elements - #(1 4 3 2) - (letm ((intvec (vector-fixnum #(1 2 3 4)))) - (swap-elements intvec 1 3) - (data intvec)))) - -(lisp-unit:define-test vector-double - (lisp-unit:assert-equal - '("-0.321000000000d+01" "0.100000000000d+01" "0.128000000000d+02") - (lisp-unit:fp-sequence - (letm ((vec (vector-double 3))) - (setf (gsl-aref vec 0) -3.21d0 - (gsl-aref vec 1) 1.0d0 - (gsl-aref vec 2) 12.8d0 - (cl-invalid vec) t) - (data vec))) - (lisp-unit:assert-equal - '("-0.321000000000d+01" "0.100000000000d+01" "0.128000000000d+02") - (lisp-unit:fp-sequence - (letm ((vec (vector-double 3))) - (setf (data vec) #(-3.21d0 1.0d0 12.8d0)) - (data vec)))) - (lisp-unit:assert-equal - '("-0.321000000000d+01" "0.100000000000d+01" "0.128000000000d+02") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) - (data vec)))) - (lisp-unit:assert-equal - '("0.000000000000d+01" "0.100000000000d+01" "0.000000000000d+01" - "0.000000000000d+01" "0.000000000000d+01") - (lisp-unit:fp-sequence - (letm ((base (vector-double 5))) - (set-basis base 1) - (data base)))) - (lisp-unit:assert-equal - '("-0.321000000000d+01" "0.100000000000d+01" "0.128000000000d+02") - (lisp-unit:fp-sequence - (letm ((vec1 (vector-double #(-3.21d0 1.0d0 12.8d0))) - (vec2 (vector-double 3))) - (copy vec2 vec1) - (data vec2)))))) +#| +(make-tests + vector-fixnum + (letm ((intvec (vector-fixnum 4))) ;(setf gsl-aref), gsl-aref + (setf (gsl-aref intvec 1) 77) + (gsl-aref intvec 1)) + (letm ((intvec (vector-fixnum 4))) ;(setf data) + (setf (data intvec) #(4 6 8 2)) + (data intvec)) + (letm ((intvec (vector-fixnum 4))) ;set-zero + (set-zero intvec) + (data intvec)) + (letm ((intvec (vector-fixnum 4))) ;set-all + (set-all intvec 44) + (data intvec)) + (letm ((intvec (vector-fixnum 4))) ;set-basis + (set-basis intvec 1) + (data intvec)) + (letm ((intvec (vector-fixnum #(1 2 3 4)))) ;vector-reverse + (vector-reverse intvec) + (data intvec)) + (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) ;gsl-min + (gsl-min intvec)) + (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) ;gsl-max + (gsl-max intvec)) + (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) ;gsl-minmax + (multiple-value-list (gsl-minmax intvec))) + (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) ;gsl-min-index + (gsl-min-index intvec)) + (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) ;gsl-max-index + (gsl-max-index intvec)) + (letm ((intvec (vector-fixnum #(-1 -12 8 3)))) ;gsl-minmax-index + (multiple-value-list (gsl-minmax-index intvec))) + (letm ((intvec1 (vector-fixnum #(1 2 3 4))) ;copy + (intvec2 (vector-fixnum 4))) + (copy intvec2 intvec1) + (data intvec2)) + (letm ((intvec1 (vector-fixnum #(1 2 3 4))) ;swap + (intvec2 (vector-fixnum #(5 6 7 8)))) + (swap intvec2 intvec1) + (concatenate 'vector (data intvec1) (data intvec2))) + (letm ((intvec (vector-fixnum #(1 2 3 4)))) ;swap-elements + (swap-elements intvec 1 3) + (data intvec))) +|# + +(LISP-UNIT:DEFINE-TEST VECTOR-FIXNUM + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 77) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM 4))) + (SETF (GSL-AREF INTVEC 1) 77) + (GSL-AREF INTVEC 1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(4 6 8 2)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM 4))) + (SETF (DATA INTVEC) #(4 6 8 2)) + (DATA INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(0 0 0 0)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM 4))) + (SET-ZERO INTVEC) + (DATA INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(44 44 44 44)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM 4))) + (SET-ALL INTVEC 44) + (DATA INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(0 1 0 0)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM 4))) + (SET-BASIS INTVEC 1) + (DATA INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(4 3 2 1)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(1 2 3 4)))) + (VECTOR-REVERSE INTVEC) + (DATA INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST -12) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(-1 -12 8 3)))) + (GSL-MIN INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 8) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(-1 -12 8 3)))) + (GSL-MAX INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST -12 8)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(-1 -12 8 3)))) + (MULTIPLE-VALUE-LIST + (GSL-MINMAX INTVEC))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(-1 -12 8 3)))) + (GSL-MIN-INDEX INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2) + (MULTIPLE-VALUE-LIST + (LETM + ((INTVEC (VECTOR-FIXNUM #(-1 -12 8 3)))) + (GSL-MAX-INDEX INTVEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 1 2)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(-1 -12 8 3)))) + (MULTIPLE-VALUE-LIST + (GSL-MINMAX-INDEX INTVEC))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(1 2 3 4)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC1 (VECTOR-FIXNUM #(1 2 3 4))) + (INTVEC2 (VECTOR-FIXNUM 4))) + (COPY INTVEC2 INTVEC1) + (DATA INTVEC2)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(5 6 7 8 1 2 3 4)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC1 (VECTOR-FIXNUM #(1 2 3 4))) + (INTVEC2 (VECTOR-FIXNUM #(5 6 7 8)))) + (SWAP INTVEC2 INTVEC1) + (CONCATENATE 'VECTOR (DATA INTVEC1) (DATA INTVEC2))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(1 4 3 2)) + (MULTIPLE-VALUE-LIST + (LETM ((INTVEC (VECTOR-FIXNUM #(1 2 3 4)))) + (SWAP-ELEMENTS INTVEC 1 3) + (DATA INTVEC))))) + +#| +(make-tests + vector-double + (letm ((vec (vector-double 3))) + (setf (gsl-aref vec 0) -3.21d0 + (gsl-aref vec 1) 1.0d0 + (gsl-aref vec 2) 12.8d0 + (cl-invalid vec) t) + (data vec)) + (letm ((vec (vector-double 3))) + (setf (data vec) #(-3.21d0 1.0d0 12.8d0)) + (data vec)) + (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) + (data vec)) + (letm ((base (vector-double 5))) + (set-basis base 1) + (data base)) + (letm ((vec1 (vector-double #(-3.21d0 1.0d0 12.8d0))) + (vec2 (vector-double 3))) + (copy vec2 vec1) + (data vec2))) +|# + +(LISP-UNIT:DEFINE-TEST VECTOR-DOUBLE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(-3.21d0 1.0d0 12.8d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE 3))) + (SETF (GSL-AREF VEC 0) -3.21d0 + (GSL-AREF VEC 1) 1.0d0 + (GSL-AREF VEC 2) 12.8d0 + (CL-INVALID VEC) T) + (DATA VEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(-3.21d0 1.0d0 12.8d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE 3))) + (SETF (DATA VEC) #(-3.21d0 1.0d0 12.8d0)) + (DATA VEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(-3.21d0 1.0d0 12.8d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0)))) + (DATA VEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(0.0d0 1.0d0 0.0d0 0.0d0 0.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((BASE (VECTOR-DOUBLE 5))) (SET-BASIS BASE 1) + (DATA BASE)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(-3.21d0 1.0d0 12.8d0)) + (MULTIPLE-VALUE-LIST + (LETM + ((VEC1 (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0))) + (VEC2 (VECTOR-DOUBLE 3))) + (COPY VEC2 VEC1) (DATA VEC2))))) diff --git a/eigensystems.lisp b/eigensystems.lisp index b65479a5b9a52602d986867ae1a48c9fa1a775bf..e51bdf605c6261b6f6e837d3c00201c37d1739b6 100644 --- a/eigensystems.lisp +++ b/eigensystems.lisp @@ -1,6 +1,6 @@ ;; Eigenvectors and eigenvalues ;; Liam Healy, Sun May 21 2006 - 19:52 -;; Time-stamp: <2008-02-03 14:14:10EST eigensystems.lisp> +;; Time-stamp: <2008-02-17 11:32:46EST eigensystems.lisp> ;; $Id: $ (in-package :gsl) @@ -11,8 +11,8 @@ (defgo-s (eigen-symm n) eigen-symm-alloc eigen-symm-free) -(defun-gsl eigen-symm-alloc (n) - "gsl_eigen_symm_alloc" ((n :size)) +(defmfun eigen-symm-alloc (n) + "gsl_eigen_symm_alloc" ((n size)) :c-return :pointer :export nil :index '(letm eigen-symm) @@ -21,7 +21,7 @@ n-by-n real symmetric matrices. The size of the workspace is O(2n).") -(defun-gsl eigen-symm-free (w) +(defmfun eigen-symm-free (w) "gsl_eigen_symm_free" ((w :pointer)) :c-return :void :export nil @@ -31,8 +31,8 @@ (defgo-s (eigen-symmv n) eigen-symmv-alloc eigen-symmv-free) -(defun-gsl eigen-symmv-alloc (n) - "gsl_eigen_symmv_alloc" ((n :size)) +(defmfun eigen-symmv-alloc (n) + "gsl_eigen_symmv_alloc" ((n size)) :c-return :pointer :export nil :index '(letm eigen-symmv) @@ -41,26 +41,26 @@ eigenvectors of n-by-n real symmetric matrices. The size of the workspace is O(4n).") -(defun-gsl eigen-symmv-free (w) +(defmfun eigen-symmv-free (w) "gsl_eigen_symmv_free" ((w :pointer)) :index '(letm eigen-symmv) :c-return :void :documentation ; FDL "Free the memory associated with the workspace w.") -(defun-gsl eigenvalues-symmetric (A eval ws) +(defmfun eigenvalues-symmetric (A eval ws) "gsl_eigen_symm" ((A gsl-matrix-c) (eval gsl-vector-c) (ws :pointer)) :documentation ; FDL "Eigenvalues of the real symmetric matrix A. Additional workspace of the appropriate size must be provided in w. The diagonal and lower triangular part of A are destroyed during the computation, but the strict upper triangular part - is not referenced. The eigenvalues are stored in the vector @var{eval} + is not referenced. The eigenvalues are stored in the vector eval and are unordered." :invalidate (A eval) :return (eval)) -(defun-gsl eigenvalues-eigenvectors-symmetric (A eval evec ws) +(defmfun eigenvalues-eigenvectors-symmetric (A eval evec ws) "gsl_eigen_symmv" (((pointer A) :pointer) ((pointer eval) :pointer) ((pointer evec) :pointer) (ws :pointer)) @@ -84,21 +84,21 @@ (defgo-s (eigen-herm n) eigen-herm-alloc eigen-herm-free) -(defun-gsl eigen-herm-alloc (n) - "gsl_eigen_herm_alloc" ((n :size)) +(defmfun eigen-herm-alloc (n) + "gsl_eigen_herm_alloc" ((n size)) :documentation ; FDL "Allocate a workspace for computing eigenvalues of n-by-n complex hermitian matrices. The size of the workspace is O(3n)." :c-return :pointer) -(defun-gsl eigen-herm-free (w) +(defmfun eigen-herm-free (w) "gsl_eigen_herm_free" ((w :pointer)) :c-return :void :documentation ; FDL "Free the memory associated with the workspace w.") -(defun-gsl eigenvalues-hermitian (A eval w) +(defmfun eigenvalues-hermitian (A eval w) "gsl_eigen_herm" (((pointer A) gsl-matrix-c) ((pointer eval) gsl-vector-c) (w :pointer)) :documentation ; FDL @@ -108,27 +108,27 @@ destroyed during the computation, but the strict upper triangular part is not referenced. The imaginary parts of the diagonal are assumed to be zero and are not referenced. The eigenvalues are stored in the vector - @var{eval} and are unordered." + eval and are unordered." :invalidate (eval A) :return (eval)) (defgo-s (eigen-hermv n) eigen-hermv-alloc eigen-hermv-free) -(defun-gsl eigen-hermv-alloc (n) - "gsl_eigen_hermv_alloc" ((n :size)) +(defmfun eigen-hermv-alloc (n) + "gsl_eigen_hermv_alloc" ((n size)) :documentation ; FDL "Allocate a workspace for computing eigenvalues and eigenvectors of n-by-n complex hermitian matrices. The size of the workspace is O(5n)." :c-return :pointer) -(defun-gsl eigen-hermv-free (w) +(defmfun eigen-hermv-free (w) "gsl_eigen_hermv_free" ((w :pointer)) :c-return :void :documentation ; FDL "Free the memory associated with the workspace w.") -(defun-gsl eigenvalues-eigenvectors-hermitian (A eval evec w) +(defmfun eigenvalues-eigenvectors-hermitian (A eval evec w) "gsl_eigen_hermv" (((pointer A) gsl-matrix-c) ((pointer eval) gsl-vector-c) ((pointer evec) gsl-matrix-c) (w :pointer)) @@ -164,14 +164,14 @@ the value of the parameter sort-type: :value-ascending, :value-descending, :absolute-ascending, :absolute-descending.")) -(defun-gsl sort-eigenvalues-eigenvectors +(defmfun sort-eigenvalues-eigenvectors ((eval gsl-vector-double) evec sort-type) "gsl_eigen_symmv_sort" ((eval gsl-vector-c) (evec gsl-matrix-c) (sort-type eigen-sort-type)) :type :method :invalidate (eval evec)) -(defun-gsl sort-eigenvalues-eigenvectors +(defmfun sort-eigenvalues-eigenvectors ((eval gsl-vector-complex) evec sort-type) "gsl_eigen_hermv_sort" ((eval gsl-vector-c) (evec gsl-matrix-c) (sort-type eigen-sort-type)) @@ -194,9 +194,16 @@ (values (data evals) (data evecs)))) #| -#(13.819660112501051d0 36.180339887498945d0 40.0d0) -#2A((0.8506508083520399d0 -0.5257311121191336d0 0.0d0) - (0.5257311121191336d0 0.8506508083520399d0 0.0d0) - (0.0d0 0.0d0 1.0d0)) - +(make-tests eigensystems + (eigenvalue-eigenvectors-example)) |# + +(LISP-UNIT:DEFINE-TEST EIGENSYSTEMS + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + #(13.819660112501051d0 36.180339887498945d0 40.0d0) + #2A((0.8506508083520399d0 -0.5257311121191337d0 0.0d0) + (0.5257311121191337d0 0.8506508083520399d0 0.0d0) + (0.0d0 0.0d0 1.0d0))) + (MULTIPLE-VALUE-LIST + (EIGENVALUE-EIGENVECTORS-EXAMPLE)))) diff --git a/gsll.asd b/gsll.asd index 34cdf7ba4ff08fdae6aea7b7abd797b6ab88ce39..29bb0b71700a14ea0b421572ea0c5627e57ecb5c 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2008-02-16 10:59:40EST gsll.asd> +;; Time-stamp: <2008-02-17 18:41:29EST gsll.asd> ;; $Id: $ (asdf:defsystem "gsll" @@ -18,7 +18,7 @@ (:file "utility" :depends-on (init)) (:file "gsl-objects" :depends-on (init)) (:file "number-conversion" :depends-on (init)) - (:file "interface" :depends-on (conditions init number-conversion)) + (:file "interface" :depends-on (init conditions number-conversion)) (:file "callback" :depends-on (init)) ;; http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html (:file "lisp-unit") diff --git a/hankel.lisp b/hankel.lisp index 06edaddac3b897de87fb98089a3dc1e5f827dca9..2e26521cda4ad4231bceee086070b238208d37b2 100644 --- a/hankel.lisp +++ b/hankel.lisp @@ -1,6 +1,6 @@ ;; Discrete Hankel Transforms. ;; Liam Healy, Sat Dec 8 2007 - 16:50 -;; Time-stamp: <2008-02-03 13:22:56EST hankel.lisp> +;; Time-stamp: <2008-02-17 18:10:15EST hankel.lisp> ;; $Id: $ (in-package :gsl) @@ -9,65 +9,63 @@ (defgo-s (hankel size nu xmax) allocate-hankel free-hankel init-hankel) -(defun-gsl allocate-hankel (size) +(defmfun allocate-hankel (size) "gsl_dht_alloc" - ((size :size)) + ((size size)) :c-return :pointer :export nil :index (letm hankel) - :documentation - "Allocate a Discrete Hankel transform object of size @var{size}.") + :documentation ; FDL + "Allocate a Discrete Hankel transform object of given size.") -(defun-gsl init-hankel (hankel nu xmax) +(defmfun init-hankel (hankel nu xmax) "gsl_dht_new" ((hankel :pointer) (nu :double) (xmax :double)) :export nil :index (letm hankel) - :documentation - "Initialize the transform @var{t} for the given values of - @var{nu} and @var{x}.") + :documentation ; FDL + "Initialize the transform for the given values of nu and x.") ;; This seems redundant; does it effectively combine allocate-hankel ;; and init-hankel? In this case we don't really need, and shouldn't ;; export it. -(defun-gsl new-hankel (size nu xmax) +(defmfun new-hankel (size nu xmax) "gsl_dht_new" - ((size :size) (nu :double) (xmax :double)) + ((size size) (nu :double) (xmax :double)) :c-return :pointer - :documentation + :documentation ; FDL "Allocate a Discrete Hankel transform object of size - @var{size} and initializes it for the given values of @var{nu} and - @var{x}.") + size and initializes it for the given values of nu and + xmax.") -(defun-gsl free-hankel (hankel) +(defmfun free-hankel (hankel) "gsl_dht_free" ((hankel :pointer)) :c-return :void :export nil :index (letm hankel) - :documentation + :documentation ; FDL "Free the Hankel object.") -(defun-gsl apply-hankel (hankel array-in array-out) +(defmfun apply-hankel (hankel array-in array-out) "gsl_dht_apply" ((hankel :pointer) ((gsl-array array-in) :pointer) ((gsl-array array-out) :pointer)) - :documentation - "Apply the transform @var{t} to the array @var{f_in} + :documentation ; FDL + "Apply the transform to the array array-in whose size is equal to the size of the transform. The result is stored - in the array @var{f_out} which must be of the same length.") + in the array array-out which must be of the same length.") -(defun-gsl sample-x-hankel (hankel n) +(defmfun sample-x-hankel (hankel n) "gsl_dht_x_sample" ((hankel :pointer) (n :int)) :c-return :double - :documentation - "The points where the function @math{f(t)} is assumed to be sampled.") + :documentation ; FDL + "The points where the function f(t) is assumed to be sampled.") -(defun-gsl sample-k-hankel (hankel n) +(defmfun sample-k-hankel (hankel n) "gsl_dht_k_sample" ((hankel :pointer) (n :int)) :c-return :double - :documentation - "The value of the @var{n}-th sample point in k-space, - j_{\nu,n+1}/X}.") + :documentation ; FDL + "The value of the n-th sample point in k-space, j_{\nu,n+1}/X}.") diff --git a/histogram/histogram.lisp b/histogram/histogram.lisp index 9c9381ce482ae1cb66953a5d134b5342cecec92a..93848d51abae5ead2664dafd7f81ef84e8e2d45e 100644 --- a/histogram/histogram.lisp +++ b/histogram/histogram.lisp @@ -1,6 +1,6 @@ ;; The histogram structure ;; Liam Healy, Mon Jan 1 2007 - 11:32 -;; Time-stamp: <2008-02-03 21:53:32EST histogram.lisp> +;; Time-stamp: <2008-02-17 16:51:35EST histogram.lisp> ;; $Id: $ (in-package :gsl) @@ -26,18 +26,18 @@ (:documentation "A histogram, including bin boundaries and bin contents.")) -(defun-gsl alloc-histo-1 (object) +(defmfun alloc-histo-1 (object) "gsl_histogram_alloc" - (((number-of-bins object) :size)) + (((number-of-bins object) size)) :export nil :index (letm histogram) :c-return (cr :pointer) :return ((assign-pointer object cr))) -(defun-gsl alloc-histo-2 (object) +(defmfun alloc-histo-2 (object) "gsl_histogram2d_alloc" - (((first (number-of-bins object)) :size) - ((second (number-of-bins object)) :size)) + (((first (number-of-bins object)) size) + ((second (number-of-bins object)) size)) :export nil :index (letm histogram) :c-return (cr :pointer) @@ -56,7 +56,7 @@ (defmethod alloc ((object histogram)) (histo-1d2d object alloc-histo)) -(defun-gsl free-histo-1 (object) +(defmfun free-histo-1 (object) "gsl_histogram_free" (((pointer object) :pointer)) :c-return (cr :pointer) @@ -64,7 +64,7 @@ :export nil :index (letm histogram)) -(defun-gsl free-histo-2 (object) +(defmfun free-histo-2 (object) "gsl_histogram2d_free" (((pointer object) :pointer)) :c-return (cr :pointer) @@ -77,10 +77,10 @@ ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl set-ranges-1 (histogram ranges) +(defmfun set-ranges-1 (histogram ranges) "gsl_histogram_set_ranges" (((pointer histogram) :pointer) - ((gsl-array ranges) :pointer) ((dim0 ranges) :size)) + ((gsl-array ranges) :pointer) ((dim0 ranges) size)) :export nil :index (letm histogram) :documentation ; FDL @@ -90,11 +90,11 @@ desired bin limits. The ranges can be arbitrary, subject to the restriction that they are monotonically increasing.") -(defun-gsl set-ranges-2 (histogram x-ranges y-ranges) +(defmfun set-ranges-2 (histogram x-ranges y-ranges) "gsl_histogram2d_set_ranges" (((pointer histogram) :pointer) - ((gsl-array x-ranges) :pointer) ((dim0 x-ranges) :size) - ((gsl-array y-ranges) :pointer) ((dim0 y-ranges) :size)) + ((gsl-array x-ranges) :pointer) ((dim0 x-ranges) size) + ((gsl-array y-ranges) :pointer) ((dim0 y-ranges) size)) :export nil :index (letm histogram)) @@ -112,7 +112,7 @@ ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl set-ranges-uniform-1 (histogram minimum maximum) +(defmfun set-ranges-uniform-1 (histogram minimum maximum) "gsl_histogram_set_ranges_uniform" (((pointer histogram) :pointer) (minimum :double) (maximum :double)) :export nil @@ -130,7 +130,7 @@ ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl set-ranges-uniform-2 +(defmfun set-ranges-uniform-2 (histogram x-minimum x-maximum y-minimum y-maximum) "gsl_histogram2d_set_ranges_uniform" (((pointer histogram) :pointer) @@ -156,7 +156,7 @@ ((first limits) (second limits) (third limits) (fourth limits)))) -(defun-gsl copy-1 (destination source) +(defmfun copy-1 (destination source) "gsl_histogram_memcpy" (((pointer destination) :pointer) ((pointer source) :pointer)) :export nil @@ -167,7 +167,7 @@ an exact copy of the former. The two histograms must be of the same size.") -(defun-gsl copy-2 (destination source) +(defmfun copy-2 (destination source) "gsl_histogram2d_memcpy" (((pointer destination) :pointer) ((pointer source) :pointer)) :export nil @@ -176,7 +176,7 @@ (defmethod copy ((destination histogram) (source histogram)) (histo-1d2d destination copy (source))) -(defun-gsl clone-1 (source) +(defmfun clone-1 (source) "gsl_histogram_memcpy" (((pointer source) :pointer)) :export nil @@ -185,7 +185,7 @@ "Create a new histogram which is an exact copy of the histogram source, and return the pointer.") -(defun-gsl clone-2 (source) +(defmfun clone-2 (source) "gsl_histogram2d_memcpy" (((pointer source) :pointer)) :export nil diff --git a/histogram/ntuple.lisp b/histogram/ntuple.lisp index 7723ce1d56e293d76b9d9ab3e2e688bff8bda8d8..e10e4e7bf396e075e14dcf163e42666e857039f8 100644 --- a/histogram/ntuple.lisp +++ b/histogram/ntuple.lisp @@ -1,6 +1,6 @@ ;; N-tuples ;; Liam Healy Sat Feb 3 2007 - 12:53 -;; Time-stamp: <2008-01-20 22:37:47EST ntuple.lisp> +;; Time-stamp: <2008-02-17 18:39:48EST ntuple.lisp> ;; $Id: $ (in-package :gsl) @@ -9,65 +9,65 @@ ;;; has not been created, and it has not been tested. ;;; Writing a file -(defun-gsl create-ntuple (filename data size) +(defmfun create-ntuple (filename data size) "gsl_ntuple_create" - ((filename :string) (data :pointer) (size :size)) + ((filename :string) (data :pointer) (size size)) :c-return :pointer - :documentation - "Create a new write-only ntuple file @var{filename} for - ntuples of size @var{size} and return a pointer to the newly created + :documentation ; FDL + "Create a new write-only ntuple file filename for + ntuples of size and return a pointer to the newly created ntuple struct. Any existing file with the same name is truncated to zero length and overwritten. A pointer to memory for the current ntuple - row @var{data} must be supplied---this is used to copy ntuples + row data must be supplied---this is used to copy ntuples in and out of the file.") ;;; Reading a file -(defun-gsl open-ntuple (filename data size) +(defmfun open-ntuple (filename data size) "gsl_ntuple_create" - ((filename :string) (data :pointer) (size :size)) + ((filename :string) (data :pointer) (size size)) :c-return :pointer - :documentation - "Open an existing ntuple file @var{filename} for reading + :documentation ; FDL + "Open an existing ntuple file filename for reading and return a pointer to a corresponding ntuple struct. The ntuples in - the file must have size @var{size}. A pointer to memory for the current - ntuple row @var{data} must be supplied---this is used to copy + the file must have size size. A pointer to memory for the current + ntuple row data must be supplied---this is used to copy ntuples in and out of the file.") ;;; Writing ntuples -(defun-gsl write-ntuple (ntuple) +(defmfun write-ntuple (ntuple) "gsl_ntuple_write" ((ntuple :pointer)) - :documentation - "Write the current ntuple @var{ntuple->ntuple_data} of - size @var{ntuple->size} to the corresponding file.") + :documentation ; FDL + "Write the current ntuple ntuple->ntuple_data of + size ntuple->size to the corresponding file.") -(defun-gsl bookdata-ntuple (ntuple) +(defmfun bookdata-ntuple (ntuple) "gsl_ntuple_bookdata" ((ntuple :pointer)) - :documentation + :documentation ; FDL "A synonym for #'write-ntuple}.") ;;; Reading ntuples -(defun-gsl read-ntuple (ntuple) +(defmfun read-ntuple (ntuple) "gsl_ntuple_read" ((ntuple :pointer)) - :documentation + :documentation ; FDL "Read the current row of the ntuple file and stores the value.") ;;; Closing file -(defun-gsl close-ntuple (ntuple) +(defmfun close-ntuple (ntuple) "gsl_ntuple_close" ((ntuple :pointer)) - :documentation - "Closes the ntuple file @var{ntuple} and frees its + :documentation ; FDL + "Closes the ntuple file ntupe and frees its associated allocated memory.") ;;; Histogramming ntuple values -(defun-gsl project-ntuple (histogram ntuple value-function select-function) +(defmfun project-ntuple (histogram ntuple value-function select-function) "gsl_ntuple_project" ((histogram :pointer) (ntuple :pointer) (value-function :pointer) (select-function :pointer)) - :documentation + :documentation ; FDL "Update the histogram the ntuple using the functions value-function and select-function. For each ntuple row where the selection function select-function is non-zero the @@ -82,6 +82,7 @@ (export '(def-ntuple-select-function def-ntuple-value-function)) (defmacro def-ntuple-select-function (name arg) + ;; FDL "The selection function determines which ntuple rows are selected for histogramming. The struct component function should return a non-zero value for each ntuple row that is to be included in the @@ -89,6 +90,7 @@ `(def-single-function ,name ,arg :int :pointer)) (defmacro def-ntuple-value-function (name arg) + ;; FDL "The value function computes scalar values for those ntuple rows selected by the selection function which should return the value to be added to the histogram." diff --git a/histogram/operations.lisp b/histogram/operations.lisp index a0a105710f3f9d524a22044fa7a52f29e8f1af8f..088ec8cf9a65f9d4805ab327444be03227f49c6b 100644 --- a/histogram/operations.lisp +++ b/histogram/operations.lisp @@ -1,217 +1,215 @@ -;******************************************************** -; file: operations.lisp -; description: Histogram operations -; date: Mon Jan 1 2007 - 16:47 -; author: Liam M. Healy -; modified: Mon Jan 1 2007 - 21:50 -;******************************************************** -;;; $Id: $ +;; Histogram operations +;; Liam Healy, Mon Jan 1 2007 - 16:47 +;; Time-stamp: <2008-02-17 17:10:53EST operations.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl equal-bins-p-1 (histogram1 histogram2) +(defmfun equal-bins-p-1 (histogram1 histogram2) "gsl_histogram_equal_bins_p" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :c-return :true-false :export nil :index equal-bins-p - :documentation - "Are all of the individual bin - ranges of the two histograms are identical?") + :documentation ; FDL + "Are all of the individual bin ranges of the two histograms are identical?") -(defun-gsl equal-bins-p-2 (histogram1 histogram2) +(defmfun equal-bins-p-2 (histogram1 histogram2) "gsl_histogram2d_equal_bins_p" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :c-return :true-false :export nil :index equal-bins-p - :documentation - "Are all of the individual bin - ranges of the two histograms are identical?") + :documentation ; FDL + "Are all of the individual bin ranges of the two histograms are identical?") (export 'equal-bins-p) (defun equal-bins-p (histogram1 histogram2) - "Are all of the individual bin - ranges of the two histograms are identical?" + "Are all of the individual bin ranges of the two histograms are identical?" (histo-1d2d histogram1 equal-bins-p (histogram2))) ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl+-1 (histogram1 histogram2) +(defmfun gsl+-1 (histogram1 histogram2) "gsl_histogram_add" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl+ - :documentation + :documentation ; FDL "Add the contents of the bins in histogram2 to the - corresponding bins of histogram1 i.e. @math{h'_1(i) = - h_1(i) + h_2(i)}. The two histograms must have identical bin + corresponding bins of histogram1 i.e. h'_1(i) = + h_1(i) + h_2(i). The two histograms must have identical bin ranges.") ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl+-2 (histogram1 histogram2) +(defmfun gsl+-2 (histogram1 histogram2) "gsl_histogram2d_add" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl+ - :documentation + :documentation ; FDL "Add the contents of the bins in histogram2 to the - corresponding bins of histogram1 i.e. @math{h'_1(i) = - h_1(i) + h_2(i)}. The two histograms must have identical bin + corresponding bins of histogram1 i.e. h'_1(i) = + h_1(i) + h_2(i). The two histograms must have identical bin ranges.") (defmethod gsl+ ((histogram1 histogram) (histogram2 histogram)) + ;; FDL "Add the contents of the bins in histogram2 to the - corresponding bins of histogram1 i.e. @math{h'_1(i) = - h_1(i) + h_2(i)}. The two histograms must have identical bin + corresponding bins of histogram1 i.e. h'_1(i) = + h_1(i) + h_2(i). The two histograms must have identical bin ranges." (histo-1d2d histogram1 gsl+ (histogram2))) ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl--1 (histogram1 histogram2) +(defmfun gsl--1 (histogram1 histogram2) "gsl_histogram_sub" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl- - :documentation + :documentation ; FDL "Subtract the contents of the bins in histogram2 from the - corresponding bins of histogram1 i.e. @math{h'_1(i) = h_1(i) - - h_2(i)}. The two histograms must have identical bin ranges.") + corresponding bins of histogram1 i.e. h'_1(i) = h_1(i) - + h_2(i). The two histograms must have identical bin ranges.") ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl--2 (histogram1 histogram2) +(defmfun gsl--2 (histogram1 histogram2) "gsl_histogram2d_sub" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl- - :documentation + :documentation ; FDL "Subtract the contents of the bins in histogram2 from the - corresponding bins of histogram1 i.e. @math{h'_1(i) = h_1(i) - - h_2(i)}. The two histograms must have identical bin ranges.") + corresponding bins of histogram1 i.e. h'_1(i) = h_1(i) - + h_2(i). The two histograms must have identical bin ranges.") (defmethod gsl- ((histogram1 histogram) (histogram2 histogram)) + ;; FDL "Subtract the contents of the bins in histogram2 from the - corresponding bins of histogram1 i.e. @math{h'_1(i) = h_1(i) - - h_2(i)}. The two histograms must have identical bin ranges." + corresponding bins of histogram1 i.e. h'_1(i) = h_1(i) - + h_2(i). The two histograms must have identical bin ranges." (histo-1d2d histogram1 gsl- (histogram2))) ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl*-1 (histogram1 histogram2) +(defmfun gsl*-1 (histogram1 histogram2) "gsl_histogram_mul" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl* - :documentation + :documentation ; FDL "Multiply the contents of the bins of histogram1 by the contents of the corresponding bins in histogram2 - i.e. @math{h'_1(i) = h_1(i) * h_2(i)}. The two histograms + i.e. h'_1(i) = h_1(i) * h_2(i). The two histograms must have identical bin ranges.") ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl*-2 (histogram1 histogram2) +(defmfun gsl*-2 (histogram1 histogram2) "gsl_histogram2d_mul" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl* - :documentation + :documentation ; FDL "Multiply the contents of the bins of histogram1 by the contents of the corresponding bins in histogram2 - i.e. @math{h'_1(i) = h_1(i) * h_2(i)}. The two histograms + i.e. h'_1(i) = h_1(i) * h_2(i). The two histograms must have identical bin ranges.") (defmethod gsl* ((histogram1 histogram) (histogram2 histogram)) + ;; FDL "Multiply the contents of the bins of histogram1 by the contents of the corresponding bins in histogram2 - i.e. @math{h'_1(i) = h_1(i) * h_2(i)}. The two histograms + i.e. h'_1(i) = h_1(i) * h_2(i). The two histograms must have identical bin ranges." (histo-1d2d histogram1 gsl* (histogram2))) ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl/-1 (histogram1 histogram2) +(defmfun gsl/-1 (histogram1 histogram2) "gsl_histogram_div" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl/ - :documentation + :documentation ; FDL "Divide the contents of the bins of histogram1 by the contents of the corresponding bins in histogram2 - i.e. @math{h'_1(i) = h_1(i) / h_2(i)}. The two histograms + i.e. h'_1(i) = h_1(i) / h_2(i). The two histograms must have identical bin ranges.") ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl gsl/-2 (histogram1 histogram2) +(defmfun gsl/-2 (histogram1 histogram2) "gsl_histogram2d_div" (((pointer histogram1) :pointer) ((pointer histogram2) :pointer)) :export nil :index gsl/ - :documentation + :documentation ; FDL "Divide the contents of the bins of histogram1 by the contents of the corresponding bins in histogram2 - i.e. @math{h'_1(i) = h_1(i) / h_2(i)}. The two histograms + i.e. h'_1(i) = h_1(i) / h_2(i). The two histograms must have identical bin ranges.") (defmethod gsl/ ((histogram1 histogram) (histogram2 histogram)) + ;; FDL "Divide the contents of the bins of histogram1 by the contents of the corresponding bins in histogram2 - i.e. @math{h'_1(i) = h_1(i) / h_2(i)}. The two histograms + i.e. h'_1(i) = h_1(i) / h_2(i). The two histograms must have identical bin ranges." (histo-1d2d histogram1 gsl/ (histogram2))) ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl scale-1 (histogram scale) +(defmfun scale-1 (histogram scale) "gsl_histogram_scale" (((pointer histogram) :pointer) (scale :double)) :export nil :index scale - :documentation + :documentation ; FDL "Multiply the contents of the bins of histogram by the constant scale, i.e. h'_1(i) = h_1(i) * scale.") ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl scale-2 (histogram scale) +(defmfun scale-2 (histogram scale) "gsl_histogram2d_scale" (((pointer histogram) :pointer) (scale :double)) :export nil :index scale - :documentation + :documentation ; FDL "Multiply the contents of the bins of histogram by the constant scale, i.e. h'_1(i) = h_1(i) * scale.") (export 'scale) (defun scale (histogram scale) + ;; FDL "Multiply the contents of the bins of histogram by the constant scale, i.e. h'_1(i) = h_1(i) * scale." (histo-1d2d histogram scale (scale))) ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl shift-1 (histogram offset) +(defmfun shift-1 (histogram offset) "gsl_histogram_shift" (((pointer histogram) :pointer) (offset :double)) :export nil :index shift - :documentation - "Shift the contents of the bins of histogram @var{h} by the + :documentation ; FDL + "Shift the contents of the bins of histogram h by the constant offset, i.e. h'_1(i) = h_1(i) + offset.") ;;; GSL documentation does not state what the return value for the ;;; C function means; assumed to be error code. -(defun-gsl shift-2 (histogram offset) +(defmfun shift-2 (histogram offset) "gsl_histogram2d_shift" (((pointer histogram) :pointer) (offset :double)) :export nil :index shift - :documentation - "Shift the contents of the bins of histogram @var{h} by the + :documentation ; FDL + "Shift the contents of the bins of histogram h by the constant offset, i.e. h'_1(i) = h_1(i) + offset.") (export 'shift) diff --git a/histogram/probability-distribution.lisp b/histogram/probability-distribution.lisp index 81091b304726e44491866859ae2a92c52f1bf238..234af4ccf3d9444921c75101ccb0497562a7718a 100644 --- a/histogram/probability-distribution.lisp +++ b/histogram/probability-distribution.lisp @@ -1,6 +1,6 @@ ;; Histogram probability distribution. ;; Liam Healy, Mon Jan 1 2007 - 17:51 -;; Time-stamp: <2008-01-21 18:02:00EST probability-distribution.lisp> +;; Time-stamp: <2008-02-17 18:39:49EST probability-distribution.lisp> ;; $Id: $ (in-package :gsl) @@ -14,17 +14,17 @@ (:documentation "A histogram, including bin boundaries and bin contents.")) -(defun-gsl alloc-1 (object) +(defmfun alloc-1 (object) "gsl_histogram_pdf_alloc" - (((number-of-bins object) :size)) + (((number-of-bins object) size)) :export nil :index alloc :c-return (cr :pointer) :return ((assign-pointer object cr))) -(defun-gsl alloc-2 (object) +(defmfun alloc-2 (object) "gsl_histogram2d_pdf_alloc" - (((number-of-bins object) :size)) + (((number-of-bins object) size)) :export nil :index alloc :c-return (cr :pointer) @@ -33,14 +33,14 @@ (defmethod alloc ((object histogram-pdf)) (histo-1d2d object alloc)) -(defun-gsl free-1 (object) +(defmfun free-1 (object) "gsl_histogram_pdf_free" (((pointer object) :pointer)) :export nil :index free :c-return :void) -(defun-gsl free-2 (object) +(defmfun free-2 (object) "gsl_histogram2d_pdf_free" (((pointer object) :pointer)) :export nil @@ -50,65 +50,64 @@ (defmethod free ((object histogram-pdf)) (histo-1d2d object free)) -(defun-gsl pdf-init-1 (pdf histogram) +(defmfun pdf-init-1 (pdf histogram) "gsl_histogram_pdf_init" (((pointer pdf) :pointer) ((pointer histogram) :pointer)) :return () :export nil :index pdf-init - :documentation + :documentation ; FDL "Initialize the probability distribution pdf with the contents of the histogram. If any of the bins are negative then an EDOM error is signalled because a probability distribution cannot contain negative values.") -(defun-gsl pdf-init-2 (pdf histogram) +(defmfun pdf-init-2 (pdf histogram) "gsl_histogram2d_pdf_init" (((pointer pdf) :pointer) ((pointer histogram) :pointer)) :return () :export nil :index pdf-init - :documentation + :documentation ; FDL "Initialize the probability distribution pdf with the contents of the histogram. If any of the bins are negative then an EDOM error is signalled because a probability distribution cannot contain negative values.") (export 'pdf-init) -(defun pdf-init (pdf histogram) +(defun pdf-init (pdf histogram) ; FDL "Initialize the probability distribution pdf with the contents of the histogram. If any of the bins are negative then an EDOM error is signalled because a probability distribution cannot contain negative values." (histo-1d2d pdf pdf-init (histogram))) -(defun-gsl sample-1 (pdf value) +(defmfun sample-1 (pdf value) "gsl_histogram_pdf_sample" (((pointer pdf) :pointer) (value :double)) :c-return :double :export nil :index sample - :documentation + :documentation ; FDL "Given a uniform random number between zero and one, compute a single random sample from the probability distribution - 'pdf. The algorithm used to compute the sample @math{s} is given by + 'pdf. The algorithm used to compute the sample s is given by s = range[i] + delta * (range[i+1] - range[i]) - where @math{i} is the index which satisfies - @math{sum[i] <= r < sum[i+1]} and @math{delta} is - @math{(r - sum[i])/(sum[i+1] - sum[i])}.") + where i is the index which satisfies + sum[i] <= r < sum[i+1] and delta is + (r - sum[i])/(sum[i+1] - sum[i]).") -(defun-gsl sample-2 (pdf value) +(defmfun sample-2 (pdf value) "gsl_histogram2d_pdf_sample" (((pointer pdf) :pointer) (value :double)) :c-return :double :export nil :index sample - :documentation + :documentation ; FDL "Given a uniform random number between zero and one, compute a single random sample from the probability distribution - 'pdf. The algorithm used to compute the sample @math{s} is given by + 'pdf. The algorithm used to compute the sample s is given by s = range[i] + delta * (range[i+1] - range[i]) - where @math{i} is the index which satisfies - @math{sum[i] <= r < sum[i+1]} and @math{delta} is - @math{(r - sum[i])/(sum[i+1] - sum[i])}.") - + where i is the index which satisfies + sum[i] <= r < sum[i+1] and delta is + (r - sum[i])/(sum[i+1] - sum[i]).") diff --git a/histogram/read-write.lisp b/histogram/read-write.lisp index 1daaa57af4b9358e6938c59f3d52d0c1c0ec1831..c92cd364ed8aab14420a7a185617eec7120b10ba 100644 --- a/histogram/read-write.lisp +++ b/histogram/read-write.lisp @@ -1,21 +1,17 @@ -;******************************************************** -; file: read-write.lisp -; description: Reading and writing histograms. -; date: Mon Jan 1 2007 - 17:13 -; author: Liam M. Healy -; modified: Mon Jan 1 2007 - 22:06 -;******************************************************** -;;; $Id: $ +;; Reading and writing histograms. +;; Liam Healy 2008-02-17 17:11:23EST read-write.lisp +;; Time-stamp: <2008-02-17 17:13:15EST read-write.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl write-binary-1 (object stream) +(defmfun write-binary-1 (object stream) "gsl_histogram_fwrite" ((stream :pointer) ((pointer object) :pointer)) :export nil :index write-binary) -(defun-gsl write-binary-2 (object stream) +(defmfun write-binary-2 (object stream) "gsl_histogram2d_fwrite" ((stream :pointer) ((pointer object) :pointer)) :export nil @@ -24,13 +20,13 @@ (defmethod write-binary ((object histogram) stream) (histo-1d2d object write-binary (stream))) -(defun-gsl read-binary-1 (object stream) +(defmfun read-binary-1 (object stream) "gsl_histogram_fread" ((stream :pointer) ((pointer object) :pointer)) :export nil :index read-binary) -(defun-gsl read-binary-2 (object stream) +(defmfun read-binary-2 (object stream) "gsl_histogram2d_fread" ((stream :pointer) ((pointer object) :pointer)) :export nil @@ -39,14 +35,14 @@ (defmethod read-binary ((object histogram) stream) (histo-1d2d object read-binary (stream))) -(defun-gsl write-formatted-1 (object stream format) +(defmfun write-formatted-1 (object stream format) "gsl_histogram_fprintf" ((stream :pointer) ((pointer object) :pointer) ((first format) :string) ((second format) :string)) :export nil :index write-formatted) -(defun-gsl write-formatted-2 (object stream format) +(defmfun write-formatted-2 (object stream format) "gsl_histogram2d_fprintf" ((stream :pointer) ((pointer object) :pointer) ((first format) :string) ((second format) :string)) @@ -54,41 +50,41 @@ :index write-formatted) (defmethod write-formatted ((object histogram) stream format) - "This function writes the ranges and bins of the histogram - line-by-line to the stream @var{stream} using the - format specifiers + ;; FDL + "This function writes the ranges and bins of the histogram + line-by-line to the stream using the format specifiers (first format) for range format and (second format) for bin format. - These should be one of the - @code{%g}, @code{%e} or @code{%f} formats for floating point - numbers. The histogram output is - formatted in three columns, and the columns are separated by spaces, + These should be one of the %g, %e or %f C formats for floating point + numbers. The histogram output is formatted in three columns, + and the columns are separated by spaces, like this, range[0] range[1] bin[0] range[1] range[2] bin[1] range[2] range[3] bin[2] .... range[n-1] range[n] bin[n-1] - The values of the ranges are formatted using @var{range_format} and the - value of the bins are formatted using @var{bin_format}. Each line + The values of the ranges are formatted using range format and the + value of the bins are formatted using bin format. Each line contains the lower and upper limit of the range of the bins and the value of the bin itself. Since the upper limit of one bin is the lower limit of the next there is duplication of these values between lines but this allows the histogram to be manipulated with line-oriented tools." (histo-1d2d object write-formatted (stream format))) -(defun-gsl read-formatted-1 (object stream format) +(defmfun read-formatted-1 (object stream format) "gsl_histogram_fscanf" ((stream :pointer) ((pointer object) :pointer)) :export nil :index read-formatted) -(defun-gsl read-formatted-2 (object stream format) +(defmfun read-formatted-2 (object stream format) "gsl_histogram2d_fscanf" ((stream :pointer) ((pointer object) :pointer)) :export nil :index read-formatted) (defmethod read-formatted ((object histogram) stream format) + ;; FDL "Read formatted data from the stream into the histogram. The data is assumed to be in the three-column format used by #'write-formatted. The histogram must be preallocated with diff --git a/histogram/statistics.lisp b/histogram/statistics.lisp index c7d24459a412727abc1bf2deab2dd225ad0ed6eb..6c911b9f1e86047cd74e8619ba521ce955d3165b 100644 --- a/histogram/statistics.lisp +++ b/histogram/statistics.lisp @@ -1,77 +1,73 @@ -;******************************************************** -; file: statistics.lisp -; description: Statistics of histograms. -; date: Mon Jan 1 2007 - 16:13 -; author: Liam M. Healy -; modified: Mon Jan 1 2007 - 22:39 -;******************************************************** -;;; $Id: $ +;; Statistics of histograms. +;; Liam Healy, Mon Jan 1 2007 - 16:13 +;; Time-stamp: <2008-02-17 17:07:06EST statistics.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl gsl-max-1 (histogram) +(defmfun gsl-max-1 (histogram) "gsl_histogram_max_val" (((pointer histogram) :pointer)) :c-return :double :export nil :index gsl-max - :documentation + :documentation ; FDL "The maximum value contained in the histogram bins.") -(defun-gsl gsl-max-2 (histogram) +(defmfun gsl-max-2 (histogram) "gsl_histogram2d_max_val" (((pointer histogram) :pointer)) :c-return :double :export nil :index gsl-max - :documentation + :documentation ; FDL "The maximum value contained in the histogram bins.") (defmethod gsl-max ((histogram histogram)) "The maximum value contained in the histogram bins." (histo-1d2d histogram gsl-max)) -(defun-gsl gsl-min-1 (histogram) +(defmfun gsl-min-1 (histogram) "gsl_histogram_min_val" (((pointer histogram) :pointer)) :c-return :double :export nil :index gsl-min - :documentation + :documentation ; FDL "The minimum value contained in the histogram bins.") -(defun-gsl gsl-min-2 (histogram) +(defmfun gsl-min-2 (histogram) "gsl_histogram2d_min_val" (((pointer histogram) :pointer)) :c-return :double :export nil :index gsl-min - :documentation + :documentation ; FDL "The minimum value contained in the histogram bins.") -(defmethod gsl-min ((histogram histogram)) +(defmethod gsl-min ((histogram histogram)) ; FDL "The minimum value contained in the histogram bins." (histo-1d2d histogram gsl-min)) -(defun-gsl gsl-max-index-1 (histogram) +(defmfun gsl-max-index-1 (histogram) "gsl_histogram_max_bin" (((pointer histogram) :pointer)) - :c-return :size + :c-return size :export nil :index gsl-max-index - :documentation + :documentation ; FDL "The index of the bin containing the maximum value. In the case where several bins contain the same maximum value the smallest index is returned.") -(defun-gsl gsl-max-index-2 (histogram) +(defmfun gsl-max-index-2 (histogram) "gsl_histogram2d_max_bin" (((pointer histogram) :pointer) - (xindex :size) (yindex :size)) - :c-return :size + (xindex size) (yindex size)) + :c-return size :export nil :index gsl-max-index - :documentation + :documentation ; FDL "The indices of the bin containing the maximum value. In the case where several bins contain the same maximum value the first bin found is returned.") @@ -79,25 +75,25 @@ (defmethod gsl-max-index (histogram) (histo-1d2d histogram gsl-max-index)) -(defun-gsl gsl-min-index-1 (histogram) +(defmfun gsl-min-index-1 (histogram) "gsl_histogram_min_bin" (((pointer histogram) :pointer)) - :c-return :size + :c-return size :export nil :index gsl-min-index - :documentation + :documentation ; FDL "The index of the bin containing the minimum value. In the case where several bins contain the same minimum value the smallest index is returned.") -(defun-gsl gsl-min-index-2 (histogram) +(defmfun gsl-min-index-2 (histogram) "gsl_histogram2d_min_bin" (((pointer histogram) :pointer) - (xindex :size) (yindex :size)) - :c-return :size + (xindex size) (yindex size)) + :c-return size :export nil :index gsl-min-index - :documentation + :documentation ; FDL "The indices of the bin containing the minimum value. In the case where several bins contain the same minimum value the first bin found is returned.") @@ -105,41 +101,41 @@ (defmethod gsl-min-index (histogram) (histo-1d2d histogram gsl-min-index)) -(defun-gsl mean-1 (histogram) +(defmfun mean-1 (histogram) "gsl_histogram_mean" (((pointer histogram) :pointer)) :c-return :double :export nil :index mean - :documentation + :documentation ; FDL "The mean of the histogrammed variable, where the histogram is regarded as a probability distribution. Negative bin values are ignored for the purposes of this calculation. The resolution of the result is limited by the bin width.") -(defun-gsl mean-2x (histogram) +(defmfun mean-2x (histogram) "gsl_histogram2d_xmean" (((pointer histogram) :pointer)) :c-return :double :export nil :index mean - :documentation + :documentation ; FDL "The mean of the histogrammed x variable, where the histogram is regarded as a probability distribution. Negative bin values are ignored for the purposes of this calculation.") -(defun-gsl mean-2y (histogram) +(defmfun mean-2y (histogram) "gsl_histogram2d_ymean" (((pointer histogram) :pointer)) :c-return :double :export nil :index mean - :documentation + :documentation ; FDL "The mean of the histogrammed y variable, where the histogram is regarded as a probability distribution. Negative bin values are ignored for the purposes of this calculation.") -(defmethod mean ((histogram histogram)) +(defmethod mean ((histogram histogram)) ; FDL "The mean of the histogrammed y variable, where the histogram is regarded as a probability distribution. Negative bin values are ignored for the purposes of this calculation. For 2d @@ -148,27 +144,27 @@ (values (mean-2x histogram) (mean-2y histogram)))) (histo-1d2d histogram mean ))) -(defun-gsl sigma-1 (histogram) +(defmfun sigma-1 (histogram) "gsl_histogram_sigma" (((pointer histogram) :pointer)) :c-return :double :export nil :index sigma - :documentation + :documentation ; FDL "The standard deviation of the histogrammed variable, where the histogram is regarded as a probability distribution. Negative bin values are ignored for the purposes of this calculation. The resolution of the result is limited by the bin width.") -(defun-gsl sigma-2x (histogram) +(defmfun sigma-2x (histogram) "gsl_histogram2d_xsigma" (((pointer histogram) :pointer)) :c-return :double :export nil :index sigma) -(defun-gsl sigma-2y (histogram) +(defmfun sigma-2y (histogram) "gsl_histogram2d_ysigma" (((pointer histogram) :pointer)) :c-return :double @@ -182,43 +178,44 @@ bin values are ignored for the purposes of this calculation. The resolution of the result is limited by the bin width. For 2d histograms, the sigmas are returned as - multiple values." + multiple values." ; FDL (flet ((sigma-2 (histogram) (values (sigma-2x histogram) (sigma-2y histogram)))) (histo-1d2d histogram sigma))) -(defun-gsl histogram-covariance (histogram-2d) +(defmfun histogram-covariance (histogram-2d) "gsl_histogram2d_cov" (((pointer histogram-2d) :pointer)) :c-return :double - :documentation + :documentation ; FDL "The covariance of the histogrammed x and y variables, where the histogram is regarded as a probability distribution. Negative bin values are ignored for the purposes of this calculation.") -(defun-gsl sum-1 (histogram) +(defmfun sum-1 (histogram) "gsl_histogram_sum" (((pointer histogram) :pointer)) :c-return :double :export nil :index sum - :documentation + :documentation ; FDL "The sum of all bin values. Negative bin values are included in the sum.") -(defun-gsl sum-2 (histogram) +(defmfun sum-2 (histogram) "gsl_histogram2d_sum" (((pointer histogram) :pointer)) :c-return :double :export nil :index sum - :documentation + :documentation ; FDL "The sum of all bin values. Negative bin values are included in the sum.") (export 'sum) (defun sum (histogram) + ;; FDL "The sum of all bin values. Negative bin values are included in the sum." (histo-1d2d histogram sum)) diff --git a/histogram/updating-accessing.lisp b/histogram/updating-accessing.lisp index dcfcd0826f7b2a4f537b68274ebab2e5c6189ead..dccfa1ae888934a03ade74df9d5657549eee43fa 100644 --- a/histogram/updating-accessing.lisp +++ b/histogram/updating-accessing.lisp @@ -1,22 +1,17 @@ -;******************************************************** -; file: updating-accessing.lisp -; description: Updating and accessing histogram -; elements. -; date: Mon Jan 1 2007 - 14:43 -; author: Liam M. Healy -; modified: Sun Jan 28 2007 - 22:19 -;******************************************************** -;;; $Id: $ +;; Updating and accessing histogram elements. +;; Liam Healy, Mon Jan 1 2007 - 14:43 +;; Time-stamp: <2008-02-17 17:04:08EST updating-accessing.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl increment-fix (histogram value) +(defmfun increment-fix (histogram value) "gsl_histogram_increment" (((pointer histogram) :pointer) (value :double)) :index increment :export nil) -(defun-gsl increment-weight (histogram value weight) +(defmfun increment-weight (histogram value weight) "gsl_histogram_accumulate" (((pointer histogram) :pointer) (value :double) (weight :double)) :index increment @@ -24,93 +19,94 @@ (defun-optionals increment (histogram value &optional weight) -fix -weight - "Update the histogram @var{h} by adding the weight + ;; FDL + "Update the histogram by adding the weight (which defaults to 1.0) to the - bin whose range contains the coordinate @var{x}. + bin whose range contains the coordinate x. - If @var{x} lies in the valid range of the histogram then the function - returns zero to indicate success. If @var{x} is less than the lower - limit of the histogram then the function issues a warning EDOM, and - none of bins are modified. Similarly, if the value of @var{x} is greater + If x lies in the valid range of the histogram then the function + returns zero to indicate success. If x is less than the lower + limit of the histogram then the function issues a warning :EDOM, and + none of bins are modified. Similarly, if the value of x is greater than or equal to the upper limit of the histogram then the function - issues a warning EDOM, and none of the bins are modified. The error + issues a warning :EDOM, and none of the bins are modified. The error handler is not called, however, since it is often necessary to compute histograms for a small range of a larger dataset, ignoring the values outside the range of interest.") -(defun-gsl gsl-aref ((histogram histogram) &rest i) +(defmfun gsl-aref ((histogram histogram) &rest i) "gsl_histogram_get" - (((pointer histogram) :pointer) ((first i) :size)) + (((pointer histogram) :pointer) ((first i) size)) :type :method :c-return :double - :documentation - "Return the contents of the @var{i}-th bin of the histogram. - If @var{i} lies outside the valid range of indices for the - histogram then an error (EDOM) is signalled.") + :documentation ; FDL + "Return the contents of the i-th bin of the histogram. + If i lies outside the valid range of indices for the + histogram then an error (:EDOM) is signalled.") -(defun-gsl range (histogram i) +(defmfun range (histogram i) "gsl_histogram_get_range" - (((pointer histogram) :pointer) (i :size) + (((pointer histogram) :pointer) (i size) (lower :double) (upper :double)) - :documentation - "Find the upper and lower range limits of the @var{i}-th - bin of the histogram @var{h}. If the index @var{i} is valid then the - corresponding range limits are stored in @var{lower} and @var{upper}. + :documentation ; FDL + "Find the upper and lower range limits of the i-th + bin of the histogram. If the index i is valid then the + corresponding range limits are stored in lower and upper. The lower limit is inclusive (i.e. events with this coordinate are included in the bin) and the upper limit is exclusive (i.e. events with the coordinate of the upper limit are excluded and fall in the neighboring higher bin, if it exists). - If @var{i} lies outside the valid range of indices for - the histogram, then the error EDOM is signalled.") + If i lies outside the valid range of indices for + the histogram, then the error :EDOM is signalled.") -(defun-gsl gsl-max-range (histogram) +(defmfun gsl-max-range (histogram) "gsl_histogram_max" (((pointer histogram) :pointer)) :c-return :double - :documentation + :documentation ; FDL "The maximum upper range limit of the histogram.") -(defun-gsl gsl-min-range (histogram) +(defmfun gsl-min-range (histogram) "gsl_histogram_min" (((pointer histogram) :pointer)) :c-return :double - :documentation + :documentation ; FDL "The minimum lower range limit of the histogram.") -(defun-gsl bins (histogram) +(defmfun bins (histogram) "gsl_histogram_bins" (((pointer histogram) :pointer)) :c-return :int - :documentation + :documentation ; FDL "The number of bins in the histogram.") -(defun-gsl reset (histogram) +(defmfun reset (histogram) "gsl_histogram_reset" (((pointer histogram) :pointer)) :c-return :void - :documentation + :documentation ; FDL "Reset all the bins in the histogram to zero.") -(defun-gsl histogram-find-1 (histogram value) +(defmfun histogram-find-1 (histogram value) "gsl_histogram_find" - (((pointer histogram) :pointer) (value :double) (bin :size)) + (((pointer histogram) :pointer) (value :double) (bin size)) :export nil :index histogram-find - :documentation + :documentation ; FDL "Finds the bin number which covers the coordinate value in the histogram. The bin is located using a binary search. The search includes an optimization for histograms with uniform range, and will return the correct bin immediately in this case. If the value is found in the range of the histogram then the function returns the index. If value lies outside - the valid range of the histogram then the error EDOM is + the valid range of the histogram then the error :EDOM is signalled.") -(defun-gsl histogram-find-2 (histogram x-value y-value) +(defmfun histogram-find-2 (histogram x-value y-value) "gsl_histogram2d_find" (((pointer histogram) :pointer) (x-value :double) (y-value :double) - (xbin :size) (ybin :size)) + (xbin size) (ybin size)) :export nil :index histogram-find) @@ -121,61 +117,112 @@ ((first values) (second values)))) ;;; Examples and unit test -(lisp-unit:define-test histogram - (lisp-unit:assert-error - 'gsl-warning - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo -2.0d0))) - (lisp-unit:assert-first-fp-equal - "0.000000000000d+01" - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (gsl-aref histo 1))) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (gsl-aref histo 2))) - (lisp-unit:assert-first-fp-equal - "0.200000000000d+01" - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (gsl-aref histo 6))) - (lisp-unit:assert-error - 'gsl-error - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (gsl-aref histo 16))) - (lisp-unit:assert-equal - '("0.000000000000d+01" "0.100000000000d+02") - (lisp-unit:fp-values - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (values (gsl-min-range histo) (gsl-max-range histo))))) - (lisp-unit:assert-eql - 10 - (letm ((histo (histogram 10))) - (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (bins histo))) - (lisp-unit:assert-eql - 5 - (letm ((histo (histogram 10))) + +#| +(make-tests histogram + (letm ((histo (histogram 10))) ; should be a gsl-warning here, how to check? (set-ranges-uniform histo 0.0d0 10.0d0) - (increment histo 2.7d0) - (increment histo 6.9d0 2.0d0) - (histogram-find histo 5.5d0)))) + (increment histo -2.0d0)) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (gsl-aref histo 1)) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (gsl-aref histo 2)) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (gsl-aref histo 6)) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (gsl-aref histo 16)) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (values (gsl-min-range histo) (gsl-max-range histo))) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (bins histo)) + (letm ((histo (histogram 10))) + (set-ranges-uniform histo 0.0d0 10.0d0) + (increment histo 2.7d0) + (increment histo 6.9d0 2.0d0) + (histogram-find histo 5.5d0))) +|# + +(LISP-UNIT:DEFINE-TEST HISTOGRAM + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO -2.0d0)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (GSL-AREF HISTO 1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (GSL-AREF HISTO 2)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (GSL-AREF HISTO 6)))) + (LISP-UNIT:ASSERT-ERROR + 'GSL-ERROR + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (GSL-AREF HISTO 16))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.0d0 10.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (VALUES (GSL-MIN-RANGE HISTO) + (GSL-MAX-RANGE HISTO))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 10) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (BINS HISTO)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 5) + (MULTIPLE-VALUE-LIST + (LETM ((HISTO (HISTOGRAM 10))) + (SET-RANGES-UNIFORM HISTO 0.0d0 10.0d0) + (INCREMENT HISTO 2.7d0) + (INCREMENT HISTO 6.9d0 2.0d0) + (HISTOGRAM-FIND HISTO 5.5d0))))) + diff --git a/init/init.lisp b/init/init.lisp index 3a14bb2eff2b4f3bf8f477974dddfb7425395b38..3c029e7ae53a874cd72bcf3b545e02cc11cb080f 100644 --- a/init/init.lisp +++ b/init/init.lisp @@ -1,6 +1,6 @@ ;; Load GSL ;; Liam Healy Sat Mar 4 2006 - 18:53 -;; Time-stamp: <2008-02-16 17:56:56EST init.lisp> +;; Time-stamp: <2008-02-17 18:58:32EST init.lisp> ;; $Id: $ (defpackage gsll @@ -21,26 +21,14 @@ ;;; The following define :size, from cffi-unix which became cffi-net, ;;; which is apparently turning into something even bigger and more -;;; irrelevant. All we need is the definition of :size. This should -;;; be changed to something outside the keyword package to suppress -;;; warnings from CFFI. +;;; irrelevant. All we need is the definition of :size. This is +;;; not in the keyword package to suppress warnings from CFFI. (cffi:defctype uint32 :unsigned-int) (cffi:defctype uint64 :unsigned-long) -(cffi:defctype size +(cffi:defctype gsll::size #-cffi-features:no-long-long uint64 #+cffi-features:no-long-long #.(progn (cerror "Use uint32 instead." "This platform does not support long long types.") uint32)) - -;;; obsolete - -(cffi:defctype :uint32 :unsigned-int) -(cffi:defctype :uint64 :unsigned-long) -(cffi:defctype :size - #-cffi-features:no-long-long :uint64 - #+cffi-features:no-long-long - #.(progn (cerror "Use :uint32 instead." - "This platform does not support long long types.") - :uint32)) diff --git a/init/interface.lisp b/init/interface.lisp index 8cfaa6f1daa322904f054c530ee9aa2e862cf350..7754b1772c83ab633ff4c3a295cdf05a7bdffa1e 100644 --- a/init/interface.lisp +++ b/init/interface.lisp @@ -1,6 +1,6 @@ ;; Macros to interface GSL functions. ;; Liam Healy -;; Time-stamp: <2008-02-16 17:47:30EST interface.lisp> +;; Time-stamp: <2008-02-17 18:44:18EST interface.lisp> ;; $Id: $ (in-package :gsl) @@ -97,7 +97,6 @@ ;;;; Argument check ;;;;**************************************************************************** - #+example (cl-argument-types '(U M) @@ -106,7 +105,7 @@ (defparameter *c-to-cl-types* `((:double . double-float) (:float . single-float) (:int . fixnum) - (:size . (integer 0 ,most-positive-fixnum)))) + (size . (integer 0 ,most-positive-fixnum)))) (defun cl-argument-types (cl-arguments c-arguments-types) "Create CL argument and types from the C arguments." @@ -120,12 +119,10 @@ (cons 'declare (mapcar (lambda (v) (cons 'type (reverse v))) cl-argument-types))) - ;;;;**************************************************************************** -;;;; Macro defun-gsl +;;;; Macro defmfun ;;;;**************************************************************************** - (defvar *special-c-return* '(:error-code :number-of-answers :success-failure :success-continue :true-false :enumerate)) @@ -251,109 +248,6 @@ ,@(when index `((map-name ',(if (eql index t) name index) ,gsl-name))) ,@(when export `((export ',name)))))) - -;;; to be removed -(defmacro defun-gsl - (name arglist gsl-name c-arguments - &key (c-return :error-code) - (return nil return-supplied-p) - (type :function) (index t) (export (not (eq type :method))) - null-pointer-info documentation invalidate after enumeration) - (let* ((cargs (substitute '(mode sf-mode) :mode c-arguments)) - (carg-symbs - (remove-if-not #'symbolp - (mapcar #'st-symbol (remove :mode c-arguments)))) - (clargs - (or arglist carg-symbs)) - (arglist-symbs - (when arglist ; can be method, so get symbol - (mapcar (lambda (x) (if (listp x) (first x) x)) arglist))) - (cret-type (if (member c-return *special-c-return*) - :int - (if (listp c-return) (st-type c-return) c-return))) - (cret-name - (if (listp c-return) (st-symbol c-return) (make-symbol "CRETURN"))) - (allocated ; Foreign objects to be allocated - (remove-if (lambda (s) (member s arglist-symbs)) carg-symbs)) - (allocated-decl - (mapcar - (lambda (s) (find s cargs :key #'st-symbol)) - allocated)) - (clret (or (substitute cret-name :c-return return) ; better as a symbol macro - (mapcan #'cl-convert-form allocated-decl) - invalidate - (unless (eq c-return :void) - (list cret-name)))) - (clargs-types (cl-argument-types clargs cargs))) - `(progn - (,(if (eq type :function) 'defun 'defmethod) - ,name - ,(if (member :mode c-arguments) - `(,@clargs &optional (mode :double-prec)) - `(,@clargs)) - ,(declaration-form clargs-types) - ,@(when documentation (list documentation)) - (,@(if allocated - `(cffi:with-foreign-objects - ,(mapcar #'wfo-declare allocated-decl)) - '(let ())) - (let ((,cret-name - (cffi:foreign-funcall - ,gsl-name - ,@(mapcan - (lambda (arg) - (list (if (member (st-symbol arg) allocated) - :pointer - (st-type arg)) - (st-symbol arg))) - cargs) - ,cret-type))) - ,@(case c-return - (:void `((declare (ignore ,cret-name)))) - (:error-code ; fill in arguments - `((check-gsl-status ,cret-name ',name)))) - ,@(when invalidate `((cl-invalidate ,@invalidate))) - ,@(when (or null-pointer-info (eq c-return :pointer)) - `((check-null-pointer ,cret-name - ,@(or null-pointer-info - '(:ENOMEM "No memory allocated"))))) - ,@after - (values - ,@(case c-return - (:number-of-answers - (mapcan - (lambda (vbl seq) - `((when (> ,cret-name ,seq) ,vbl))) - clret - (loop for i below (length clret) collect i))) - (:success-failure - (if (equal clret invalidate) - ;; success-failure more important than passed-in - `((success-failure ,cret-name)) - (remove cret-name ; don't return c-return itself - `(,@clret (success-failure ,cret-name))))) - (:success-continue - (if (equal clret invalidate) - ;; success-failure more important than passed-in - `((success-continue ,cret-name)) - (remove cret-name ; don't return c-return itself - `(,@clret (success-continue ,cret-name))))) - (:true-false - `((not (zerop ,cret-name)))) - (:enumerate - `((cffi:foreign-enum-keyword ',enumeration ,cret-name))) - (t (unless - (or - (and (eq c-return :error-code) - (not allocated) - (not return-supplied-p)) - (and (null return) return-supplied-p)) - clret))))))) - ,@(when index `((map-name ',(if (eql index t) name index) ,gsl-name))) - ,@(when export `((export ',name)))))) - - - (defmacro defun-optionals (name arglist no-optional optionals &optional documentation) "Define a function with and without optional arguments." @@ -383,15 +277,6 @@ (map-name ',cl-symbol ,gsl-symbol) (export ',cl-symbol))) -;;; to be removed -(defmacro defvariable (cl-symbol gsl-symbol documentation) - "Define a library variable pointer." - `(progn - (cffi:defcvar (,gsl-symbol ,cl-symbol :read-only t) :pointer - ,documentation) - (map-name ',cl-symbol ,gsl-symbol) - (export ',cl-symbol))) - ;;;;**************************************************************************** ;;;; GSL library version ;;;;**************************************************************************** diff --git a/init/number-conversion.lisp b/init/number-conversion.lisp index ec0c16b07830d5126159fe290ca1c9ad9c656517..1306742625bcc44e27c49b7c240c454a422b9607 100644 --- a/init/number-conversion.lisp +++ b/init/number-conversion.lisp @@ -1,6 +1,6 @@ ;; Conversion of numbers C->CL ;; Liam Healy, Sun May 28 2006 - 22:04 -;; Time-stamp: <2008-01-28 22:09:08EST number-conversion.lisp> +;; Time-stamp: <2008-02-17 18:54:32EST number-conversion.lisp> ;; $Id: $ (in-package :gsl) @@ -21,7 +21,7 @@ (defmacro scref (size &optional (index 0)) "Reference C size(s)." - `(cffi:mem-aref ,size :size ,index)) + `(cffi:mem-aref ,size 'size ,index)) (defmacro icref (integer &optional (index 0)) "Reference C integer(s)." @@ -31,7 +31,7 @@ (case type (:float 'fcref) (:double 'dcref) - (:size 'scref) + (size 'scref) (:int 'icref) (gsl-complex 'complex-to-cl))) diff --git a/init/tests.lisp b/init/tests.lisp index e5cde39135af2fbf31b06138e5eddd0979b1b043..2c7663eec641e398aa96b57d6125ec079d4a6a78 100644 --- a/init/tests.lisp +++ b/init/tests.lisp @@ -31,6 +31,7 @@ (or (typep result1 'vector) (typep result2 'vector) (typep result1 'complex) (typep result2 'complex) + (typep result1 'array) (typep result2 'array) (eql (type-of result1) (type-of result2))) (typecase result1 (integer (= result1 result2)) @@ -63,7 +64,7 @@ (defun gsl::make-test (form) "Make a test for lisp-unit." (let ((vals (multiple-value-list (ignore-errors (eval form))))) - (if (typep (second vals) 'error) + (if (typep (second vals) 'condition) `(lisp-unit::assert-error ',(type-of (second vals)) ,form) @@ -75,96 +76,3 @@ (append `(lisp-unit:define-test ,name) (mapcar #'gsl::make-test forms))) - - -;;;;;;;;;;;;;; OBSOLETE - -(export '(assert-first-fp-equal fp-values fp-sequence)) - -(defmacro fp-values (results) - `(mapcar #'fp-record (multiple-value-list ,results))) - -(defparameter *test-fp-decimal-digits* 12 - "The number of decimal digits on which floating point - number must agree.") - -(defun fp-string (fp &optional (decimal-digits *test-fp-decimal-digits*)) - "Format the floating point number as a string for comparison." - (if (typep fp 'complex) - (list (fp-string (realpart fp)) (fp-string (imagpart fp))) - (format nil "~,v,2,0,,,ve" - decimal-digits (if (typep fp 'double-float) #\d #\e) - (if (< (abs fp) *zero-threshold*) - 0.0d0 - fp)))) - -(defmacro assert-first-fp-equal (expected form &rest extras) - (lisp-unit::expand-assert - :equal form `(fp-string (nth-value 0 ,form)) expected extras - :test #'string-equal)) - -(defmacro fp-values (results) - `(mapcar #'fp-string (multiple-value-list ,results))) - -(defun fp-sequence (results) - (map 'list #'fp-string results)) - - - - - -#| - - - -;;(gsl:double-float-unequal x y double-float-epsilon) - - - -;;; Tests: -;;; assert-float-equal: First value only -;;; turn multiple values into a list -;;; compare sequences including structure. - - - -(defmacro assert-fp-equal (expected form &rest extras) - (lisp-unit::expand-assert - :equal form `(fp-string (nth-value 0 ,form)) expected extras - :test #'fp-equal)) - -(defun fp-record (fp) - "Record the floating point number for comparison." - (if (typep fp 'complex) - (list (fp-record (realpart fp)) (fp-record (imagpart fp))) - ;; relies on ~g printing full precision per spec - (format nil "~g" fp))) - -(defun fp-record (fp) - "Record the floating point number for comparison." - (etypecase fp - (complex - (list (fp-record (realpart fp)) (fp-record (imagpart fp)))) - (sequence (map (type-of fp) #'fp-record)) - ;; relies on ~g printing full precision per spec - (float (format nil "~g" fp)))) - - -(defun fp-sequence (results) - (map 'list #'fp-string results)) - - - -;;;;;;;;;;;;;;;;; -;;; Thinking about how to do floating point comparisons - -(defun gsl::equal-float (x rat) - "Is the float very close to the rational?" - (<= (abs (- rat (rationalize x))) - (* 4 (if (typep x 'double-float) - double-float-epsilon - single-float-epsilon)))) - - - -|# diff --git a/interpolation/evaluation.lisp b/interpolation/evaluation.lisp index fd6864ffb2fe70ce3bd548b2630abe4935f6baa6..c4ffbeed3db52a81764d6685e5f718f7bde9ae3d 100644 --- a/interpolation/evaluation.lisp +++ b/interpolation/evaluation.lisp @@ -1,88 +1,82 @@ -;******************************************************** -; file: evaluation.lisp -; description: Evaluation of interpolation functions. -; date: Sun Nov 4 2007 - 18:40 -; author: Liam Healy -; modified: Sun Nov 4 2007 - 19:04 -;******************************************************** -;;; $Id: $ +;; Evaluation of interpolation functions. +;; Liam Healy, Sun Nov 4 2007 - 18:40 (in-package :gsl) -(defun-gsl evaluate-interpolation (interpolation xa ya x acceleration) +(defmfun evaluate-interpolation (interpolation xa ya x acceleration) "gsl_interp_eval" ((interpolation :pointer) (xa :pointer) (ya :pointer) (x :double) (acceleration :pointer)) :c-return :double - :documentation - "Find the interpolated value of @var{y} for a given - point @var{x}, using the interpolation object 'interpolation, data arrays - @var{xa} and @var{ya} and the accelerator 'acceleration.") + :documentation ; FDL + "Find the interpolated value of y for a given + point x, using the interpolation object interpolation, data arrays + xa and ya and the accelerator acceleration.") -(defun-gsl derivative-evaluate-interpolation (interpolation xa ya x acceleration) +(defmfun derivative-evaluate-interpolation (interpolation xa ya x acceleration) "gsl_interp_eval_deriv" ((interpolation :pointer) (xa :pointer) (ya :pointer) (x :double) (acceleration :pointer)) :c-return :double - :documentation + :documentation ; FDL "Find the derivative of an interpolated function for a given point - @var{x}, using the interpolation object 'interpolation, data arrays - @var{xa} and @var{ya} and the accelerator 'acceleration.") + x, using the interpolation object interpolation, data arrays + xa and ya and the accelerator acceleration.") -(defun-gsl second-derivative-evaluate-interpolation (interpolation xa ya x acceleration) +(defmfun second-derivative-evaluate-interpolation (interpolation xa ya x acceleration) "gsl_interp_eval_deriv2" ((interpolation :pointer) (xa :pointer) (ya :pointer) (x :double) (acceleration :pointer)) :c-return :double - :documentation + :documentation ; FDL "Find the second derivative of an interpolated function for a given point - @var{x}, using the interpolation object 'interpolation, data arrays - @var{xa} and @var{ya} and the accelerator 'acceleration.") + x, using the interpolation object interpolation, data arrays + xa and ya and the accelerator acceleration.") -(defun-gsl integral-evaluate-interpolation (interpolation xa ya x low high acceleration) +(defmfun integral-evaluate-interpolation (interpolation xa ya x low high acceleration) "gsl_interp_eval_integ" ((interpolation :pointer) (xa :pointer) (ya :pointer) (x :double) (low :double) (high :double) (acceleration :pointer)) :c-return :double - :documentation + :documentation ; FDL "Find the numerical integral of an interpolated function over the - range [low, high], using the interpolation object 'interpolation, - data arrays @var{xa} and @var{ya} and the accelerator 'acceleration.") + range [low, high], using the interpolation object interpolation, + data arrays xa and ya and the accelerator 'acceleration.") ;;; Spline -(defun-gsl evaluate-spline (spline x acceleration) +(defmfun evaluate-spline (spline x acceleration) "gsl_spline_eval" ((spline :pointer) (x :double) (acceleration :pointer)) :c-return :double :documentation - "Find the interpolated value of @var{y} for a given - point @var{x}, using the spline object 'spline, data arrays - @var{xa} and @var{ya} and the accelerator 'acceleration.") + "Find the interpolated value of y for a given + point x, using the spline object spline, data arrays + xa and ya and the accelerator 'acceleration.") -(defun-gsl derivative-evaluate-spline (spline x acceleration) +(defmfun derivative-evaluate-spline (spline x acceleration) "gsl_spline_eval_deriv" ((spline :pointer) (x :double) (acceleration :pointer)) :c-return :double - :documentation + :documentation ; FDL "Find the derivative of an interpolated function for a given point - @var{x}, using the spline object 'spline, data arrays - @var{xa} and @var{ya} and the accelerator 'acceleration.") + x, using the spline object spline, data arrays + xa and ya and the accelerator acceleration.") -(defun-gsl second-derivative-evaluate-spline (spline x acceleration) +(defmfun second-derivative-evaluate-spline (spline x acceleration) "gsl_spline_eval_deriv2" ((spline :pointer) (x :double) (acceleration :pointer)) :c-return :double - :documentation + :documentation ; FDL "Find the second derivative of an interpolated function for a given point - @var{x}, using the spline object 'spline, data arrays - @var{xa} and @var{ya} and the accelerator 'acceleration.") + x, using the spline object spline, data arrays + xa and ya and the accelerator acceleration.") -(defun-gsl integral-evaluate-spline (spline x low high acceleration) +(defmfun integral-evaluate-spline (spline x low high acceleration) "gsl_spline_eval_integ" ((spline :pointer) (x :double) (low :double) (high :double) (acceleration :pointer)) :c-return :double - :documentation + :documentation ; FDL "Find the numerical integral of an interpolated function over the - range [low, high], using the spline object 'spline, - data arrays @var{xa} and @var{ya} and the accelerator 'acceleration.") + range [low, high], using the spline object spline, + data arrays xa and ya and the accelerator acceleration.") diff --git a/interpolation/interpolation.lisp b/interpolation/interpolation.lisp index 92dddd1cee8e15a2f8e8b18afdce53f17f32c713..f26a4f43222ae671f684ef8bcc6bf59d45cd5fd7 100644 --- a/interpolation/interpolation.lisp +++ b/interpolation/interpolation.lisp @@ -1,6 +1,6 @@ ;; Interpolation allocation, initialization, and freeing. ;; Liam Healy, Sun Nov 4 2007 - 17:24 -;; Time-stamp: <2008-02-03 22:55:28EST interpolation.lisp> +;; Time-stamp: <2008-02-17 17:45:18EST interpolation.lisp> ;; $Id: $ (in-package :gsl) @@ -17,9 +17,9 @@ `(initialize-interpolation ,symb ,xa-or-size ,ya))))) ;;; Interpolation -(defun-gsl allocate-interpolation (type size) +(defmfun allocate-interpolation (type size) "gsl_interp_alloc" - ((type :pointer) (size :size)) + ((type :pointer) (size size)) :c-return :pointer :export nil :index (letm interpolation) @@ -27,10 +27,10 @@ "Allocate an interpolation object of type for size data-points, and return the pointer to it.") -(defun-gsl initialize-interpolation (interpolation xa ya) +(defmfun initialize-interpolation (interpolation xa ya) "gsl_interp_init" ((interpolation :pointer) - ((gsl-array xa) :pointer) ((gsl-array ya) :pointer) ((dim0 xa) :size)) + ((gsl-array xa) :pointer) ((gsl-array ya) :pointer) ((dim0 xa) size)) :documentation ; FDL "Initialize the interpolation object interp for the data (xa,ya) where xa and ya are gsl-arrays. The interpolation object does not save @@ -38,14 +38,14 @@ computed from the data. The xa data array is always assumed to be strictly ordered; the behavior for other arrangements is not defined.") -(defun-gsl free-interpolation (interpolation) +(defmfun free-interpolation (interpolation) "gsl_interp_free" ((interpolation :pointer)) :c-return :void :export nil :index (letm interpolation) - :documentation - "Frees the interpolation object @var{interp}.") + :documentation ; FDL + "Frees the interpolation object interp.") (defgo spline (type xa-or-size &optional ya) (list @@ -56,18 +56,18 @@ `(initialize-spline ,symb ,xa-or-size ,ya))))) ;;; Spline -(defun-gsl allocate-spline (type size) +(defmfun allocate-spline (type size) "gsl_spline_alloc" - ((type :pointer) (size :size)) + ((type :pointer) (size size)) :c-return :pointer :documentation ; FDL "Allocate an interpolation object of type for size data-points, and return the pointer to it.") -(defun-gsl initialize-spline (interpolation xa ya) +(defmfun initialize-spline (interpolation xa ya) "gsl_spline_init" ((interpolation :pointer) - ((gsl-array xa) :pointer) ((gsl-array ya) :pointer) ((dim0 xa) :size)) + ((gsl-array xa) :pointer) ((gsl-array ya) :pointer) ((dim0 xa) size)) :documentation ; FDL "Initialize the interpolation object interp for the data (xa,ya) where xa and ya are gsl-arrays. The spline object saves @@ -75,7 +75,7 @@ The xa data array is always assumed to be strictly ordered; the behavior for other arrangements is not defined.") -(defun-gsl free-spline (interpolation) +(defmfun free-spline (interpolation) "gsl_spline_free" ((interpolation :pointer)) :c-return :void diff --git a/interpolation/lookup.lisp b/interpolation/lookup.lisp index 4a526f92063155240ecd1779e664412268fd01b4..5574143fca75fc601fd64b4e1cb9ebfa19a88f7d 100644 --- a/interpolation/lookup.lisp +++ b/interpolation/lookup.lisp @@ -1,53 +1,47 @@ -;******************************************************** -; file: lookup.lisp -; description: Index lookup and acceleration -; date: Sun Nov 4 2007 - 18:09 -; author: Liam Healy -; modified: Sat Nov 10 2007 - 21:16 -;******************************************************** -;;; $Id: $ +;; Index lookup and acceleration +;; Liam Healy, Sun Nov 4 2007 - 18:09 +;; Time-stamp: <2008-02-17 17:50:25EST lookup.lisp> +;; $Id: $ (in-package :gsl) (defgo-s (acceleration) allocate-acceleration free-acceleration nil 0) -(defun-gsl interpolation-search (x-array x low-index high-index) +(defmfun interpolation-search (x-array x low-index high-index) "gsl_interp_bsearch" - ((x-array :pointer) (x :double) (low-index :size) (high-index :size)) - :c-return :size - :documentation - "Find the index @math{i} of the array @var{x-array} such - that @code{x-array[i] <= x < x-array[i+1]}. The index is searched for + ((x-array :pointer) (x :double) (low-index size) (high-index size)) + :c-return size + :documentation ; FDL + "Find the index i of the array x-array such + that x-array[i] <= x < x-array[i+1]. The index is searched for in the range [low-index, high-index].") -(defun-gsl allocate-acceleration () +(defmfun allocate-acceleration () "gsl_interp_accel_alloc" () :c-return :pointer :export nil :index (letm acceleration) - :documentation + :documentation ; FDL "Allocate an accelerator object, which is a kind of iterator for interpolation lookups. It tracks the state of lookups, thus allowing for application of various acceleration strategies.") -(defun-gsl accelerated-interpolation-search (x-array x acceleration) +(defmfun accelerated-interpolation-search (x-array x acceleration) "gsl_interp_accel_find" ((acceleration :pointer) (x-array :pointer) (x :double)) - :c-return :size - :documentation - "Search the data array @var{x_array} - of size @var{size}, using the given accelerator @var{a}. This is how - lookups are performed during evaluation of an interpolation. The - function returns an index @math{i} such that @code{x_array[i] <= x < - x_array[i+1]}.") + :c-return size + :documentation ; FDL + "Search the data array x-array of size, using the given acceleration. + This is how lookups are performed during evaluation of an interpolation. The + function returns an index i such that x_array[i] <= x < x_array[i+1]}.") -(defun-gsl free-acceleration (acceleration) +(defmfun free-acceleration (acceleration) "gsl_interp_accel_free" ((acceleration :pointer)) :export nil :index (letm acceleration) :c-return :void - :documentation + :documentation ; FDL "Frees the accelerator object.") diff --git a/interpolation/types.lisp b/interpolation/types.lisp index 21a3e4e56f2e9d552f9009d5bc4179ca47ca835c..704a4e2103c454366768700f6c62dd6bb9a5efcb 100644 --- a/interpolation/types.lisp +++ b/interpolation/types.lisp @@ -1,32 +1,32 @@ -;******************************************************** -; file: types.lisp -; description: Interpolation types -; date: Sun Nov 4 2007 - 17:41 -; author: Liam Healy -; modified: Mon Nov 26 2007 - 21:07 -;******************************************************** -;;; $Id: $ +;; Interpolation types +;; Liam Healy, Sun Nov 4 2007 - 17:41 +;; Time-stamp: <2008-02-17 17:47:53EST types.lisp> +;; $Id: $ (in-package :gsl) -(defvariable *linear-interpolation* "gsl_interp_linear" +(defmpar *linear-interpolation* "gsl_interp_linear" + ;; FDL "Linear interpolation. This interpolation method does not require any additional memory.") -(defvariable *polynomial-interpolation* "gsl_interp_polynomial" +(defmpar *polynomial-interpolation* "gsl_interp_polynomial" + ;; FDL "Polynomial interpolation. This method should only be used for interpolating small numbers of points because polynomial interpolation introduces large oscillations, even for well-behaved datasets. The number of terms in the interpolating polynomial is equal to the number of points.") -(defvariable *cubic-spline-interpolation* "gsl_interp_cspline" +(defmpar *cubic-spline-interpolation* "gsl_interp_cspline" + ;; FDL "Cubic spline with natural boundary conditions. The resulting curve is piecewise cubic on each interval, with matching first and second derivatives at the supplied data-points. The second derivative is chosen to be zero at the first point and last point.") -(defvariable *periodic-cubic-spline-interpolation* "gsl_interp_cspline_periodic" +(defmpar *periodic-cubic-spline-interpolation* "gsl_interp_cspline_periodic" + ;; FDL "Cubic spline with periodic boundary conditions. The resulting curve is piecewise cubic on each interval, with matching first and second derivatives at the supplied data-points. The derivatives at the first @@ -35,42 +35,44 @@ resulting periodic interpolation will have a discontinuity at the boundary.") -(defvariable *akima-interpolation* "gsl_interp_akima" +(defmpar *akima-interpolation* "gsl_interp_akima" + ;; FDL "Non-rounded Akima spline with natural boundary conditions. This method uses the non-rounded corner algorithm of Wodicka.") -(defvariable *periodic-akima-interpolation* "gsl_interp_akima_periodic" +(defmpar *periodic-akima-interpolation* "gsl_interp_akima_periodic" + ;; FDL "Non-rounded Akima spline with periodic boundary conditions. This method uses the non-rounded corner algorithm of Wodicka.") -(defun-gsl interpolation-name (interpolation) +(defmfun interpolation-name (interpolation) "gsl_interp_name" ((interpolation :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the interpolation type.") -(defun-gsl interpolation-minimum-size (interpolation) +(defmfun interpolation-minimum-size (interpolation) "gsl_interp_min_size" ((interpolation :pointer)) :c-return :uint - :documentation + :documentation ; FDL "The minimum number of points required by the interpolation. For example, Akima spline interpolation requires a minimum of 5 points.") -(defun-gsl spline-name (interpolation) +(defmfun spline-name (interpolation) "gsl_spline_name" ((interpolation :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the interpolation type.") -(defun-gsl spline-minimum-size (interpolation) +(defmfun spline-minimum-size (interpolation) "gsl_spline_min_size" ((interpolation :pointer)) :c-return :uint - :documentation + :documentation ; FDL "The minimum number of points required by the interpolation. For example, Akima spline interpolation requires a minimum of 5 points.") diff --git a/linear-algebra/blas1.lisp b/linear-algebra/blas1.lisp index 37565bdc644649fed12f4b28f54985dd0141e214..4fe608defaf733b6fcf6dbb369151a544c3a1f4d 100644 --- a/linear-algebra/blas1.lisp +++ b/linear-algebra/blas1.lisp @@ -1,6 +1,6 @@ ;; BLAS level 1, Vector operations ;; Liam Healy, Wed Apr 26 2006 - 15:23 -;; Time-stamp: <2008-02-03 22:18:30EST blas1.lisp> +;; Time-stamp: <2008-02-17 10:24:18EST blas1.lisp> ;; $Id: $ (in-package :gsl) @@ -58,55 +58,55 @@ ;;;; Single ;;;;**************************************************************************** -(defun-gsl sdot (result alpha vec1 vec2) +(defmfun sdot (result alpha vec1 vec2) "gsl_blas_sdsdot" ((alpha :float) ((pointer vec1) :pointer) ((pointer vec2) :pointer) ((gsl-array result) :pointer)) :invalidate (result)) -(defun-gsl dot ((vec1 gsl-vector-single) (vec2 gsl-vector-single)) +(defmfun dot ((vec1 gsl-vector-single) (vec2 gsl-vector-single)) "gsl_blas_sdot" (((pointer vec1) :pointer) ((pointer vec2) :pointer) (result :float)) :type :method) -(defun-gsl norm ((vec gsl-vector-single)) +(defmfun norm ((vec gsl-vector-single)) "gsl_blas_snrm2" (((pointer vec) :pointer)) :type :method :c-return :float) -(defun-gsl asum ((vec gsl-vector-single)) +(defmfun asum ((vec gsl-vector-single)) "gsl_blas_sasum" (((pointer vec) :pointer)) :type :method :c-return :float) -(defun-gsl imax ((vec gsl-vector-single)) +(defmfun imax ((vec gsl-vector-single)) "gsl_blas_isamax" (((pointer vec) :pointer)) :type :method :c-return :int) -(defun-gsl blas-swap ((vec1 gsl-vector-single) (vec2 gsl-vector-single)) +(defmfun blas-swap ((vec1 gsl-vector-single) (vec2 gsl-vector-single)) "gsl_blas_sswap" (((pointer vec1) :pointer) ((pointer vec2) :pointer)) :type :method :invalidate (vec1 vec2)) -(defun-gsl blas-copy ((vec1 gsl-vector-single) (vec2 gsl-vector-single)) +(defmfun blas-copy ((vec1 gsl-vector-single) (vec2 gsl-vector-single)) "gsl_blas_scopy" (((pointer vec1) :pointer) ((pointer vec2) :pointer)) :type :method :invalidate (vec2)) -(defun-gsl axpy (alpha (vec1 gsl-vector-single) (vec2 gsl-vector-single)) +(defmfun axpy (alpha (vec1 gsl-vector-single) (vec2 gsl-vector-single)) "gsl_blas_saxpy" ((alpha :float) ((pointer vec1) :pointer) ((pointer vec2) :pointer)) :type :method :invalidate (vec2)) -(defun-gsl scal (alpha (vec gsl-vector-single)) +(defmfun scal (alpha (vec gsl-vector-single)) "gsl_blas_sscal" ((alpha :float) ((pointer vec) :pointer)) :type :method :invalidate (vec) :c-return :void) -(defun-gsl rot +(defmfun rot ((vec1 gsl-vector-single) (vec2 gsl-vector-single) (c float) (s float)) "gsl_blas_srot" @@ -118,49 +118,49 @@ ;;;; Double ;;;;**************************************************************************** -(defun-gsl dot ((vec1 gsl-vector-double) (vec2 gsl-vector-double)) +(defmfun dot ((vec1 gsl-vector-double) (vec2 gsl-vector-double)) "gsl_blas_ddot" (((pointer vec1) :pointer) ((pointer vec2) :pointer) (result :double)) :type :method) -(defun-gsl norm ((vec gsl-vector-double)) +(defmfun norm ((vec gsl-vector-double)) "gsl_blas_dnrm2" (((pointer vec) :pointer)) :type :method :c-return :double) -(defun-gsl asum ((vec gsl-vector-double)) +(defmfun asum ((vec gsl-vector-double)) "gsl_blas_dasum" (((pointer vec) :pointer)) :type :method :c-return :double) -(defun-gsl imax ((vec gsl-vector-double)) +(defmfun imax ((vec gsl-vector-double)) "gsl_blas_idamax" (((pointer vec) :pointer)) :type :method :c-return :int) -(defun-gsl blas-swap ((vec1 gsl-vector-double) (vec2 gsl-vector-double)) +(defmfun blas-swap ((vec1 gsl-vector-double) (vec2 gsl-vector-double)) "gsl_blas_dswap" (((pointer vec1) :pointer) ((pointer vec2) :pointer)) :type :method :invalidate (vec1 vec2)) -(defun-gsl blas-copy ((vec1 gsl-vector-double) (vec2 gsl-vector-double)) +(defmfun blas-copy ((vec1 gsl-vector-double) (vec2 gsl-vector-double)) "gsl_blas_dcopy" (((pointer vec1) :pointer) ((pointer vec2) :pointer)) :type :method :invalidate (vec2)) -(defun-gsl axpy (alpha (vec1 gsl-vector-double) (vec2 gsl-vector-double)) +(defmfun axpy (alpha (vec1 gsl-vector-double) (vec2 gsl-vector-double)) "gsl_blas_daxpy" ((alpha :double) ((pointer vec1) :pointer) ((pointer vec2) :pointer)) :type :method :invalidate (vec2)) -(defun-gsl scal (alpha (vec gsl-vector-double)) +(defmfun scal (alpha (vec gsl-vector-double)) "gsl_blas_dscal" ((alpha :double) ((pointer vec) :pointer)) :type :method :invalidate (vec) :c-return :void) -(defun-gsl rot +(defmfun rot ((vec1 gsl-vector-double) (vec2 gsl-vector-double) (c float) (s float)) "gsl_blas_drot" @@ -172,99 +172,158 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test blas1 - ;; single - (lisp-unit:assert-first-fp-equal - "0.260000000000e+02" - (letm ((a (vector-single #(1.0f0 2.0f0 3.0f0))) - (b (vector-single #(3.0f0 4.0f0 5.0f0)))) - (dot a b))) - (lisp-unit:assert-first-fp-equal - "0.707106770000e+01" - (letm ((b (vector-single #(3.0f0 4.0f0 5.0f0)))) - (norm b))) - (lisp-unit:assert-first-fp-equal - "0.120000000000e+02" - (letm ((b (vector-single #(3.0f0 4.0f0 5.0f0)))) - (asum b))) - (lisp-unit:assert-eql - 1 - (letm ((b (vector-single #(3.0f0 5.0f0 4.0f0)))) - (imax b))) - (lisp-unit:assert-equalp - '("0.500000000000e+01" "0.800000000000e+01" "0.110000000000e+02") - (lisp-unit:fp-sequence - (letm ((a (vector-single #(1.0f0 2.0f0 3.0f0))) - (b (vector-single #(3.0f0 4.0f0 5.0f0)))) - (setf (data a) #(1.0f0 2.0f0 3.0f0) - (data b) #(3.0f0 4.0f0 5.0f0)) - (axpy 2.0f0 a b) - (data b)))) - (lisp-unit:assert-equal - '("0.600000000000e+01" "0.800000000000e+01" "0.100000000000e+02") - (lisp-unit:fp-sequence - (letm ((b (vector-single #(3.0f0 4.0f0 5.0f0)))) - (setf (data b) #(3.0f0 4.0f0 5.0f0)) - (scal 2.0f0 b) - (data b)))) - (lisp-unit:assert-equal - '("0.494974760000e+01" "0.424264040000e+01") - (lisp-unit:fp-sequence - (letm ((a (vector-single #(1.0f0 3.0f0))) - (b (vector-single #(8.0f0 9.0f0)))) - (rot a b (/ (sqrt 2.0f0)) (/ (sqrt 2.0f0))) - (data b)))) - ;; double - (lisp-unit:assert-first-fp-equal - "0.260000000000d+02" - (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) - (b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (dot a b))) - (lisp-unit:assert-first-fp-equal - "0.707106781187d+01" - (letm ((b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (norm b))) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+02" - (letm ((b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (setf (data b) #(3.0d0 4.0d0 5.0d0)) - (asum b))) - (lisp-unit:assert-eql - 1 - (letm ((b (vector-double #(3.0d0 5.0d0 4.0d0)))) - (setf (data b) #(3.0d0 5.0d0 4.0d0)) - (imax b))) - (lisp-unit:assert-equalp - '("0.300000000000d+01" "0.400000000000d+01" "0.500000000000d+01") - (lisp-unit:fp-sequence - (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) - (b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (blas-swap a b) - (data a)))) - (lisp-unit:assert-equalp - '("0.300000000000d+01" "0.400000000000d+01" "0.500000000000d+01") - (lisp-unit:fp-sequence - (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) - (b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (blas-copy b a) - (data a)))) - (lisp-unit:assert-equalp - '("0.500000000000d+01" "0.800000000000d+01" "0.110000000000d+02") - (lisp-unit:fp-sequence - (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) - (b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (axpy 2.0d0 a b) - (data b)))) - (lisp-unit:assert-equal - '("0.600000000000d+01" "0.800000000000d+01" "0.100000000000d+02") - (lisp-unit:fp-sequence - (letm ((b (vector-double #(3.0d0 4.0d0 5.0d0)))) - (scal 2.0d0 b) - (data b)))) - (lisp-unit:assert-equal - '("0.494974746831d+01" "0.424264068712d+01") - (lisp-unit:fp-sequence - (letm ((a (vector-double #(1.0d0 3.0d0))) - (b (vector-double #(8.0d0 9.0d0)))) - (rot a b (/ (sqrt 2.0d0)) (/ (sqrt 2.0d0))) - (data b))))) +#| +(make-tests blas1 + ;; single + (letm ((a (vector-single #(1.0f0 2.0f0 3.0f0))) + (b (vector-single #(3.0f0 4.0f0 5.0f0)))) + (dot a b)) + (letm ((b (vector-single #(3.0f0 4.0f0 5.0f0)))) + (norm b)) + (letm ((b (vector-single #(3.0f0 4.0f0 5.0f0)))) + (asum b)) + (letm ((b (vector-single #(3.0f0 5.0f0 4.0f0)))) + (imax b)) + (letm ((a (vector-single #(1.0f0 2.0f0 3.0f0))) + (b (vector-single #(3.0f0 4.0f0 5.0f0)))) + (setf (data a) #(1.0f0 2.0f0 3.0f0) + (data b) #(3.0f0 4.0f0 5.0f0)) + (axpy 2.0f0 a b) + (data b)) + (letm ((b (vector-single #(3.0f0 4.0f0 5.0f0)))) + (setf (data b) #(3.0f0 4.0f0 5.0f0)) + (scal 2.0f0 b) + (data b)) + (letm ((a (vector-single #(1.0f0 3.0f0))) + (b (vector-single #(8.0f0 9.0f0)))) + (rot a b (/ (sqrt 2.0f0)) (/ (sqrt 2.0f0))) + (data b)) + ;; double + (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) + (b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (dot a b)) + (letm ((b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (norm b)) + (letm ((b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (setf (data b) #(3.0d0 4.0d0 5.0d0)) + (asum b)) + (letm ((b (vector-double #(3.0d0 5.0d0 4.0d0)))) + (setf (data b) #(3.0d0 5.0d0 4.0d0)) + (imax b)) + (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) + (b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (blas-swap a b) + (data a)) + (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) + (b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (blas-copy b a) + (data a)) + (letm ((a (vector-double #(1.0d0 2.0d0 3.0d0))) + (b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (axpy 2.0d0 a b) + (data b)) + (letm ((b (vector-double #(3.0d0 4.0d0 5.0d0)))) + (scal 2.0d0 b) + (data b)) + (letm ((a (vector-double #(1.0d0 3.0d0))) + (b (vector-double #(8.0d0 9.0d0)))) + (rot a b (/ (sqrt 2.0d0)) (/ (sqrt 2.0d0))) + (data b))) +|# + +(LISP-UNIT:DEFINE-TEST BLAS1 + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 26.0) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-SINGLE #(1.0 2.0 3.0))) + (B (VECTOR-SINGLE #(3.0 4.0 5.0)))) + (DOT A B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 7.071068) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-SINGLE #(3.0 4.0 5.0)))) + (NORM B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 12.0) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-SINGLE #(3.0 4.0 5.0)))) + (ASUM B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-SINGLE #(3.0 5.0 4.0)))) + (IMAX B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(5.0 8.0 11.0)) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-SINGLE #(1.0 2.0 3.0))) + (B (VECTOR-SINGLE #(3.0 4.0 5.0)))) + (SETF (DATA A) #(1.0 2.0 3.0) + (DATA B) #(3.0 4.0 5.0)) + (AXPY 2.0 A B) (DATA B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(6.0 8.0 10.0)) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-SINGLE #(3.0 4.0 5.0)))) + (SETF (DATA B) #(3.0 4.0 5.0)) (SCAL 2.0 B) + (DATA B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(4.9497476 4.2426405)) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-SINGLE #(1.0 3.0))) + (B (VECTOR-SINGLE #(8.0 9.0)))) + (ROT A B (/ (SQRT 2.0)) (/ (SQRT 2.0))) (DATA B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 26.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0))) + (B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (DOT A B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 7.0710678118654755d0) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (NORM B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 12.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (SETF (DATA B) #(3.0d0 4.0d0 5.0d0)) + (ASUM B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-DOUBLE #(3.0d0 5.0d0 4.0d0)))) + (SETF (DATA B) #(3.0d0 5.0d0 4.0d0)) + (IMAX B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(3.0d0 4.0d0 5.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0))) + (B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (BLAS-SWAP A B) (DATA A)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(3.0d0 4.0d0 5.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0))) + (B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (BLAS-COPY B A) (DATA A)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(5.0d0 8.0d0 11.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0))) + (B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (AXPY 2.0d0 A B) (DATA B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(6.0d0 8.0d0 10.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((B (VECTOR-DOUBLE #(3.0d0 4.0d0 5.0d0)))) + (SCAL 2.0d0 B) (DATA B)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(4.949747468305832d0 4.242640687119286d0)) + (MULTIPLE-VALUE-LIST + (LETM ((A (VECTOR-DOUBLE #(1.0d0 3.0d0))) + (B (VECTOR-DOUBLE #(8.0d0 9.0d0)))) + (ROT A B (/ (SQRT 2.0d0)) (/ (SQRT 2.0d0))) + (DATA B))))) + diff --git a/linear-algebra/blas2.lisp b/linear-algebra/blas2.lisp index 3b7b62de5b1d25f577bb545b32340ffd2fd49ae5..fd359ac3a3b82b52dff671570cebf5c80e59e56d 100644 --- a/linear-algebra/blas2.lisp +++ b/linear-algebra/blas2.lisp @@ -1,11 +1,7 @@ -;******************************************************** -; file: blas2.lisp -; description: BLAS level 2, Matrix-vector operations -; date: Wed Apr 26 2006 - 21:08 -; author: Liam M. Healy -; modified: Mon Jul 3 2006 - 23:47 -;******************************************************** -;;; $Id: $ +;; BLAS level 2, Matrix-vector operations +;; Liam Healy, Wed Apr 26 2006 - 21:08 +;; Time-stamp: <2008-02-17 10:36:36EST blas2.lisp> +;; $Id: $ (in-package :gsl) @@ -32,76 +28,82 @@ (export '(gemv trmv trsv symv ger syr syr2)) (defgeneric gemv (TransA alpha A x beta y) - (:documentation "The matrix-vector product and sum - y = \alpha op(A) x + \beta y, where op(A) = A, A^T, A^H - for TransA = :notrans, :trans, :conjtrans.") (:method :after (TransA alpha A x beta y) - (cl-invalidate y))) + (cl-invalidate y)) + (:documentation ; FDL + "The matrix-vector product and sum + y = alpha op(A) x + beta y, where op(A) = A, A^T, A^H + for TransA = :notrans, :trans, :conjtrans.")) (defgeneric trmv (uplo TransA diag A x) - (:documentation "The matrix-vector product x =\alpha op(A) x + (:method :after (uplo TransA diag A x) + (cl-invalidate x)) + (:documentation ; FDL + "The matrix-vector product x =\alpha op(A) x for the triangular matrix A, where op(A) = A, A^T, A^H for TransA = :NoTrans, :Trans, :ConjTrans. When Uplo is :Upper then the upper triangle of A is used, and when Uplo is :Lower then the lower triangle of A is used. If Diag is :NonUnit then the diagonal of the matrix is used, but if Diag is :Unit then the diagonal elements of the - matrix A are taken as unity and are not referenced.") - (:method :after (uplo TransA diag A x) - (cl-invalidate x))) + matrix A are taken as unity and are not referenced.")) (defgeneric trsv (uplo TransA diag A x) - (:documentation - "Compute inv(op(A)) x for x, where op(A) = A, A^T, A^H for - TransA = :NoTrans, :Trans, :ConjTrans. When Uplo is - :Upper then the upper triangle of A is used, and when Uplo is - :Lower then the lower triangle of A is used. If Diag is - :NonUnit then the diagonal of the matrix is used, but if Diag - is :Unit then the diagonal elements of the matrix A are taken - as unity and are not referenced.") (:method :after (uplo TransA diag A x) - (cl-invalidate x))) + (cl-invalidate x)) + (:documentation ; FDL + "Compute inv(op(A)) x for x, where op(A) = A, A^T, A^H for + TransA = :NoTrans, :Trans, :ConjTrans. When Uplo is + :Upper then the upper triangle of A is used, and when Uplo is + :Lower then the lower triangle of A is used. If Diag is + :NonUnit then the diagonal of the matrix is used, but if Diag + is :Unit then the diagonal elements of the matrix A are taken + as unity and are not referenced.")) (defgeneric symv (uplo alpha A x beta y) - (:documentation "The matrix-vector product and sum y = \alpha A - x + \beta y for the symmetric matrix A. Since the matrix A is + (:method :after (uplo alpha A x beta y) + (cl-invalidate y)) + (:documentation ; FDL + "The matrix-vector product and sum y = alpha A + x + beta y for the symmetric matrix A. Since the matrix A is symmetric only its upper half or lower half need to be stored. When Uplo is :Upper then the upper triangle and diagonal of A are used, and when Uplo is :Lower then the - lower triangle and diagonal of A are used.") - (:method :after (uplo alpha A x beta y) - (cl-invalidate y))) + lower triangle and diagonal of A are used.")) (defgeneric ger (alpha x y A) - (:documentation "The rank-1 update A = \alpha x y^T + A of the matrix A.") (:method :after (alpha x y A) - (cl-invalidate A))) + (cl-invalidate A)) + (:documentation ; FDL + "The rank-1 update A = alpha x y^T + A of the matrix A.")) (defgeneric syr (uplo alpha x A) - (:documentation "The symmetric rank-1 update A = \alpha x x^T + + (:method :after (uplo alpha x A) + (cl-invalidate A)) + (:documentation ; FDL + "The symmetric rank-1 update A = \alpha x x^T + A of the symmetric matrix A. Since the matrix A is symmetric only its upper half or lower half need to be stored. When Uplo is :Upper then the upper triangle and diagonal of A are used, and when Uplo is :Lower then the lower triangle and - diagonal of A are used.") - (:method :after (uplo alpha x A) - (cl-invalidate A))) + diagonal of A are used.")) (defgeneric syr2 (uplo alpha x y A) - (:documentation "The symmetric rank-2 update A = \alpha x y^T + - \alpha y x^T + A of the symmetric matrix A. Since the matrix A + (:method :after (uplo alpha x y A) + (cl-invalidate A)) + (:documentation ; FDL + "The symmetric rank-2 update A = \alpha x y^T + + alpha y x^T + A of the symmetric matrix A. Since the matrix A is symmetric only its upper half or lower half need to be stored. When Uplo is :Upper then the upper triangle and diagonal of A are used, and when Uplo is :Lower then the - lower triangle and diagonal of A are used.") - (:method :after (uplo alpha x y A) - (cl-invalidate A))) + lower triangle and diagonal of A are used.")) ;;;;**************************************************************************** ;;;; Single ;;;;**************************************************************************** -(defun-gsl gemv +(defmfun gemv (TransA alpha (A gsl-matrix-single) (x gsl-vector-single) beta (y gsl-vector-single)) "gsl_blas_sgemv" @@ -109,19 +111,19 @@ ((pointer x) gsl-vector-c) (beta :float) ((pointer y) gsl-vector-c)) :type :method) -(defun-gsl trmv (uplo transa diag (A gsl-matrix-single) (x gsl-vector-single)) +(defmfun trmv (uplo transa diag (A gsl-matrix-single) (x gsl-vector-single)) "gsl_blas_strmv" ((uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) ((pointer A) gsl-matrix-c) ((pointer x) gsl-vector-c)) :type :method) -(defun-gsl trsv (uplo transa diag (A gsl-matrix-single) (x gsl-vector-single)) +(defmfun trsv (uplo transa diag (A gsl-matrix-single) (x gsl-vector-single)) "gsl_blas_strsv" ((uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) ((pointer A) gsl-matrix-c) ((pointer x) gsl-vector-c)) :type :method) -(defun-gsl symv +(defmfun symv (uplo alpha (A gsl-matrix-single) (x gsl-vector-single) beta (y gsl-vector-single)) "gsl_blas_ssymv" @@ -129,20 +131,20 @@ ((pointer x) gsl-vector-c) (beta :float) ((pointer y) gsl-vector-c)) :type :method) -(defun-gsl ger +(defmfun ger (alpha (x gsl-vector-single) (y gsl-vector-single) (A gsl-matrix-single)) "gsl_blas_sger" ((alpha :float) ((pointer x) gsl-vector-c) ((pointer y) gsl-vector-c) ((pointer A) gsl-matrix-c)) :type :method) -(defun-gsl syr (uplo alpha (x gsl-vector-single) (A gsl-matrix-single)) +(defmfun syr (uplo alpha (x gsl-vector-single) (A gsl-matrix-single)) "gsl_blas_ssyr" ((uplo cblas-uplo) (alpha :float) ((pointer x) gsl-vector-c) ((pointer A) gsl-matrix-c)) :type :method) -(defun-gsl syr2 +(defmfun syr2 (uplo alpha (x gsl-vector-single) (y gsl-vector-single) (A gsl-matrix-single)) "gsl_blas_ssyr2" ((uplo cblas-uplo) (alpha :float) @@ -154,7 +156,7 @@ ;;;; Double ;;;;**************************************************************************** -(defun-gsl gemv +(defmfun gemv (TransA alpha (A gsl-matrix-double) (x gsl-vector-double) beta (y gsl-vector-double)) "gsl_blas_dgemv" @@ -162,19 +164,19 @@ ((pointer x) gsl-vector-c) (beta :double) ((pointer y) gsl-vector-c)) :type :method) -(defun-gsl trmv (uplo transa diag (A gsl-matrix-double) (x gsl-vector-double)) +(defmfun trmv (uplo transa diag (A gsl-matrix-double) (x gsl-vector-double)) "gsl_blas_dtrmv" ((uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) ((pointer A) gsl-matrix-c) ((pointer x) gsl-vector-c)) :type :method) -(defun-gsl trsv (uplo transa diag (A gsl-matrix-double) (x gsl-vector-double)) +(defmfun trsv (uplo transa diag (A gsl-matrix-double) (x gsl-vector-double)) "gsl_blas_dtrsv" ((uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) ((pointer A) gsl-matrix-c) ((pointer x) gsl-vector-c)) :type :method) -(defun-gsl symv +(defmfun symv (uplo alpha (A gsl-matrix-double) (x gsl-vector-double) beta (y gsl-vector-double)) "gsl_blas_dsymv" @@ -182,20 +184,20 @@ ((pointer x) gsl-vector-c) (beta :double) ((pointer y) gsl-vector-c)) :type :method) -(defun-gsl ger +(defmfun ger (alpha (x gsl-vector-double) (y gsl-vector-double) (A gsl-matrix-double)) "gsl_blas_dger" ((alpha :double) ((pointer x) gsl-vector-c) ((pointer y) gsl-vector-c) ((pointer A) gsl-matrix-c)) :type :method) -(defun-gsl syr (uplo alpha (x gsl-vector-double) (A gsl-matrix-double)) +(defmfun syr (uplo alpha (x gsl-vector-double) (A gsl-matrix-double)) "gsl_blas_dsyr" ((uplo cblas-uplo) (alpha :double) ((pointer x) gsl-vector-c) ((pointer A) gsl-matrix-c)) :type :method) -(defun-gsl syr2 +(defmfun syr2 (uplo alpha (x gsl-vector-double) (y gsl-vector-double) (A gsl-matrix-double)) "gsl_blas_dsyr2" ((uplo cblas-uplo) (alpha :double) diff --git a/linear-algebra/blas3.lisp b/linear-algebra/blas3.lisp index 70377e64d11d995f15f4bb5bf82b3ad7a2aef09b..d5bc547c61a8b7ef22d2036ebe1738e190265648 100644 --- a/linear-algebra/blas3.lisp +++ b/linear-algebra/blas3.lisp @@ -1,11 +1,7 @@ -;******************************************************** -; file: blas3.lisp -; description: BLAS level 3, Matrix-matrix operations -; date: Wed Apr 26 2006 - 21:08 -; author: Liam M. Healy -; modified: Mon Oct 8 2007 - 11:32 -;******************************************************** -;;; $Id: $ +;; BLAS level 3, Matrix-matrix operations +;; Liam Healy, Wed Apr 26 2006 - 21:08 +;; Time-stamp: <2008-02-17 10:39:56EST blas3.lisp> +;; $Id: $ (in-package :gsl) @@ -24,25 +20,30 @@ (export '(gemm symm trmm trsm syrk syr2k)) (defgeneric gemm (TransA TransB alpha A B beta C) - (:documentation "The matrix-matrix product and sum C = \alpha - op(A) op(B) + \beta C where op(A) = A, A^T, A^H for TransA = - :NoTrans, :Trans, :ConjTrans and similarly for the - parameter TransB.") (:method :after (TransA TransB alpha A B beta C) - (cl-invalidate C))) + (cl-invalidate C)) + (:documentation ; FDL + "The matrix-matrix product and sum C = alpha + op(A) op(B) + beta C where op(A) = A, A^T, A^H for TransA = + :NoTrans, :Trans, :ConjTrans and similarly for the + parameter TransB.")) (defgeneric symm (side uplo alpha A B beta C) - (:documentation "The matrix-matrix product and sum C = \alpha A - B + \beta C for Side is :Left and C = \alpha B A + \beta C + (:method :after (side uplo alpha A B beta C) + (cl-invalidate C)) + (:documentation ; FDL + "The matrix-matrix product and sum C = alpha A + B + beta C for Side is :Left and C = alpha B A + beta C for Side is :Right, where the matrix A is symmetric. When Uplo is :Upper then the upper triangle and diagonal of A are used, and when Uplo is :Lower then the lower triangle - and diagonal of A are used.") - (:method :after (side uplo alpha A B beta C) - (cl-invalidate C))) + and diagonal of A are used.")) (defgeneric trmm (side uplo TransA diag alpha A B) - (:documentation "The matrix-matrix product B = \alpha op(A) B + (:method :after (side uplo TransA diag alpha A B) + (cl-invalidate B)) + (:documentation ; FDL + "The matrix-matrix product B = \alpha op(A) B for Side is :Left and B = \alpha B op(A) for Side is :Right. The matrix A is triangular and op(A) = A, A^T, A^H for TransA = :NoTrans, :Trans, :ConjTrans When Uplo @@ -50,11 +51,11 @@ Uplo is :Lower then the lower triangle of A is used. If Diag is :NonUnit then the diagonal of A is used, but if Diag is :Unit then the diagonal elements of the matrix A - are taken as unity and are not referenced.") - (:method :after (side uplo TransA diag alpha A B) - (cl-invalidate B))) + are taken as unity and are not referenced.")) (defgeneric trsm (side uplo TransA diag alpha A B) + (:method :after (side uplo TransA diag alpha A B) + (cl-invalidate B)) (:documentation "The inverse-matrix matrix product B = \alpha op(inv(A))B for Side is :Left and B = \alpha B op(inv(A)) for Side is @@ -64,38 +65,36 @@ when Uplo is :Lower then the lower triangle of A is used. If Diag is :NonUnit then the diagonal of A is used, but if Diag is :Unit then the diagonal elements of the - matrix A are taken as unity and are not referenced.") - (:method :after (side uplo TransA diag alpha A B) - (cl-invalidate B))) + matrix A are taken as unity and are not referenced.")) (defgeneric syrk (uplo trans alpha A beta C) + (:method :after (uplo trans alpha A beta C) + (cl-invalidate C)) (:documentation "A rank-k update of the symmetric matrix C, C = - \alpha A A^T + \beta C when Trans is :NoTrans and C = - \alpha A^T A + \beta C when Trans is :Trans. Since the + alpha A A^T + beta C when Trans is :NoTrans and C = + alpha A^T A + beta C when Trans is :Trans. Since the matrix C is symmetric only its upper half or lower half need to be stored. When Uplo is :Upper then the upper triangle and diagonal of C are used, and when Uplo is :Lower then the - lower triangle and diagonal of C are used.") - (:method :after (uplo trans alpha A beta C) - (cl-invalidate C))) + lower triangle and diagonal of C are used.")) (defgeneric syr2k (uplo trans alpha A B beta C) + (:method :after (uplo trans alpha A B beta C) + (cl-invalidate C)) (:documentation "A rank-2k update of the symmetric matrix C, C - = \alpha A B^T + \alpha B A^T + \beta C when Trans is - :NoTrans and C = \alpha A^T B + \alpha B^T A + \beta C when + = alpha A B^T + alpha B A^T + beta C when Trans is + :NoTrans and C = alpha A^T B + alpha B^T A + \beta C when Trans is :Trans. Since the matrix C is symmetric only its upper half or lower half need to be stored. When Uplo is :Upper then the upper triangle and diagonal of C are used, and when Uplo is :Lower then the lower triangle and - diagonal of C are used.") - (:method :after (uplo trans alpha A B beta C) - (cl-invalidate C))) + diagonal of C are used.")) ;;;;**************************************************************************** ;;;; Single ;;;;**************************************************************************** -(defun-gsl gemm +(defmfun gemm (TransA TransB alpha (A gsl-matrix-single) (B gsl-matrix-single) beta (C gsl-matrix-single)) "gsl_blas_sgemm" @@ -104,7 +103,7 @@ (beta :float) ((pointer C) gsl-matrix-c)) :type :method) -(defun-gsl symm +(defmfun symm (side uplo alpha (A gsl-matrix-single) (B gsl-matrix-single) beta (C gsl-matrix-single)) "gsl_blas_ssymm" @@ -113,28 +112,28 @@ (beta :float) ((pointer C) gsl-matrix-c)) :type :method) -(defun-gsl trmm +(defmfun trmm (side uplo transa diag alpha (A gsl-matrix-single) (B gsl-matrix-single)) "gsl_blas_strmm" ((side cblas-side) (uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) (alpha :float) ((pointer A) gsl-matrix-c) ((pointer B) gsl-matrix-c)) :type :method) -(defun-gsl trsm +(defmfun trsm (side uplo transa diag alpha (A gsl-matrix-single) (B gsl-matrix-single)) "gsl_blas_strsm" ((side cblas-side) (uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) (alpha :float) ((pointer A) gsl-matrix-c) ((pointer B) gsl-matrix-c)) :type :method) -(defun-gsl syrk +(defmfun syrk (uplo trans alpha (A gsl-matrix-single) beta (C gsl-matrix-single)) "gsl_blas_ssyrk" ((uplo cblas-uplo) (trans cblas-transpose) (alpha :float) ((pointer A) gsl-matrix-c) (beta :float) ((pointer C) gsl-matrix-c)) :type :method) -(defun-gsl syr2k +(defmfun syr2k (uplo trans alpha (A gsl-matrix-single) (B gsl-matrix-single) beta (C gsl-matrix-single)) "gsl_blas_ssyr2k" @@ -147,7 +146,7 @@ ;;;; Double ;;;;**************************************************************************** -(defun-gsl gemm +(defmfun gemm (TransA TransB alpha (A gsl-matrix-double) (B gsl-matrix-double) beta (C gsl-matrix-double)) "gsl_blas_dgemm" @@ -156,7 +155,7 @@ (beta :double) (C gsl-matrix-c)) :type :method) -(defun-gsl symm +(defmfun symm (side uplo alpha (A gsl-matrix-double) (B gsl-matrix-double) beta (C gsl-matrix-double)) "gsl_blas_dsymm" @@ -165,28 +164,28 @@ (beta :double) ((pointer C) gsl-matrix-c)) :type :method) -(defun-gsl trmm +(defmfun trmm (side uplo transa diag alpha (A gsl-matrix-double) (B gsl-matrix-double)) "gsl_blas_dtrmm" ((side cblas-side) (uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) (alpha :double) ((pointer A) gsl-matrix-c) ((pointer B) gsl-matrix-c)) :type :method) -(defun-gsl trsm +(defmfun trsm (side uplo transa diag alpha (A gsl-matrix-double) (B gsl-matrix-double)) "gsl_blas_dtrsm" ((side cblas-side) (uplo cblas-uplo) (transa cblas-transpose) (diag cblas-diag) (alpha :double) ((pointer A) gsl-matrix-c) ((pointer B) gsl-matrix-c)) :type :method) -(defun-gsl syrk +(defmfun syrk (uplo trans alpha (A gsl-matrix-double) beta (C gsl-matrix-double)) "gsl_blas_dsyrk" ((uplo cblas-uplo) (trans cblas-transpose) (alpha :double) ((pointer A) gsl-matrix-c) (alpha :double) ((pointer C) gsl-matrix-c)) :type :method) -(defun-gsl syr2k +(defmfun syr2k (uplo trans (alpha float) (A gsl-matrix-double) (B gsl-matrix-double) beta (C gsl-matrix-double)) "gsl_blas_dsyr2k" diff --git a/linear-algebra/cholesky.lisp b/linear-algebra/cholesky.lisp index 44a4506faa894be71deb080b63d7d9088700be59..a13a7a13d2f97309d21a83bb6bf71c4543520ba4 100644 --- a/linear-algebra/cholesky.lisp +++ b/linear-algebra/cholesky.lisp @@ -1,52 +1,51 @@ -;******************************************************** -; file: cholesky.lisp -; description: Cholesky Decomposition -; date: Wed May 3 2006 - 16:38 -; author: Liam Healy -; modified: Mon Jul 3 2006 - 23:17 -;******************************************************** -;;; $Id: $ +;; Cholesky Decomposition +;; Liam Healy, Wed May 3 2006 - 16:38 +;; Time-stamp: <2008-02-17 10:43:34EST cholesky.lisp> +;; $Id: $ (in-package :gsl) -;;; A symmetric, positive definite square matrix @math{A} has a Cholesky -;;; decomposition into a product of a lower triangular matrix @math{L} and -;;; its transpose @math{L^T}, +;;; FDL +;;; A symmetric, positive definite square matrix A has a Cholesky +;;; decomposition into a product of a lower triangular matrix L and +;;; its transpose L^T, ;;; A = L L^T ;;; This is sometimes referred to as taking the square-root of a matrix. The ;;; Cholesky decomposition can only be carried out when all the eigenvalues ;;; of the matrix are positive. This decomposition can be used to convert -;;; the linear system @math{A x = b} into a pair of triangular systems -;;; (@math{L y = b}, @math{L^T x = y}), which can be solved by forward and +;;; the linear system A x = b into a pair of triangular systems +;;; (L y = b, L^T x = y), which can be solved by forward and ;;; back-substitution. -(defun-gsl cholesky-decomp (A) +(defmfun cholesky-decomp (A) "gsl_linalg_cholesky_decomp" (((pointer A) gsl-matrix-c)) - :documentation - "Factorize the positive-definite square matrix @var{A} - into the Cholesky decomposition @math{A = L L^T}. On output the diagonal - and lower triangular part of the input matrix @var{A} contain the matrix - @math{L}. The upper triangular part of the input matrix contains - @math{L^T}, the diagonal terms being identical for both @math{L} and - @math{L^T}. If the matrix is not positive-definite then the - decomposition will fail, returning the error code :EDOM." - :invalidate (A)) + :invalidate (A) + :documentation ; FDL + "Factorize the positive-definite square matrix A + into the Cholesky decomposition A = L L^T. On output the diagonal + and lower triangular part of the input matrix A contain the matrix + L. The upper triangular part of the input matrix contains + L^T, the diagonal terms being identical for both L and + L^T. If the matrix is not positive-definite then the + decomposition will fail, returning the error code :EDOM.") -(defun-gsl cholesky-solve (cholesky b x) +(defmfun cholesky-solve (cholesky b x) "gsl_linalg_cholesky_solve" (((pointer cholesky) gsl-matrix-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the system @math{A x = b} using the Cholesky - decomposition of @math{A} into the matrix @var{cholesky} given by - #'cholesky-decomp." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solve the system A x = b using the Cholesky + decomposition of A into the matrix cholesky given by + #'cholesky-decomp.") -(defun-gsl cholesky-svx (cholesky x) +(defmfun cholesky-svx (cholesky x) "gsl_linalg_cholesky_svx" (((pointer cholesky) gsl-matrix-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the system @math{A x = b} in-place using the - Cholesky decomposition of @math{A} into the matrix @var{cholesky} given - by @code{gsl_linalg_cholesky_decomp}. On input @var{x} should contain - the right-hand side @math{b}, which is replaced by the solution on - output." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solve the system A x = b in-place using the + Cholesky decomposition of A into the matrix cholesky given + by #'cholesky-decomp. On input x should contain + the right-hand side B, which is replaced by the solution on + output.") diff --git a/linear-algebra/diagonal.lisp b/linear-algebra/diagonal.lisp index 440796003a23ef7763e27090806853fccd506dc6..de7a71167d247e74a95cb217f5826a7c4b635d99 100644 --- a/linear-algebra/diagonal.lisp +++ b/linear-algebra/diagonal.lisp @@ -1,11 +1,7 @@ -;******************************************************** -; file: tridiagonal.lisp -; description: Tridiagonal and Bidiagonal matrices -; date: Thu May 4 2006 - 15:43 -; author: Liam Healy -; modified: Tue Jul 4 2006 - 00:00 -;******************************************************** -;;; $Id: $ +;; Tridiagonal and Bidiagonal matrices +;; Liam Healy, Thu May 4 2006 - 15:43 +;; Time-stamp: <2008-02-17 10:55:01EST diagonal.lisp> +;; $Id: $ (in-package :gsl) @@ -13,212 +9,229 @@ ;;;; Tridiagonal Decomposition of Real Symmetric Matrices ;;;;**************************************************************************** -;;; A symmetric matrix @math{A} can be factorized by similarity +;;; FDL +;;; A symmetric matrix A can be factorized by similarity ;;; transformations into the form ;;; A = Q T Q^T -;;; where @math{Q} is an orthogonal matrix and @math{T} is a symmetric +;;; where Q is an orthogonal matrix and T is a symmetric ;;; tridiagonal matrix. -(defun-gsl symmtd-decomp (A tau) +(defmfun symmtd-decomp (A tau) "gsl_linalg_symmtd_decomp" (((pointer A) gsl-matrix-c) ((pointer tau) gsl-vector-c)) - :documentation "Factorizes the symmetric square matrix @var{A} into the - symmetric tridiagonal decomposition @math{Q T Q^T}. On output the - diagonal and subdiagonal part of the input matrix @var{A} contain the - tridiagonal matrix @math{T}. The remaining lower triangular part of the + :invalidate (A tau) + :documentation ; FDL + "Factorizes the symmetric square matrix A into the + symmetric tridiagonal decomposition Q T Q^T. On output the + diagonal and subdiagonal part of the input matrix A contain the + tridiagonal matrix T. The remaining lower triangular part of the input matrix contains the Householder vectors which, together with the - Householder coefficients @var{tau}, encode the orthogonal matrix - @math{Q}. This storage scheme is the same as used by @sc{lapack}. The - upper triangular part of @var{A} is not referenced." - :invalidate (A tau)) + Householder coefficients tau, encode the orthogonal matrix + Q. This storage scheme is the same as used by lapack. The + upper triangular part of A is not referenced.") -(defun-gsl symmtd-unpack (A tau Q diag subdiag) +(defmfun symmtd-unpack (A tau Q diag subdiag) "gsl_linalg_symmtd_unpack" (((pointer A) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer Q) gsl-matrix-c) ((pointer diag) gsl-vector-c) ((pointer subdiag) gsl-vector-c)) - :documentation "Unpacks the encoded symmetric tridiagonal decomposition - (@var{A}, @var{tau}) obtained from #'symmtd-decomp into - the orthogonal matrix @var{Q}, the vector of diagonal elements @var{diag} - and the vector of subdiagonal elements @var{subdiag}." - :invalidate (Q diag subdiag)) - -(defun-gsl symmtd-unpack-T (A diag subdiag) + :invalidate (Q diag subdiag) + :documentation ; FDL + "Unpacks the encoded symmetric tridiagonal decomposition + (A, tau) obtained from #'symmtd-decomp into + the orthogonal matrix Q, the vector of diagonal elements diag + and the vector of subdiagonal elements subdiag.") + +(defmfun symmtd-unpack-T (A diag subdiag) "gsl_linalg_symmtd_unpack_T" (((pointer A) gsl-matrix-c) ((pointer diag) gsl-vector-c) ((pointer subdiag) gsl-vector-c)) - :documentation "Unpack the diagonal and subdiagonal of the encoded - symmetric tridiagonal decomposition (@var{A}, @var{tau}) obtained from - #'symmtd-decomp into the vectors @var{diag} and @var{subdiag}." - :invalidate (diag subdiag)) + :invalidate (diag subdiag) + :documentation ; FDL + "Unpack the diagonal and subdiagonal of the encoded + symmetric tridiagonal decomposition (A, tau) obtained from + #'symmtd-decomp into the vectors diag and subdiag.") ;;;;**************************************************************************** ;;;; Tridiagonal Decomposition of Hermitian Matrices ;;;;**************************************************************************** -;;; A hermitian matrix @math{A} can be factorized by similarity +;;; FDL +;;; A hermitian matrix A can be factorized by similarity ;;; transformations into the form -;;; A = U T U^T where @math{U} is a unitary -;;; matrix and @math{T} is a real symmetric tridiagonal matrix. +;;; A = U T U^T where U is a unitary +;;; matrix and T is a real symmetric tridiagonal matrix. -(defun-gsl hermitian-decomp (A tau) +(defmfun hermitian-decomp (A tau) "gsl_linalg_hermtd_decomp" (((pointer A) gsl-matrix-c) ((pointer tau) gsl-vector-c)) - :documentation "This function factorizes the hermitian matrix @var{A} - into the symmetric tridiagonal decomposition @math{U T U^T}. + :invalidate (A tau) + :documentation ; FDL + "This function factorizes the hermitian matrix A + into the symmetric tridiagonal decomposition U T U^T. On output the real parts of - the diagonal and subdiagonal part of the input matrix @var{A} contain - the tridiagonal matrix @math{T}. The remaining lower triangular part of + the diagonal and subdiagonal part of the input matrix A contain + the tridiagonal matrix T. The remaining lower triangular part of the input matrix contains the Householder vectors which, together with - the Householder coefficients @var{tau}, encode the orthogonal matrix - @math{Q}. This storage scheme is the same as used by @sc{lapack}. The - upper triangular part of @var{A} and imaginary parts of the diagonal are - not referenced." - :invalidate (A tau)) + the Householder coefficients tau, encode the orthogonal matrix + Q. This storage scheme is the same as used by lapack. The + upper triangular part of A and imaginary parts of the diagonal are + not referenced.") ;;; GSL doc or arglist incorrect? Q->U -(defun-gsl hermitian-unpack (A tau U diag subdiag) +(defmfun hermitian-unpack (A tau U diag subdiag) "gsl_linalg_hermtd_unpack" (((pointer A) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer U) gsl-matrix-c) ((pointer diag) gsl-vector-c) ((pointer subdiag) gsl-vector-c)) - :documentation "Unpacks the encoded tridiagonal decomposition (@var{A}, - @var{tau}) obtained from hermitian-decomp into the - unitary matrix @var{U}, the real vector of diagonal elements @var{diag} and - the real vector of subdiagonal elements @var{subdiag}. " - :invalidate (U diag subdiag)) - -(defun-gsl hermitian-unpack-T (A diag subdiag) + :invalidate (U diag subdiag) + :documentation ; FDL + "Unpacks the encoded tridiagonal decomposition (A, tau) + obtained from hermitian-decomp into the + unitary matrix U, the real vector of diagonal elements diag and + the real vector of subdiagonal elements subdiag. ") + +(defmfun hermitian-unpack-T (A diag subdiag) "gsl_linalg_hermtd_unpack_T" (((pointer A) gsl-matrix-c) ((pointer diag) gsl-vector-c) ((pointer subdiag) gsl-vector-c)) - :documentation "Unpack the diagonal and subdiagonal of the encoded - tridiagonal decomposition (@var{A}, @var{tau}) obtained from the - hermitian-decomp into the real vectors @var{diag} and @var{subdiag}." - :invalidate (diag subdiag)) + :invalidate (diag subdiag) + :documentation ; FDL + "Unpack the diagonal and subdiagonal of the encoded + tridiagonal decomposition (A, tau) obtained from the + hermitian-decomp into the real vectors diag and subdiag.") ;;;;**************************************************************************** ;;;; Bidiagonal ;;;;**************************************************************************** -;;; A general matrix @math{A} can be factorized by similarity +;;; FDL +;;; A general matrix A can be factorized by similarity ;;; transformations into the form A = U B V^T -;;; where @math{U} and @math{V} are orthogonal matrices and @math{B} is a -;;; @math{N}-by-@math{N} bidiagonal matrix with non-zero entries only on the -;;; diagonal and superdiagonal. The size of @var{U} is @math{M}-by-@math{N} -;;; and the size of @var{V} is @math{N}-by-@math{N}. +;;; where U and V are orthogonal matrices and B is a +;;; N-by-N bidiagonal matrix with non-zero entries only on the +;;; diagonal and superdiagonal. The size of U is M-by-N +;;; and the size of V is N-by-N. -(defun-gsl bidiagonal-decomp (A tau-U tau-V) +(defmfun bidiagonal-decomp (A tau-U tau-V) "gsl_linalg_bidiag_decomp" (((pointer A) gsl-matrix-c) ((pointer tau-U) gsl-vector-c) ((pointer tau-V) gsl-vector-c)) - :documentation "Factorize the @math{M}-by-@math{N} matrix @var{A} into - bidiagonal form @math{U B V^T}. The diagonal and superdiagonal of the - matrix @math{B} are stored in the diagonal and superdiagonal of @var{A}. - The orthogonal matrices @math{U} and @var{V} are stored as compressed - Householder vectors in the remaining elements of @var{A}. The - Householder coefficients are stored in the vectors @var{tau_U} and - @var{tau_V}. The length of @var{tau_U} must equal the number of - elements in the diagonal of @var{A} and the length of @var{tau_V} should - be one element shorter." - :invalidate (A tau-U tau-V)) - -(defun-gsl bidiagonal-unpack (A tau-U U tau-V V diag subdiag) + :invalidate (A tau-U tau-V) + :documentation ; FDL + "Factorize the M-by-N matrix A into + bidiagonal form U B V^T. The diagonal and superdiagonal of the + matrix B are stored in the diagonal and superdiagonal of A, + The orthogonal matrices U and V are stored as compressed + Householder vectors in the remaining elements of A. The + Householder coefficients are stored in the vectors tau-U and + tau-V. The length of tau-U must equal the number of + elements in the diagonal of A and the length of tau-V should + be one element shorter.") + +(defmfun bidiagonal-unpack (A tau-U U tau-V V diag subdiag) "gsl_linalg_bidiag_unpack" (((pointer A) gsl-matrix-c) ((pointer tau-U) gsl-vector-c) ((pointer U) gsl-matrix-c) ((pointer tau-V) gsl-vector-c) ((pointer V) gsl-matrix-c) ((pointer diag) gsl-vector-c) ((pointer subdiag) gsl-vector-c)) - :documentation "Unpack the bidiagonal decomposition of @var{A} given by - #'bidiagonal-decomp (@var{A}, @var{tau_U}, @var{tau_V}) - into the separate orthogonal matrices @var{U}, @var{V} and the diagonal - vector @var{diag} and superdiagonal @var{superdiag}. Note that @var{U} - is stored as a compact @math{M}-by-@math{N} orthogonal matrix satisfying - @math{U^T U = I} for efficiency." - :invalidate (U V diag subdiag)) + :invalidate (U V diag subdiag) + :documentation ; FDL + "Unpack the bidiagonal decomposition of A given by + #'bidiagonal-decomp (A, tau-U, tau-V) + into the separate orthogonal matrices U, V, and the diagonal + vector diag and superdiagonal superdiag. Note that U + is stored as a compact M-by-N orthogonal matrix satisfying + U^T U = I for efficiency.") ;;; There is no 'diag and 'superdiag given for arguments to this function -(defun-gsl bidiagonal-unpack2 (A tau-U tau-V V) +(defmfun bidiagonal-unpack2 (A tau-U tau-V V) "gsl_linalg_bidiag_unpack2" (((pointer A) gsl-matrix-c) ((pointer tau-U) gsl-vector-c) ((pointer tau-V) gsl-vector-c) ((pointer V) gsl-matrix-c)) - :documentation "Unpack the bidiagonal decomposition of @var{A} given by - #'bidiagonal-decomp (@var{A}, @var{tau_U}, @var{tau_V}) - into the separate orthogonal matrices @var{U}, @var{V} and the diagonal - vector @var{diag} and superdiagonal @var{superdiag}. The matrix @var{U} - is stored in-place in @var{A}." - :invalidate (A V)) - -(defun-gsl bidiagonal-unpack-B (A diag superdiag) + :invalidate (A V) + :documentation ; FDL + "Unpack the bidiagonal decomposition of A given by + #'bidiagonal-decomp (A, tau-U, tau-V) + into the separate orthogonal matrices U, V and the diagonal + vector diag and superdiagonal superdiag. The matrix U + is stored in-place in A.") + +(defmfun bidiagonal-unpack-B (A diag superdiag) "gsl_linalg_bidiag_unpack_B" (((pointer A) gsl-matrix-c) ((pointer diag) gsl-vector-c) ((pointer superdiag) gsl-vector-c)) - :documentation "Unpack the diagonal and superdiagonal of the bidiagonal - decomposition of @var{A} given by #'bidiagonal-decomp, into the diagonal - vector @var{diag} and superdiagonal vector @var{superdiag}." + :documentation ; FDL + "Unpack the diagonal and superdiagonal of the bidiagonal + decomposition of A given by #'bidiagonal-decomp, into the diagonal + vector diag and superdiagonal vector superdiag." :invalidate (diag superdiag)) ;;;;**************************************************************************** ;;;; Tridiagonal Systems ;;;;**************************************************************************** -(defun-gsl solve-tridiagonal (diag e f b x) +(defmfun solve-tridiagonal (diag e f b x) "gsl_linalg_solve_tridiag" (((pointer diag) gsl-vector-c) ((pointer e) gsl-vector-c) ((pointer f) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the general @math{N}-by-@math{N} system @math{A x = - b} where @var{A} is tridiagonal (@math{N >= 2}). The super-diagonal and - sub-diagonal vectors @var{e} and @var{f} must be one element shorter - than the diagonal vector @var{diag}. The form of @var{A} for the 4-by-4 + :invalidate (x) + :documentation ; FDL + "Solve the general N-by-N system A x = b where A is tridiagonal + (N >= 2). The super-diagonal and + sub-diagonal vectors e and f must be one element shorter + than the diagonal vector diag. The form of A for the 4-by-4 case is A = ( d_0 e_0 0 0 ) ( f_0 d_1 e_1 0 ) ( 0 f_1 d_2 e_2 ) - ( 0 0 f_2 d_3 )." - :invalidate (x)) + ( 0 0 f_2 d_3 ).") -(defun-gsl solve-symmetric-tridiagonal (diag e b x) +(defmfun solve-symmetric-tridiagonal (diag e b x) "gsl_linalg_solve_symm_tridiag" (((pointer diag) gsl-vector-c) ((pointer e) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the general @math{N}-by-@math{N} system @math{A x = - b} where @var{A} is symmetric tridiagonal (@math{N >= 2}). The off-diagonal vector - @var{e} must be one element shorter than the diagonal vector @var{diag}. - The form of @var{A} for the 4-by-4 case is + :invalidate (x) + :documentation ; FDL + "Solve the general N-by-N system A x = b where A is + symmetric tridiagonal (N >= 2). The off-diagonal vector + e must be one element shorter than the diagonal vector diag. + The form of A for the 4-by-4 case is A = ( d_0 e_0 0 0 ) ( e_0 d_1 e_1 0 ) ( 0 e_1 d_2 e_2 ) - ( 0 0 e_2 d_3 )." - :invalidate (x)) + ( 0 0 e_2 d_3 ).") -(defun-gsl solve-cyclic-tridiagonal (diag e f b x) +(defmfun solve-cyclic-tridiagonal (diag e f b x) "gsl_linalg_solve_cyc_tridiag" (((pointer diag) gsl-vector-c) ((pointer e) gsl-vector-c) ((pointer f) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the general @math{N}-by-@math{N} system @math{A x = - b} where @var{A} is cyclic tridiagonal (@math{N >= 3}). The cyclic super-diagonal and - sub-diagonal vectors @var{e} and @var{f} must have the same number of - elements as the diagonal vector @var{diag}. The form of @var{A} for the + :invalidate (x) + :documentation ; FDL + "Solve the general N-by-N system A x = b where A is cyclic + tridiagonal (N >= 3). The cyclic super-diagonal and + sub-diagonal vectors e and f must have the same number of + elements as the diagonal vector diag. The form of A for the 4-by-4 case is A = ( d_0 e_0 0 f_3 ) ( f_0 d_1 e_1 0 ) ( 0 f_1 d_2 e_2 ) - ( e_3 0 f_2 d_3 )." - :invalidate (x)) + ( e_3 0 f_2 d_3 ).") -(defun-gsl solve-symmetric-cyclic-tridiagonal (diag e b x) +(defmfun solve-symmetric-cyclic-tridiagonal (diag e b x) "gsl_linalg_solve_symm_cyc_tridiag" (((pointer diag) gsl-vector-c) ((pointer e) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the general @math{N}-by-@math{N} system @math{A x = - b} where @var{A} is symmetric cyclic tridiagonal (@math{N >= 3}). The cyclic - off-diagonal vector @var{e} must have the same number of elements as the - diagonal vector @var{diag}. The form of @var{A} for the 4-by-4 case is - shown below, + :invalidate (x) + :documentation ; FDL + "Solve the general N-by-N system A x = b where A is symmetric + cyclic tridiagonal (N >= 3). The cyclic + off-diagonal vector e must have the same number of elements as the + diagonal vector diag. The form of A for the 4-by-4 case is + shown below, A = ( d_0 e_0 0 e_3 ) ( e_0 d_1 e_1 0 ) ( 0 e_1 d_2 e_2 ) - ( e_3 0 e_2 d_3 )" - :invalidate (x)) + ( e_3 0 e_2 d_3 )") diff --git a/linear-algebra/householder.lisp b/linear-algebra/householder.lisp index b80e55725b0733fb535f48a1566708de954412cb..d864d47bcc2fde73e3d8292e09ad233fe289d4b6 100644 --- a/linear-algebra/householder.lisp +++ b/linear-algebra/householder.lisp @@ -1,11 +1,7 @@ -;******************************************************** -; file: householder.lisp -; description: Householder Transformations -; date: Wed May 10 2006 - 10:03 -; author: Liam Healy -; modified: Mon Jul 3 2006 - 23:41 -;******************************************************** -;;; $Id: $ +;; Householder Transformations +;; Liam Healy, Wed May 10 2006 - 10:03 +;; Time-stamp: <2008-02-17 11:00:45EST householder.lisp> +;; $Id: $ ;;; For householder-transform, it would be nice to be able to pick the ;;; order of arguments returned (reverse). @@ -16,71 +12,78 @@ ;;;; Householder transformations ;;;;**************************************************************************** +;;; FDL ;;; A Householder transformation is a rank-1 modification of the identity ;;; matrix which can be used to zero out selected elements of a vector. A -;;; Householder matrix @math{P} takes the form, -;;; P = I - \tau v v^T -;;; where @math{v} is a vector (called the @dfn{Householder vector}) and -;;; @math{\tau = 2/(v^T v)}. The functions described in this section use the +;;; Householder matrix P takes the form, +;;; P = I - tau v v^T +;;; where v is a vector (called the Householder vector) and +;;; tau = 2/(v^T v). The functions described in this section use the ;;; rank-1 structure of the Householder matrix to create and apply ;;; Householder transformations efficiently. -(defun-gsl householder-transform (v) +(defmfun householder-transform (v) "gsl_linalg_householder_transform" (((pointer v) gsl-vector-c)) - :documentation "Prepare a Householder transformation @math{P = I - \tau v - v^T} which can be used to zero all the elements of the input vector except - the first. Returned values are the transformation, which is stored - in the vector @var{v}, and the scalar @math{\tau}." :invalidate (v) :c-return (ret :double) - :return (v ret)) + :return (v ret) + :documentation ; FDL + "Prepare a Householder transformation P = I - tau v v^T + which can be used to zero all the elements of the input vector except + the first. Returned values are the transformation, which is stored + in the vector v, and the scalar tau.") -(defun-gsl householder-HM (tau v A) +(defmfun householder-HM (tau v A) "gsl_linalg_householder_hm" ((tau :double) ((pointer v) gsl-vector-c) ((pointer A) gsl-matrix-c)) - :documentation "Apply the Householder matrix @math{P} defined by the - scalar @var{tau} and the vector @var{v} to the left-hand side of the - matrix @var{A}. On output the result @math{P A} is stored in @var{A}." - :invalidate (A)) + :invalidate (A) + :documentation ; FDL + "Apply the Householder matrix P defined by the + scalar tau and the vector v to the left-hand side of the + matrix A. On output the result P A is stored in A.") -(defun-gsl householder-MH (tau v A) +(defmfun householder-MH (tau v A) "gsl_linalg_householder_mh" ((tau :double) ((pointer v) gsl-vector-c) ((pointer A) gsl-matrix-c)) - :documentation "Apply the Householder matrix @math{P} defined by the - scalar @var{tau} and the vector @var{v} to the right-hand side of the - matrix @var{A}. On output the result @math{A P} is stored in @var{A}." - :invalidate (A)) + :invalidate (A) + :documentation ; FDL + "Apply the Householder matrix P defined by the + scalar tau and the vector v to the right-hand side of the + matrix A. On output the result A P is stored in A.") -(defun-gsl householder-Hv (tau v w) +(defmfun householder-Hv (tau v w) "gsl_linalg_householder_hv" ((tau :double) ((pointer v) gsl-vector-c) ((pointer w) gsl-vector-c)) - :documentation "Apply the Householder transformation @math{P} defined by - the scalar @var{tau} and the vector @var{v} to the vector @var{w}. On - output the result @math{P w} is stored in @var{w}." + :documentation ; FDL + "Apply the Householder transformation P defined by + the scalar tau and the vector v to the vector w. On + output the result P w is stored in w." :invalidate (w)) ;;;;**************************************************************************** ;;;; Householder solver for linear systems ;;;;**************************************************************************** -(defun-gsl householder-solve (A b x) +(defmfun householder-solve (A b x) "gsl_linalg_HH_solve" (((pointer A) gsl-matrix-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the system @math{A x = b} directly using - Householder transformations. On output the solution is stored in @var{x} - and @var{b} is not modified. The matrix @var{A} is destroyed by the - Householder transformations." :invalidate (x A) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the system A x = b directly using + Householder transformations. On output the solution is stored in x + and b is not modified. The matrix A is destroyed by the + Householder transformations.") -(defun-gsl householder-svx (A x) +(defmfun householder-svx (A x) "gsl_linalg_HH_svx" (((pointer A) gsl-matrix-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the system @math{A x = b} in-place using - Householder transformations. On input @var{x} should contain the - right-hand side @math{b}, which is replaced by the solution on output. The - matrix @var{A} is destroyed by the Householder transformations." :invalidate (x A) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the system A x = b in-place using + Householder transformations. On input x should contain the + right-hand side b, which is replaced by the solution on output. The + matrix A is destroyed by the Householder transformations.") diff --git a/linear-algebra/lu.lisp b/linear-algebra/lu.lisp index 70a80b5f5fab736ff71016d1664675f50a03fbef..6f6e036817120e72c1414b807267e8179105d0c3 100644 --- a/linear-algebra/lu.lisp +++ b/linear-algebra/lu.lisp @@ -1,109 +1,114 @@ -;******************************************************** -; file: lu.lisp -; description: LU decomposition -; date: Thu Apr 27 2006 - 12:42 -; author: Liam Healy -; modified: Mon Jul 3 2006 - 23:32 -;******************************************************** -;;; $Id: $ +;; LU decomposition +;; Liam Healy, Thu Apr 27 2006 - 12:42 +;; Time-stamp: <2008-02-17 11:05:06EST lu.lisp> +;; $Id: $ (in-package :gsl) ;;; Not ported: those functions that use complex vectors or matrices -(defun-gsl LU-decomp (A p signum) +(defmfun LU-decomp (A p signum) "gsl_linalg_LU_decomp" (((pointer A) gsl-matrix-c) ((pointer p) gsl-permutation-c) (signum :int)) - :documentation "Factorize the square matrix @var{A} into the @math{LU} - decomposition @math{PA = LU}. On output the diagonal and upper - triangular part of the input matrix @var{A} contain the matrix - @math{U}. The lower triangular part of the input matrix (excluding the - diagonal) contains @math{L}. The diagonal elements of @math{L} are + :invalidate (A p) + :documentation ; FDL + "Factorize the square matrix A into the LU + decomposition PA = LU. On output the diagonal and upper + triangular part of the input matrix A contain the matrix + U. The lower triangular part of the input matrix (excluding the + diagonal) contains L. The diagonal elements of L are unity, and are not stored. - The permutation matrix @math{P} is encoded in the permutation - @var{p}. The @math{j}-th column of the matrix @math{P} is given by the - @math{k}-th column of the identity matrix, where @math{k = p_j} the - @math{j}-th element of the permutation vector. The sign of the - permutation is given by @var{signum}. It has the value @math{(-1)^n}, - where @math{n} is the number of interchanges in the permutation. + The permutation matrix P is encoded in the permutation + p. The j-th column of the matrix P is given by the + k-th column of the identity matrix, where k = p_j the + j-th element of the permutation vector. The sign of the + permutation is given by signum. It has the value (-1)^n, + where n is the number of interchanges in the permutation. The algorithm used in the decomposition is Gaussian Elimination with - partial pivoting (Golub & Van Loan, @cite{Matrix Computations}, - Algorithm 3.4.1)." - :invalidate (A p)) + partial pivoting (Golub & Van Loan, Matrix Computations, + Algorithm 3.4.1).") -(defun-gsl LU-solve (LU p b x) +(defmfun LU-solve (LU p b x) "gsl_linalg_LU_solve" (((pointer LU) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the square system @math{A x = b} using the @math{LU} - decomposition of @math{A} into (@var{LU}, @var{p}) given by - LU-decomp." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solve the square system A x = b using the LU + decomposition of A into (LU, p) given by LU-decomp.") -(defun-gsl LU-svx (LU p x) +(defmfun LU-svx (LU p x) "gsl_linalg_LU_svx" (((pointer LU) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the square system @math{A x = b} in-place - using the @math{LU} decomposition of @math{A} into - (@var{LU},@var{p}). On input @var{x} should contain the right-hand - side @math{b}, which is replaced by the solution on output." - :invalidate (x)) + :invalidate (x) + :documentation ; FLD + "Solve the square system A x = b in-place + using the LU decomposition of A into + (LU, p). On input x should contain the right-hand + side b, which is replaced by the solution on output.") -(defun-gsl LU-refine (A LU p b x residual) +(defmfun LU-refine (A LU p b x residual) "gsl_linalg_LU_refine" (((pointer A) gsl-matrix-c) ((pointer LU) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c) ((pointer residual) gsl-vector-c)) - :documentation "Apply an iterative improvement to x, the solution of + :invalidate (x residual) + :documentation ; FDL + "Apply an iterative improvement to x, the solution of A x = b, using the LU decomposition of A into (LU,p). The initial - residual r = A x - b is also computed and stored in residual. " - :invalidate (x residual)) + residual r = A x - b is also computed and stored in residual. ") -(defun-gsl LU-invert (LU p inverse) +(defmfun LU-invert (LU p inverse) "gsl_linalg_LU_invert" (((pointer LU) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer inverse) gsl-matrix-c)) - :documentation "Compute the inverse of a matrix A from its LU + :invalidate (inverse) + :documentation ; FDL + "Compute the inverse of a matrix A from its LU decomposition (LU,p), storing the result in the matrix inverse. The inverse is computed by solving the system A x = b for each column of the identity matrix. It is preferable to avoid direct use of the inverse whenever possible, as the linear solver functions can obtain the same result more efficiently and reliably (consult any - introductory textbook on numerical linear algebra for details)." - :invalidate (inverse)) + introductory textbook on numerical linear algebra for details).") (defgeneric LU-det (LU signum) - (:documentation "Compute the determinant of a matrix A from its LU + (:documentation ; FDL + "Compute the determinant of a matrix A from its LU decomposition, LU. The determinant is computed as the product of the diagonal elements of U and the sign of the row permutation signum.")) -(defun-gsl LU-det ((LU gsl-matrix-double) signum) - "gsl_linalg_LU_det" (((pointer LU) gsl-matrix-c) (signum :int)) +(defmfun LU-det ((LU gsl-matrix-double) signum) + "gsl_linalg_LU_det" + (((pointer LU) gsl-matrix-c) (signum :int)) :type :method :c-return :double) -(defun-gsl LU-det ((LU gsl-matrix-complex) signum) - "gsl_linalg_complex_LU_det" (((pointer LU) gsl-matrix-c) (signum :int)) +(defmfun LU-det ((LU gsl-matrix-complex) signum) + "gsl_linalg_complex_LU_det" + (((pointer LU) gsl-matrix-c) (signum :int)) :type :method :c-return (ret gsl-complex) :return ((complex-to-cl ret))) -(defun-gsl LU-lndet (LU) - "gsl_linalg_LU_lndet" (((pointer LU) gsl-matrix-c)) - :documentation "The logarithm of the absolute value of the - determinant of a matrix A, \ln|\det(A)|, from its LU decomposition, +(defmfun LU-lndet (LU) + "gsl_linalg_LU_lndet" + (((pointer LU) gsl-matrix-c)) + :c-return :double + :documentation ; FDL + "The logarithm of the absolute value of the + determinant of a matrix A, ln|det(A)|, from its LU decomposition, LU. This function may be useful if the direct computation of the - determinant would overflow or underflow." - :c-return :double) + determinant would overflow or underflow.") -(defun-gsl LU-sgndet (LU signum) +(defmfun LU-sgndet (LU signum) "gsl_linalg_LU_sgndet" (((pointer LU) gsl-matrix-c) (signum :int)) - :documentation + :c-return :int + :documentation ; FDL "Compute the sign or phase factor of the determinant of a matrix A, - \det(A)/|\det(A)|, from its LU decomposition, LU." - :c-return :int) + det(A)/|det(A)|, from its LU decomposition, LU.") diff --git a/linear-algebra/qr.lisp b/linear-algebra/qr.lisp index 845ce70bdda49d04830cca07b6c674810a138e37..83d10de0f575efc9b441291f605a526396c4da5b 100644 --- a/linear-algebra/qr.lisp +++ b/linear-algebra/qr.lisp @@ -1,164 +1,170 @@ -;******************************************************** -; file: qr.lisp -; description: QR decomposition -; date: Fri Apr 28 2006 - 16:53 -; author: Liam Healy -; modified: Mon Jul 3 2006 - 23:29 -;******************************************************** -;;; $Id: $ +;; QR decomposition +;; Liam Healy 2008-02-17 11:05:20EST qr.lisp +;; Time-stamp: <2008-02-17 11:17:37EST qr.lisp> +;; $Id: $ (in-package :gsl) -;;; A general rectangular @math{M}-by-@math{N} matrix @math{A} has a -;;; @math{QR} decomposition into the product of an orthogonal -;;; @math{M}-by-@math{M} square matrix @math{Q} (where @math{Q^T Q = I}) and -;;; an @math{M}-by-@math{N} right-triangular matrix @math{R}, -;;; A = Q R +;;; FDL +;;; A general rectangular M-by-N matrix A has a +;;; QR decomposition into the product of an orthogonal +;;; M-by-M square matrix Q (where Q^T Q = I) and +;;; an M-by-N right-triangular matrix R, A = Q R. -;;; This decomposition can be used to convert the linear system @math{A x = -;;; b} into the triangular system @math{R x = Q^T b}, which can be solved by -;;; back-substitution. Another use of the @math{QR} decomposition is to -;;; compute an orthonormal basis for a set of vectors. The first @math{N} -;;; columns of @math{Q} form an orthonormal basis for the range of @math{A}, -;;; @math{ran(A)}, when @math{A} has full column rank. +;;; This decomposition can be used to convert the linear system A x = b +;;; into the triangular system R x = Q^T b, which can be solved by +;;; back-substitution. Another use of the QR decomposition is to +;;; compute an orthonormal basis for a set of vectors. The first N +;;; columns of Q form an orthonormal basis for the range of A, +;;; ran(A), when A has full column rank. -(defun-gsl QR-decomp (A tau) +(defmfun QR-decomp (A tau) "gsl_linalg_QR_decomp" (((pointer A) gsl-matrix-c) ((pointer tau) gsl-vector-c)) - :documentation "Factorize the @math{M}-by-@math{N} matrix @var{A} into - the @math{QR} decomposition @math{A = Q R}. On output the diagonal and + :invalidate (A tau) + :documentation ; FDL + "Factorize the M-by-N matrix A into the QR decomposition A = Q R. + On output the diagonal and upper triangular part of the input matrix contain the matrix - @math{R}. The vector @var{tau} and the columns of the lower triangular - part of the matrix @var{A} contain the Householder coefficients and - Householder vectors which encode the orthogonal matrix @var{Q}. The - vector @var{tau} must be of length @math{k=\min(M,N)}. The matrix - @math{Q} is related to these components by, @math{Q = Q_k ... Q_2 Q_1} - where @math{Q_i = I - \tau_i v_i v_i^T} and @math{v_i} is the - Householder vector @math{v_i = - (0,...,1,A(i+1,i),A(i+2,i),...,A(m,i))}. This is the same storage scheme - as used by @sc{lapack}. + R. The vector tau and the columns of the lower triangular + part of the matrix A contain the Householder coefficients and + Householder vectors which encode the orthogonal matrix Q. The + vector tau must be of length k=min(M,N). The matrix + Q is related to these components by, Q = Q_k ... Q_2 Q_1 + where Q_i = I - \tau_i v_i v_i^T and v_i is the + Householder vector v_i = (0,...,1,A(i+1,i),A(i+2,i),...,A(m,i)). + This is the same storage scheme as used by lapack. The algorithm used to perform the decomposition is Householder QR (Golub - & Van Loan, @cite{Matrix Computations}, Algorithm 5.2.1)." - :invalidate (A tau)) + & Van Loan, Matrix Computations, Algorithm 5.2.1).") -(defun-gsl QR-solve (QR tau b x) +(defmfun QR-solve (QR tau b x) "gsl_linalg_QR_solve" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the square system @math{A x = b} using the @math{QR} - decomposition of @math{A} into (@var{QR}, @var{tau}) given by + :invalidate (x) + :documentation ; FDL + "Solve the square system A x = b using the QR + decomposition of A into (QR, tau) given by QR-decomp. The least-squares solution for rectangular systems can - be found using QR-lssolve." - :invalidate (x)) + be found using QR-lssolve.") -(defun-gsl QR-svx (QR tau x) +(defmfun QR-svx (QR tau x) "gsl_linalg_QR_svx" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solves the square system @math{A x = b} in-place using the - @math{QR} decomposition of @math{A} into (@var{QR},@var{tau}) given by - QR-decomp. On input @var{x} should contain the - right-hand side @math{b}, which is replaced by the solution on output." - :invalidate (x)) - -(defun-gsl QR-lssolve (QR tau b x residual) + :invalidate (x) + :documentation ; FDL + "Solves the square system A x = b in-place using the + QR decomposition of A into (QR, tau) given by + QR-decomp. On input x should contain the + right-hand side b, which is replaced by the solution on output.") + +(defmfun QR-lssolve (QR tau b x residual) "gsl_linalg_QR_lssolve" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c) ((pointer residual) gsl-vector-c)) - :documentation "The least squares solution to the overdetermined - system @math{A x = b} where the matrix @var{A} has more rows than + :invalidate (x) + :documentation ; FDL + "The least squares solution to the overdetermined + system A x = b where the matrix A has more rows than columns. The least squares solution minimizes the Euclidean norm of the - residual, @math{||Ax - b||}.The routine uses the @math{QR} decomposition - of @math{A} into (@var{QR}, @var{tau}) given by - @code{gsl_linalg_QR_decomp}. The solution is returned in @var{x}. The - residual is computed as a by-product and stored in @var{residual}." - :invalidate (x)) + residual, ||Ax - b||.The routine uses the QR decomposition + of A into (QR, tau) given by #'QR-decomp. The solution is returned in x. + The residual is computed as a by-product and stored in residual.") -(defun-gsl QR-QTvec (QR tau v) +(defmfun QR-QTvec (QR tau v) "gsl_linalg_QR_QTvec" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer v) gsl-vector-c)) - :documentation "Apply the matrix @math{Q^T} encoded in the decomposition - (@var{QR},@var{tau}) to the vector @var{v}, storing the result @math{Q^T - v} in @var{v}. The matrix multiplication is carried out directly using - the encoding of the Householder vectors without needing to form the full - matrix @math{Q^T}." - :invalidate (v)) - -(defun-gsl QR-Qvec (QR tau v) + :invalidate (v) + :documentation ; FDL + "Apply the matrix Q^T encoded in the decomposition + (QR, tau) to the vector v, storing the result Q^T v in v. + The matrix multiplication is carried out directly using + the encoding of the Householder vectors without needing to form the full + matrix Q^T.") + +(defmfun QR-Qvec (QR tau v) "gsl_linalg_QR_Qvec" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer v) gsl-vector-c)) - :documentation "Apply the matrix @math{Q} encoded in the decomposition - (@var{QR},@var{tau}) to the vector @var{v}, storing the result @math{Q - v} in @var{v}. The matrix multiplication is carried out directly using + :invalidate (v) + :documentation ; FDL + "Apply the matrix Q encoded in the decomposition + (QR, tau) to the vector v, storing the result Q v in v. + The matrix multiplication is carried out directly using the encoding of the Householder vectors without needing to form the full - matrix @math{Q}." - :invalidate (v)) + matrix Q.") -(defun-gsl QR-Rsolve (QR b x) +(defmfun QR-Rsolve (QR b x) "gsl_linalg_QR_Rsolve" (((pointer QR) gsl-matrix-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the triangular system @math{R x = b} for - @var{x}. It may be useful if the product @math{b' = Q^T b} has already - been computed using QR-QTvec}." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solve the triangular system R x = b for + x. It may be useful if the product b' = Q^T b has already + been computed using QR-QTvec}.") -(defun-gsl QR-Rsvx (QR x) +(defmfun QR-Rsvx (QR x) "gsl_linalg_QR_Rsvx" (((pointer QR) gsl-matrix-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the triangular system @math{R x = b} for @var{x} - in-place. On input @var{x} should contain the right-hand side @math{b} + :invalidate (x) + :documentation ; FDL + "Solve the triangular system R x = b for x + in-place. On input x should contain the right-hand side b and is replaced by the solution on output. This function may be useful if - the product @math{b' = Q^T b} has already been computed using - QR-QTvec}." - :invalidate (x)) + the product b' = Q^T b has already been computed using + QR-QTvec}.") -(defun-gsl QR-unpack (QR tau Q R) +(defmfun QR-unpack (QR tau Q R) "gsl_linalg_QR_unpack" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer Q) gsl-matrix-c) ((pointer R) gsl-matrix-c)) - :documentation "Unpack the encoded @math{QR} decomposition - (@var{QR},@var{tau}) into the matrices @var{Q} and @var{R}, where - @var{Q} is @math{M}-by-@math{M} and @var{R} is @math{M}-by-@math{N}." - :invalidate (Q R)) + :invalidate (Q R) + :documentation ; FDL + "Unpack the encoded QR decomposition + (QR, tau) into the matrices Q and R where + Q is M-by-M and R is M-by-N.") -(defun-gsl QR-QRsolve (Q R b x) +(defmfun QR-QRsolve (Q R b x) "gsl_linalg_QR_QRsolve" (((pointer Q) gsl-matrix-c) ((pointer R) gsl-matrix-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solves the system @math{R x = Q^T b} for @var{x}. It can - be used when the @math{QR} decomposition of a matrix is available in - unpacked form as (@var{Q}, @var{R})." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solves the system R x = Q^T b for x. It can + be used when the QR decomposition of a matrix is available in + unpacked form as Q, R).") -(defun-gsl QR-update (Q R w v) +(defmfun QR-update (Q R w v) "gsl_linalg_QR_update" (((pointer Q) gsl-matrix-c) ((pointer R) gsl-matrix-c) ((pointer w) gsl-vector-c) ((pointer v) gsl-vector-c)) - :documentation "Perform a rank-1 update @math{w v^T} of the @math{QR} - decomposition (@var{Q}, @var{R}). The update is given by @math{Q'R' = Q - R + w v^T} where the output matrices @math{Q'} and @math{R'} are also - orthogonal and right triangular. Note that @var{w} is destroyed by the - update." :invalidate (w Q R) - :return (Q R)) - -(defun-gsl R-solve (R b x) + :return (Q R) + :documentation ; FDL + "Perform a rank-1 update w v^T of the QR + decomposition (Q, R). The update is given by Q'R' = Q R + w v^T + where the output matrices Q' and R' are also + orthogonal and right triangular. Note that w is destroyed by the + update.") + +(defmfun R-solve (R b x) "gsl_linalg_R_solve" (((pointer R) gsl-matrix-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solves the triangular system @math{R x = b} for the - @math{N}-by-@math{N} matrix @var{R}." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solves the triangular system R x = b for the N-by-N matrix R.") -(defun-gsl R-svx (R x) +(defmfun R-svx (R x) "gsl_linalg_R_svx" (((pointer R) gsl-matrix-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the triangular system @math{R x = b} in-place. On - input @var{x} should contain the right-hand side @math{b}, which is - replaced by the solution on output." - :invalidate (x)) + :invalidate (x) + :documentation ; FDL + "Solve the triangular system R x = b in-place. On + input x should contain the right-hand side b, which is + replaced by the solution on output.") diff --git a/linear-algebra/qrpt.lisp b/linear-algebra/qrpt.lisp index edb6d1b75f221adc214a51c8f70f89d9ec7a9d38..a611df12aef7b1612e3205c9bf353a5dc67db03e 100644 --- a/linear-algebra/qrpt.lisp +++ b/linear-algebra/qrpt.lisp @@ -1,115 +1,116 @@ -;******************************************************** -; file: qrpt.lisp -; description: QR with column pivoting -; date: Fri Apr 28 2006 - 16:53 -; author: Liam Healy -; modified: Mon Jul 3 2006 - 23:21 -;******************************************************** -;;; $Id: $ +;; QR with column pivoting +;; Liam Healy, Fri Apr 28 2006 - 16:53 +;; Time-stamp: <2008-02-17 11:24:34EST qrpt.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl QRPT-decomp (A tau p signum norm) +(defmfun QRPT-decomp (A tau p signum norm) "gsl_linalg_QRPT_decomp" (((pointer A) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer p) gsl-permutation-c) (signum :pointer) ((pointer norm) gsl-vector-c)) - :documentation "Factorizes the @math{M}-by-@math{N} matrix @var{A} into - the @math{QRP^T} decomposition @math{A = Q R P^T}. On output the + :invalidate (A tau p norm) + :return (A tau signum p) + :documentation ; FDL + "Factorizes the M-by-N matrix A into + the QRP^T decomposition A = Q R P^T. On output the diagonal and upper triangular part of the input matrix contain the - matrix @math{R}. The permutation matrix @math{P} is stored in the - permutation @var{p}. The sign of the permutation is given by - @var{signum}. It has the value @math{(-1)^n}, where @math{n} is the - number of interchanges in the permutation. The vector @var{tau} and the - columns of the lower triangular part of the matrix @var{A} contain the + matrix R. The permutation matrix P is stored in the + permutation p. The sign of the permutation is given by + signum. It has the value (-1)^n, where n is the + number of interchanges in the permutation. The vector tau and the + columns of the lower triangular part of the matrix A contain the Householder coefficients and vectors which encode the orthogonal matrix - @var{Q}. The vector @var{tau} must be of length @math{k=\min(M,N)}. The - matrix @math{Q} is related to these components by, @math{Q = Q_k ... Q_2 - Q_1} where @math{Q_i = I - \tau_i v_i v_i^T} and @math{v_i} is the - Householder vector @math{v_i = - (0,...,1,A(i+1,i),A(i+2,i),...,A(m,i))}. This is the same storage scheme - as used by @sc{lapack}. The vector @var{norm} is a workspace of length - @var{N} used for column pivoting. + Q. The vector tau must be of length k=min(M,N). The + matrix Q is related to these components by, Q = Q_k ... Q_2 Q_1 + where Q_i = I - tau_i v_i v_i^T and v_i is the Householder vector + v_i = (0,...,1,A(i+1,i),A(i+2,i),...,A(m,i)). This is the same storage scheme + as used by lapack. The vector norm is a workspace of length + N used for column pivoting. The algorithm used to perform the decomposition is Householder QR with - column pivoting (Golub & Van Loan, @cite{Matrix Computations}, Algorithm - 5.4.1)." - :invalidate (A tau p norm) - :return (A tau signum p)) + column pivoting (Golub & Van Loan, Matrix Computations, Algorithm + 5.4.1).") -(defun-gsl QRPT-decomp2 (A q r tau p signum norm) +(defmfun QRPT-decomp2 (A q r tau p signum norm) "gsl_linalg_QRPT_decomp2" (((pointer A) gsl-matrix-c) ((pointer q) gsl-matrix-c) ((pointer r) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer p) gsl-permutation-c) (signum :pointer) ((pointer norm) gsl-vector-c)) - :documentation "Factorize the matrix @var{A} into the decomposition - @math{A = Q R P^T} without modifying @var{A} itself and storing the - output in the separate matrices @var{q} and @var{r}." :invalidate (q r norm) - :return (q r p signum)) + :return (q r p signum) + :documentation ; FDL + "Factorize the matrix A into the decomposition + A = Q R P^T without modifying A itself and storing the + output in the separate matrices q and r.") -(defun-gsl QRPT-solve (QR tau p b x) +(defmfun QRPT-solve (QR tau p b x) "gsl_linalg_QRPT_solve" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer p) gsl-permutation-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the square system @math{A x = b} using the @math{QRP^T} - decomposition of @math{A} into (@var{QR}, @var{tau}, @var{p}) given by - #'QRPT-decomp." :invalidate (x) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the square system A x = b using the QRP^T + decomposition of A into (QR, tau, p) given by #'QRPT-decomp.") -(defun-gsl QRPT-svx (QR tau p x) +(defmfun QRPT-svx (QR tau p x) "gsl_linalg_QRPT_svx" (((pointer QR) gsl-matrix-c) ((pointer tau) gsl-vector-c) ((pointer p) gsl-permutation-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the square system @math{A x = b} in-place using the - @math{QRP^T} decomposition of @math{A} into - (@var{QR},@var{tau},@var{p}). On input @var{x} should contain the - right-hand side @math{b}, which is replaced by the solution on output." :invalidate (x) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the square system A x = b in-place using the + QRP^T decomposition of A into (QR, tau, p). On input x should contain the + right-hand side b, which is replaced by the solution on output.") -(defun-gsl QRPT-QRsolve (QR p b x) +(defmfun QRPT-QRsolve (QR p b x) "gsl_linalg_QRPT_QRsolve" (((pointer QR) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the square system @math{R P^T x = Q^T b} for - @var{x}. It can be used when the @math{QR} decomposition of a matrix is - available in unpacked form as (@var{Q}, @var{R})." :invalidate (x) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the square system R P^T x = Q^T b for + x. It can be used when the QR decomposition of a matrix is + available in unpacked form as (Q, R).") -(defun-gsl QRPT-update (Q R p w v) +(defmfun QRPT-update (Q R p w v) "gsl_linalg_QRPT_update" (((pointer Q) gsl-matrix-c) ((pointer R) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer w) gsl-vector-c) ((pointer v) gsl-vector-c)) - :documentation "Perform a rank-1 update @math{w v^T} of the @math{QRP^T} - decomposition (@var{Q}, @var{R}, @var{p}). The update is given by - @math{Q'R' = Q R + w v^T} where the output matrices @math{Q'} and - @math{R'} are also orthogonal and right triangular. Note that @var{w} is - destroyed by the update. The permutation @var{p} is not changed." :invalidate (w Q R) - :return (Q R)) + :return (Q R) + :documentation ; FDL + "Perform a rank-1 update w v^T of the QRP^T + decomposition (Q, R, p). The update is given by + Q'R' = Q R + w v^T where the output matrices Q' and + R' are also orthogonal and right triangular. Note that w is + destroyed by the update. The permutation p is not changed.") -(defun-gsl QRPT-Rsolve (QR p b x) +(defmfun QRPT-Rsolve (QR p b x) "gsl_linalg_QRPT_Rsolve" (((pointer QR) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the triangular system @math{R P^T x = b} for the - @math{N}-by-@math{N} matrix @math{R} contained in @var{QR}." :invalidate (x) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the triangular system R P^T x = b for the + N-by-N matrix R contained in QR.") -(defun-gsl QRPT-Rsvx (QR p x) +(defmfun QRPT-Rsvx (QR p x) "gsl_linalg_QRPT_Rsvx" (((pointer QR) gsl-matrix-c) ((pointer p) gsl-permutation-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the triangular system @math{R P^T x = b} in-place - for the @math{N}-by-@math{N} matrix @math{R} contained in @var{QR}. On - input @var{x} should contain the right-hand side @math{b}, which is - replaced by the solution on output." :invalidate (x) - :return (x)) + :return (x) + :documentation ; FDL + "Solve the triangular system R P^T x = b in-place + for the N-by-N matrix R contained in QR. On + input x should contain the right-hand side b, which is + replaced by the solution on output.") diff --git a/linear-algebra/svd.lisp b/linear-algebra/svd.lisp index 96c931896e15a45225946a068f5319becd0d0944..c9773319f53c28f592c6d9a08948d52ada393f73 100644 --- a/linear-algebra/svd.lisp +++ b/linear-algebra/svd.lisp @@ -1,39 +1,19 @@ -;******************************************************** -; file: svd.lisp -; description: Singular Value Decomposition -; date: Tue May 2 2006 - 12:15 -; author: Liam Healy -; modified: Mon Jul 3 2006 - 23:34 -;******************************************************** -;;; $Id: $ +;; Singular Value Decomposition +;; Liam Healy, Tue May 2 2006 - 12:15 +;; Time-stamp: <2008-02-17 11:29:50EST svd.lisp> +;; $Id: $ (in-package :gsl) -;;; A general rectangular @math{M}-by-@math{N} matrix @math{A} has a -;;; singular value decomposition (@sc{svd}) into the product of an -;;; @math{M}-by-@math{N} orthogonal matrix @math{U}, an @math{N}-by-@math{N} -;;; diagonal matrix of singular values @math{S} and the transpose of an -;;; @math{N}-by-@math{N} orthogonal square matrix @math{V}, -;;; @tex -;;; \beforedisplay -;;; $$ -;;; A = U S V^T -;;; $$ -;;; \afterdisplay -;;; @end tex -;;; @ifinfo - -;;; @example -;;; A = U S V^T -;;; @end example -;;; @end ifinfo -;;; @noindent -;;; The singular values -;;; @c{$\sigma_i = S_{ii}$} -;;; @math{\sigma_i = S_@{ii@}} are all non-negative and are +;;; FDL +;;; A general rectangular M-by-N matrix A has a +;;; singular value decomposition (svd) into the product of an +;;; M-by-N orthogonal matrix U, an N-by- diagonal matrix of +;;; singular values S and the transpose of an +;;; N-by-N orthogonal square matrix V, A = U S V^T +;;; The singular values sigma_i = S_{ii} are all non-negative and are ;;; generally chosen to form a non-increasing sequence -;;; @c{$\sigma_1 \ge \sigma_2 \ge ... \ge \sigma_N \ge 0$} -;;; @math{\sigma_1 >= \sigma_2 >= ... >= \sigma_N >= 0}. +;;; sigma_1 >= sigma_2 >= ... >= sigma_N >= 0. ;;; The singular value decomposition of a matrix has many practical uses. ;;; The condition number of the matrix is given by the ratio of the largest @@ -45,60 +25,60 @@ ;;; precision. Small singular values should be edited by choosing a suitable ;;; tolerance. -(defun-gsl SV-decomp (A V S work) +(defmfun SV-decomp (A V S work) "gsl_linalg_SV_decomp" (((pointer A) gsl-matrix-c) ((pointer V) gsl-matrix-c) ((pointer S) gsl-vector-c) ((pointer work) gsl-vector-c)) - :documentation - "Factorize the @math{M}-by-@math{N} matrix @var{A} into - the singular value decomposition @math{A = U S V^T} for @c{$M \ge N$} - @math{M >= N}. On output the matrix @var{A} is replaced by - @math{U}. The diagonal elements of the singular value matrix @math{S} - are stored in the vector @var{S}. The singular values are non-negative - and form a non-increasing sequence from @math{S_1} to @math{S_N}. The - matrix @var{V} contains the elements of @math{V} in untransposed - form. To form the product @math{U S V^T} it is necessary to take the - transpose of @var{V}. A workspace of length @var{N} is required in - @var{work}. - This routine uses the Golub-Reinsch SVD algorithm." - :invalidate (A)) + :invalidate (A) + :documentation ; FDL + "Factorize the M-by-N matrix A into + the singular value decomposition A = U S V^T for M >= N. + On output the matrix A is replaced by U. The diagonal elements + of the singular value matrix S + are stored in the vector S. The singular values are non-negative + and form a non-increasing sequence from S_1 to S_N. The + matrix V contains the elements of V in untransposed + form. To form the product U S V^T it is necessary to take the + transpose of V. A workspace of length N is required in work. + This routine uses the Golub-Reinsch SVD algorithm.") -(defun-gsl SV-decomp-mod (A X V S work) +(defmfun SV-decomp-mod (A X V S work) "gsl_linalg_SV_decomp_mod" (((pointer A) gsl-matrix-c) ((pointer X) gsl-matrix-c) ((pointer V) gsl-matrix-c) ((pointer S) gsl-vector-c) ((pointer work) gsl-vector-c)) - :documentation - "The SVD using the modified Golub-Reinsch algorithm, which is faster for @c{$M \gg N$} - @math{M>>N}. It requires the vector @var{work} of length @var{N} and the - @math{N}-by-@math{N} matrix @var{X} as additional working space." - :invalidate (A)) + :invalidate (A) + :documentation ; FDL + "The SVD using the modified Golub-Reinsch algorithm, which is + faster for M >> N. It requires the vector work of length N and the + N-by-N matrix X as additional working space.") -(defun-gsl SV-decomp-jacobi (A V S) +(defmfun SV-decomp-jacobi (A V S) "gsl_linalg_SV_decomp_jacobi" (((pointer A) gsl-matrix-c) ((pointer V) gsl-matrix-c) ((pointer S) gsl-vector-c)) - :documentation "The SVD of the @math{M}-by-@math{N} matrix @var{A} - using one-sided Jacobi orthogonalization for @c{$M \ge N$} - @math{M >= N}. The Jacobi method can compute singular values to higher - relative accuracy than Golub-Reinsch algorithms (see references for - details)." - :invalidate (A)) + :invalidate (A) + :documentation ; FDL + "The SVD of the M-by-N matrix A using one-sided Jacobi + orthogonalization for M >= N. The Jacobi method can compute singular + values to higher relative accuracy than Golub-Reinsch algorithms (see + references for details).") -(defun-gsl SV-solve (U V S b x) +(defmfun SV-solve (U V S b x) "gsl_linalg_SV_solve" (((pointer U) gsl-matrix-c) ((pointer V) gsl-matrix-c) ((pointer S) gsl-vector-c) ((pointer b) gsl-vector-c) ((pointer x) gsl-vector-c)) - :documentation "Solve the system @math{A x = b} using the singular value - decomposition (@var{U}, @var{S}, @var{V}) of @math{A} given by #'SV-decomp. + :invalidate (x) + :documentation ; FDL + "Solve the system A x = b using the singular value + decomposition (U, S, V) of A given by #'SV-decomp. Only non-zero singular values are used in computing the solution. The parts of the solution corresponding to singular values of zero are ignored. Other singular values can be edited out by setting them to zero before calling this function. - In the over-determined case where @var{A} has more rows than columns the + In the over-determined case where A has more rows than columns the system is solved in the least squares sense, returning the solution - @var{x} which minimizes @math{||A x - b||_2}." - :invalidate (x)) + x which minimizes ||A x - b||_2.") diff --git a/mathematical.lisp b/mathematical.lisp index 728804076bd841623168a4bb8b9e8fddd2bf0943..b1cbb6ac8baccfed286a090de09fc009f72def97 100644 --- a/mathematical.lisp +++ b/mathematical.lisp @@ -1,6 +1,6 @@ ;; Mathematical functions ;; Liam Healy, Wed Mar 8 2006 - 22:09 -;; Time-stamp: <2008-01-21 18:01:09EST mathematical.lisp> +;; Time-stamp: <2008-02-17 09:13:19EST mathematical.lisp> ;; $Id: $ (in-package :gsl) @@ -45,60 +45,65 @@ (ignore-errors (cffi:foreign-funcall "gsl_neginf" :double))) -(defun-gsl nanp (x) +(defmfun nanp (x) "gsl_isnan" ((x :double)) - :documentation "Return T if x is a double-float NaN." :c-return (cr :int) - :return ((= 1 cr))) + :return ((= 1 cr)) + :documentation ; FDL + "Return T if x is a double-float NaN.") -(defun-gsl infinityp (x) +(defmfun infinityp (x) "gsl_isinf" ((x :double)) - :documentation "Return +1 if x is positive infinity, -1 if negative infinity - nil if finite." :c-return (cr :int) - :return ((pmnil cr))) + :return ((pmnil cr)) + :documentation ; FDL + "Return +1 if x is positive infinity, -1 if negative infinity + nil if finite.") -(defun-gsl finitep (x) - "gsl_finite" ((x :double)) - :documentation "Return T if x is finite." +(defmfun finitep (x) + "gsl_finite" ((x :double)) :c-return (cr :int) - :return ((= 1 cr))) + :return ((= 1 cr)) + :documentation ; FDL + "Return T if x is finite.") ;;;;**************************************************************************** ;;; Elementary functions ;;;;**************************************************************************** -(defun-gsl log+1 (x) +(defmfun log+1 (x) "gsl_log1p" ((x :double)) :c-return :double - :documentation + :documentation ; FDL "log(1+x), computed in a way that is accurate for small x.") -(defun-gsl exp-1 (x) +(defmfun exp-1 (x) "gsl_expm1" ((x :double)) :c-return :double - :documentation + :documentation ; FDL "exp(x)-1, computed in a way that is accurate for small x.") -(defun-gsl hypotenuse* (x y) +(defmfun hypotenuse* (x y) ;; This is redundant; there is "gsl_sf_hypot_e" defined as ;; #'hyptoenuse. "gsl_hypot" ((x :double) (y :double)) :c-return :double - :documentation + :documentation ;FDL "The hypotenuse sqrt{x^2 + y^2} computed in a way that avoids overflow.") ;; Not clear why this function exists -(defun-gsl gsl-asinh (x) +(defmfun gsl-asinh (x) "gsl_asinh" ((x :double)) :c-return :double - :documentation "Arc hyperbolic sine.") + :documentation ; FDL + "Arc hyperbolic sine.") ;; Not clear why this function exists -(defun-gsl gsl-atanh (x) +(defmfun gsl-atanh (x) "gsl_atanh" ((x :double)) :c-return :double - :documentation "Arc hyperbolic tangent.") + :documentation ; FDL + "Arc hyperbolic tangent.") ;;; gsl_ldexp ;;; gsl_frexp @@ -111,6 +116,7 @@ ;;; Does CL need these? #| +;; FDL A common complaint about the standard C library is its lack of a function for calculating (small) integer powers. GSL provides a simple functions to fill this gap. For reasons of efficiency, @@ -145,21 +151,22 @@ Function: double gsl_pow_9 (const double x) ;;; Approximate Comparison of Floating Point Numbers ;;;;**************************************************************************** +;;; FDL ;;; It is sometimes useful to be able to compare two floating point ;;; numbers approximately, to allow for rounding and truncation ;;; errors. This function implements the approximate ;;; floating-point comparison algorithm proposed by D.E. Knuth in ;;; Section 4.2.2 of Seminumerical Algorithms (3rd edition). -(defun-gsl double-float-unequal (x y epsilon) +(defmfun double-float-unequal (x y epsilon) "gsl_fcmp" ((x :double) (y :double) (epsilon :double)) :c-return (cr :int) - :documentation + :documentation ; FDL "This function determines whether x and y are approximately equal to a relative accuracy epsilon. The relative accuracy is measured using an interval of size 2 - \delta, where \delta = 2^k \epsilon and k is the maximum + delta, where delta = 2^k \epsilon and k is the maximum base-2 exponent of x and y as computed by the function frexp(). @@ -173,6 +180,13 @@ Function: double gsl_pow_9 (const double x) ;;;; Examples and unit test ;;;;**************************************************************************** +#| +(make-tests mathematical + (log+1 0.001d0) + (exp-1 0.001d0) + (hypotenuse 3.0d0 4.0d0)) +|# + (lisp-unit:define-test mathematical (lisp-unit:assert-true (nanp +nan+)) (lisp-unit:assert-false (nanp 1.0d0)) @@ -180,7 +194,13 @@ Function: double gsl_pow_9 (const double x) (lisp-unit:assert-false (infinityp 1.0d0)) (lisp-unit:assert-eq 1 (infinityp +positive-infinity+)) (lisp-unit:assert-false (finitep +positive-infinity+)) - (lisp-unit:assert-first-fp-equal "0.999500333084d-03" (log+1 0.001d0)) - (lisp-unit:assert-first-fp-equal "0.100050016671d-02" (exp-1 0.001d0)) - (lisp-unit:assert-first-fp-equal "0.500000000000d+01" (hypotenuse 3.0d0 4.0d0)) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 9.995003330835331d-4) + (MULTIPLE-VALUE-LIST (LOG+1 0.001d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.0010005001667083417d0) + (MULTIPLE-VALUE-LIST (EXP-1 0.001d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 5.0d0 2.220446049250313d-15) + (MULTIPLE-VALUE-LIST (HYPOTENUSE 3.0d0 4.0d0))) (lisp-unit:assert-false (double-float-unequal 1.0d0 1.0d0 0.001d0))) diff --git a/monte-carlo.lisp b/monte-carlo.lisp index a529856a0c1811f9e10f8889f1b04abb16823ed9..8d5e5d30cdb9c491c3767924850d5a07f4c84046 100644 --- a/monte-carlo.lisp +++ b/monte-carlo.lisp @@ -1,6 +1,6 @@ ;; Monte Carlo Integration ;; Liam Healy Sat Feb 3 2007 - 17:42 -;; Time-stamp: <2008-02-03 13:25:30EST monte-carlo.lisp> +;; Time-stamp: <2008-02-17 18:29:59EST monte-carlo.lisp> ;; $Id: $ (in-package :gsl) @@ -10,57 +10,57 @@ ;;;;**************************************************************************** (cffi:defcstruct plain-state - (dim :size) + (dim size) (x :pointer)) (defgo-s (monte-carlo-plain dim) monte-carlo-plain-alloc monte-carlo-plain-free) -(defun-gsl monte-carlo-plain-alloc (dim) +(defmfun monte-carlo-plain-alloc (dim) "gsl_monte_plain_alloc" - ((dim :size)) + ((dim size)) :c-return :pointer :export nil :index (letm monte-carlo-plain) - :documentation + :documentation ; FDL "Allocate and initialize a workspace for Monte Carlo - integration in @var{dim} dimensions.") + integration in dim dimensions.") -(defun-gsl monte-carlo-plain-init (integrator-state) +(defmfun monte-carlo-plain-init (integrator-state) "gsl_monte_plain_init" ((integrator-state :pointer)) - :documentation + :documentation ; FDL "Initialize a previously allocated integration state. This allows an existing workspace to be reused for different integrations.") -(defun-gsl monte-carlo-plain-free (integrator-state) +(defmfun monte-carlo-plain-free (integrator-state) "gsl_monte_plain_free" ((integrator-state :pointer)) :c-return :void :export nil :index (letm monte-carlo-plain) - :documentation + :documentation ; FDL "Frees the memory associated with the integrator.") -(defun-gsl monte-carlo-integrate-plain +(defmfun monte-carlo-integrate-plain (function lower-limits upper-limits calls generator state) "gsl_monte_plain_integrate" ((function :pointer) ((gsl-array lower-limits) :pointer) ((gsl-array upper-limits) :pointer) - ((dim0 lower-limits) :size) (calls :size) + ((dim0 lower-limits) size) (calls size) ((generator generator) :pointer) (state :pointer) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Uses the plain Monte Carlo algorithm to integrate the - function @var{f} over the hypercubic region defined by the + function f over the hypercubic region defined by the lower and upper limits in the arrays 'lower-limits and - 'upper-limits, each a gsl-vector of length @var{dim}. + 'upper-limits, each a gsl-vector of length dim. The integration uses a fixed number - of function calls @var{calls}, and obtains random sampling points using + of function calls calls, and obtains random sampling points using the random number generator 'generator. A previously allocated workspace - 'state must be supplied. The result of the integration is returned in - @var{result}, with an estimated absolute error @var{abserr}.") + 'state must be supplied. The result of the integration is returned + with an estimated absolute error.") ;;;;**************************************************************************** ;;;; MISER @@ -72,12 +72,12 @@ ;;; regions of highest variance. (cffi:defcstruct miser-state - (min-calls :size) - (min-calls-per-bisection :size) + (min-calls size) + (min-calls-per-bisection size) (dither :double) (estimate-frac :double) (alpha :double) - (dim :size) + (dim size) (estimate-style :int) (depth :int) (verbose :int) @@ -98,75 +98,76 @@ (defgo-s (monte-carlo-miser dim) monte-carlo-miser-alloc monte-carlo-miser-free) -(defun-gsl monte-carlo-miser-alloc (dim) +(defmfun monte-carlo-miser-alloc (dim) "gsl_monte_miser_alloc" - ((dim :size)) + ((dim size)) :c-return :pointer :export nil :index (letm monte-carlo-miser) - :documentation + :documentation ; FDL "Allocate and initialize a workspace for Monte Carlo integration in - @var{dim} dimensions. The workspace is used to maintain + dim dimensions. The workspace is used to maintain the state of the integration. Returns a pointer to miser-state.") -(defun-gsl monte-carlo-miser-init (integrator-state) +(defmfun monte-carlo-miser-init (integrator-state) "gsl_monte_miser_init" ((integrator-state :pointer)) - :documentation + :documentation ; FDL "Initialize a previously allocated integration state. This allows an existing workspace to be reused for different integrations.") -(defun-gsl monte-carlo-miser-free (integrator-state) +(defmfun monte-carlo-miser-free (integrator-state) "gsl_monte_miser_free" ((integrator-state :pointer)) :c-return :void :export nil :index (letm monte-carlo-miser) - :documentation + :documentation ; FDL "Frees the memory associated with the integrator.") (export 'miser-parameter) (defmacro miser-parameter (workspace parameter) + ;; FDL "Get or set with setf the parameter value for the MISER Monte Carlo integration method." ;; (miser-parameter ws min-calls) ;; (setf (miser-parameter ws min-calls) 300) `(foreign-slot-value ,workspace 'miser-state ',parameter)) -(defun-gsl monte-carlo-integrate-miser +(defmfun monte-carlo-integrate-miser (function lower-limits upper-limits calls generator state) "gsl_monte_miser_integrate" ((function :pointer) ((gsl-array lower-limits) :pointer) ((gsl-array upper-limits) :pointer) - ((dim0 lower-limits) :size) (calls :size) + ((dim0 lower-limits) size) (calls size) ((generator generator) :pointer) (state :pointer) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Uses the miser Monte Carlo algorithm to integrate the - function @var{f} over the hypercubic region defined by the + function f over the hypercubic region defined by the lower and upper limits in the arrays 'lower-limits and - 'upper-limits, each a gsl-vector of length @var{dim}. + 'upper-limits, each a gsl-vector of the samelength The integration uses a fixed number - of function calls @var{calls}, and obtains random sampling points using + of function calls calls, and obtains random sampling points using the random number generator 'generator. A previously allocated workspace - 'state must be supplied. The result of the integration is returned in - @var{result}, with an estimated absolute error @var{abserr}.") + 'state must be supplied. The result of the integration is returned + with an estimated absolute error.") ;;;;**************************************************************************** ;;;; VEGAS ;;;;**************************************************************************** -;;; The @sc{vegas} algorithm of Lepage is based on importance sampling. It +;;; The vegas algorithm of Lepage is based on importance sampling. It ;;; samples points from the probability distribution described by the -;;; function @math{|f|}, so that the points are concentrated in the regions +;;; function |f|, so that the points are concentrated in the regions ;;; that make the largest contribution to the integral. (cffi:defcstruct vegas-state ;; grid - (dim :size) - (bins-max :size) + (dim size) + (bins-max size) (bins :uint) ; uint (boxes :uint) ; these are both counted along the axes (xi :pointer) @@ -200,63 +201,64 @@ (defgo-s (monte-carlo-vegas dim) monte-carlo-vegas-alloc monte-carlo-vegas-free) -(defun-gsl monte-carlo-vegas-alloc (dim) +(defmfun monte-carlo-vegas-alloc (dim) "gsl_monte_vegas_alloc" - ((dim :size)) + ((dim size)) :c-return :pointer :export nil :index (letm monte-carlo-vegas) - :documentation + :documentation ; FDL "Allocate and initialize a workspace for Monte Carlo integration in - @var{dim} dimensions. The workspace is used to maintain + dim dimensions. The workspace is used to maintain the state of the integration. Returns a pointer to vegas-state.") -(defun-gsl monte-carlo-vegas-init (integrator-state) +(defmfun monte-carlo-vegas-init (integrator-state) "gsl_monte_vegas_init" ((integrator-state :pointer)) - :documentation + :documentation ; FDL "Initialize a previously allocated integration state. This allows an existing workspace to be reused for different integrations.") -(defun-gsl monte-carlo-vegas-free (integrator-state) +(defmfun monte-carlo-vegas-free (integrator-state) "gsl_monte_vegas_free" ((integrator-state :pointer)) :c-return :void :export nil :index (letm monte-carlo-vegas) - :documentation + :documentation ; FDL "Frees the memory associated with the integrator.") (export 'vegas-parameter) (defmacro vegas-parameter (workspace parameter) + ;; FDL "Get or set with setf the parameter value for the VEGAS Monte Carlo integration method." ;; (vegas-parameter ws bins-max) ;; (setf (vegas-parameter ws bins-max) 300) `(foreign-slot-value ,workspace 'vegas-state ',parameter)) -(defun-gsl monte-carlo-integrate-vegas +(defmfun monte-carlo-integrate-vegas (function lower-limits upper-limits calls generator state) "gsl_monte_vegas_integrate" ((function :pointer) ((gsl-array lower-limits) :pointer) ((gsl-array upper-limits) :pointer) - ((dim0 lower-limits) :size) (calls :size) + ((dim0 lower-limits) size) (calls size) ((generator generator) :pointer) (state :pointer) (result :double) (abserr :double)) - :documentation - "Uses the @sc{vegas} Monte Carlo algorithm to integrate the - function @var{f} over the @var{dim}-dimensional hypercubic region - defined by the lower and upper limits in the arrays @var{xl} and - @var{xu}, each of size @var{dim}. The integration uses a fixed number - of function calls @var{calls}, and obtains random sampling points using - the random number generator @var{r}. A previously allocated workspace - @var{s} must be supplied. The result of the integration is returned in - @var{result}, with an estimated absolute error @var{abserr}. The result + :documentation ; FDL + "Uses the vegas Monte Carlo algorithm to integrate the + function f over the dim-dimensional hypercubic region + defined by the lower and upper limits in the arrays x1 and + xu, each of size dim. The integration uses a fixed number + of function calls calls, and obtains random sampling points using + the random number generator r. A previously allocated workspace + s must be supplied. The result of the integration is returned + with an estimated absolute error. The result and its error estimate are based on a weighted average of independent samples. The chi-squared per degree of freedom for the weighted average - is returned via the state struct component, @var{s->chisq}, and must be + is returned via the state struct component, s->chisq, and must be consistent with 1 for the weighted average to be reliable.") ;;;;**************************************************************************** @@ -265,7 +267,7 @@ (cffi:defcstruct monte-function (function :pointer) - (dimensions :size) + (dimensions size) (parameters :pointer)) (export 'def-mc-function) @@ -308,13 +310,21 @@ (rng (random-number-generator *mt19937* 0))) (monte-carlo-integrate-vegas monte-carlo-g lower upper nsamples rng ws))) -(lisp-unit:define-test monte-carlo - (lisp-unit:assert-first-fp-equal - "0.141220870335d+01" - (random-walk-plain-example)) - (lisp-unit:assert-first-fp-equal - "0.138952970588d+01" - (random-walk-miser-example)) - (lisp-unit:assert-first-fp-equal - "0.139316327396d+01" - (random-walk-vegas-example))) +#| +(make-tests monte-carlo + (random-walk-plain-example) + (random-walk-miser-example) + (random-walk-vegas-example)) +|# + +(LISP-UNIT:DEFINE-TEST MONTE-CARLO + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.4122087033540667d0 0.013435861456267064d0) + (MULTIPLE-VALUE-LIST (RANDOM-WALK-PLAIN-EXAMPLE))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.3895297058825096d0 0.0050106269732269415d0) + (MULTIPLE-VALUE-LIST (RANDOM-WALK-MISER-EXAMPLE))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.3931632739551914d0 1.4981164744582692d-4) + (MULTIPLE-VALUE-LIST (RANDOM-WALK-VEGAS-EXAMPLE)))) + diff --git a/numerical-differentiation.lisp b/numerical-differentiation.lisp index d9230aba939a59ed300ccdae408029edb9e1fae5..0cf3ee8f9b961b5ee7946c55e820fdd77b628662 100644 --- a/numerical-differentiation.lisp +++ b/numerical-differentiation.lisp @@ -1,6 +1,6 @@ ;; Numerical differentiation. ;; Liam Healy Mon Nov 12 2007 - 22:07 -;; Time-stamp: <2008-01-20 22:35:42EST numerical-differentiation.lisp> +;; Time-stamp: <2008-02-17 18:36:19EST numerical-differentiation.lisp> ;; $Id: $ (in-package :gsl) @@ -10,62 +10,61 @@ ;;; numerical-integration, so those definitions have been used. ;;; Some improvement could be made in naming/organization. -(defun-gsl central-derivative (function x step) +(defmfun central-derivative (function x step) "gsl_deriv_central" ((function :pointer) (x :double) (step :double) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Compute the numerical derivative of the function - at the point @var{x} using an adaptive central difference algorithm with + at the point x using an adaptive central difference algorithm with a step-size of step. The derivative and an estimate of its absolute error is returned. The initial value of step is used to estimate an optimal step-size, based on the scaling of the truncation error and round-off error in the derivative calculation. The derivative is computed using a 5-point rule - for equally spaced abscissae at @math{x-step}, @math{x-step/2}, @math{x}, - @math{x+step/2}, @math{x}, with an error estimate taken from the difference - between the 5-point rule and the corresponding 3-point rule @math{x-step}, - @math{x}, @math{x+step}. Note that the value of the function at @math{x} + for equally spaced abscissae at x-step, x-step/2, x, + x+step/2, x, with an error estimate taken from the difference + between the 5-point rule and the corresponding 3-point rule x-step, + x, x+step. Note that the value of the function at x does not contribute to the derivative calculation, so only 4-points are actually used.") -(defun-gsl forward-derivative (function x step) +(defmfun forward-derivative (function x step) "gsl_deriv_forward" ((function :pointer) (x :double) (step :double) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Compute the numerical derivative of the function - at the point @var{x} using an adaptive forward difference algorithm with + at the point x using an adaptive forward difference algorithm with a step-size of step. The function is evaluated only at points greater - than @var{x}, and never at @var{x} itself. The derivative is returned in - @var{result} and an estimate of its absolute error is returned in - @var{abserr}. This function should be used if @math{f(x)} has a - discontinuity at @var{x}, or is undefined for values less than @var{x}. + than x and never at x itself. The derivative is returned in + result and an estimate of its absolute error is returned as the + second value. This function should be used if f(x) has a + discontinuity at x, or is undefined for values less than x. The initial value of step is used to estimate an optimal step-size, based on the scaling of the truncation error and round-off error in - the derivative calculation. The derivative at @math{x} is computed + the derivative calculation. The derivative at x is computed using an ``open'' 4-point rule for equally spaced abscissae at - @math{x+step/4}, @math{x+step/2}, @math{x+3step/4}, @math{x+step}, + x+step/4, x+step/2, x+3step/4, x+step, with an error estimate taken from the difference between the 4-point - rule and the corresponding 2-point rule @math{x+step/2}, - @math{x+step}.") + rule and the corresponding 2-point rule x+step/2, + x+step.") -(defun-gsl backward-derivative (function x step) +(defmfun backward-derivative (function x step) "gsl_deriv_backward" ((function :pointer) (x :double) (step :double) (result :double) (abserr :double)) - :documentation - "Compute the numerical derivative of the function at the point - @var{x} using an adaptive backward difference algorithm with a - step-size of step. The function is evaluated only at points less than - @var{x}, and never at @var{x} itself. The derivative is returned in - @var{result} and an estimate of its absolute error is returned in - @var{abserr}. This function should be used if @math{f(x)} has a - discontinuity at @var{x}, or is undefined for values greater than - @var{x}. This function is equivalent to calling #'forward-derivative - with a negative step-size.") + :documentation ; FDL + "Compute the numerical derivative of the function at the point x + using an adaptive backward difference algorithm with a step-size of + step. The function is evaluated only at points less than x, and never + at x itself. The derivative is returned in result and an estimate of + its absolute error is returned as the second value. This function + should be used if f(x) has a discontinuity at x, or is undefined for + values greater than x. This function is equivalent to calling + #'forward-derivative with a negative step-size.") ;;;; Examples and unit test @@ -73,8 +72,15 @@ (defun-single 3/2-power (x) (expt x 3/2)) ;;; (3/2-power 2.0d0) -(lisp-unit:define-test numerical-differentiation - (lisp-unit:assert-first-fp-equal - "0.212132031200d+01" +#| +(make-tests numerical-differentiation ;; Compare to (* 3/2 (sqrt 2.0d0)) - (central-derivative 3/2-power 2.0d0 1.d-8))) + (central-derivative 3/2-power 2.0d0 1.d-8)) +|# + +(LISP-UNIT:DEFINE-TEST NUMERICAL-DIFFERENTIATION + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.121320312002221d0 4.0642813729715275d-7) + (MULTIPLE-VALUE-LIST + (CENTRAL-DERIVATIVE 3/2-POWER 2.0d0 1.d-8)))) + diff --git a/numerical-integration.lisp b/numerical-integration.lisp index 60f66a0daeb2a8c8b7f5a26143692a5ce2065587..9757fea0305bdce7296592cb9680a882772650d9 100644 --- a/numerical-integration.lisp +++ b/numerical-integration.lisp @@ -1,6 +1,6 @@ ;; Numerical integration ;; Liam Healy, Wed Jul 5 2006 - 23:14 -;; Time-stamp: <2008-02-16 11:07:23EST numerical-integration.lisp> +;; Time-stamp: <2008-02-17 11:43:47EST numerical-integration.lisp> ;; $Id: $ ;;; To do: QAWS, QAWO, QAWF, more tests @@ -11,24 +11,24 @@ ;;;; QNG non-adaptive Gauss-Kronrod integration ;;;;**************************************************************************** -(defun-gsl integration-QNG - (function a b &optional (epsabs 1.0d0) (epsrel 1.0d0)) - ;; Set epsabs and epsrel to 1 because it apparently doesn't matter +(defmfun integration-QNG + (function a b &optional (absolute-error 1.0d0) (relative-error 1.0d0)) + ;; Set absolute-error and relative-error to 1 because it apparently doesn't matter ;; what these are if they are too large, it will do a minimum number ;; of points anyway. "gsl_integration_qng" ((function :pointer) (a :double) (b :double) - (epsabs :double) (epsrel :double) - (result :double) (abserr :double) (neval :size)) - :documentation + (absolute-error :double) (relative-error :double) + (result :double) (abserr :double) (neval size)) + :documentation ; FDL "Apply the Gauss-Kronrod 10-point, 21-point, 43-point and 87-point integration rules in succession until an estimate of the - integral of @math{f} over @math{(a,b)} is achieved within the desired - absolute and relative error limits, @var{epsabs} and @var{epsrel}. The + integral of f over (a,b) is achieved within the desired + absolute and relative error limits, absolute-error and relative-error. The function returns the final approximation, an estimate of the absolute error, and the number of function evaluations - used, @var{neval}. The Gauss-Kronrod rules are designed in such a way + used. The Gauss-Kronrod rules are designed in such a way that each rule uses all the results of its predecessors, in order to minimize the total number of function evaluations.") @@ -39,44 +39,46 @@ (defgo-s (integration-workspace size) integration-workspace-alloc integration-workspace-free) -(defun-gsl integration-workspace-alloc (size) - "gsl_integration_workspace_alloc" ((size :size)) +(defmfun integration-workspace-alloc (size) + "gsl_integration_workspace_alloc" ((size size)) :c-return :pointer :export nil :index (letm integration-workspace) - :documentation "Allocate a workspace sufficient to hold @var{n} double + :documentation ; FDL + "Allocate a workspace sufficient to hold n double precision intervals, their integration results and error estimates.") -(defun-gsl integration-workspace-free (pointer) +(defmfun integration-workspace-free (pointer) "gsl_integration_workspace_free" ((pointer :pointer)) :c-return :void :export nil :index (letm integration-workspace) - :documentation "Free the memory associated with the workspace @var{w}.") + :documentation ; FDL + "Free the memory associated with the workspace.") (cffi:defcenum integrate-method :gauss15 :gauss21 :gauss31 :gauss41 :gauss51 :gauss61) -(defun-gsl integration-QAG +(defmfun integration-QAG (function a b method limit workspace - &optional (epsabs 1.0d0) (epsrel 1.0d0)) - ;; Set epsabs and epsrel to 1 because it apparently doesn't matter + &optional (absolute-error 1.0d0) (relative-error 1.0d0)) + ;; Set absolute-error and relative-error to 1 because it apparently doesn't matter ;; what these are if they are too large, it will do a minimum number ;; of points anyway. "gsl_integration_qag" ((function :pointer) (a :double) (b :double) - (epsabs :double) (epsrel :double) - (limit :size) (method integrate-method) (workspace :pointer) + (absolute-error :double) (relative-error :double) + (limit size) (method integrate-method) (workspace :pointer) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Apply an integration rule adaptively until an estimate - of the integral of @math{f} over @math{(a,b)} is achieved within the - desired absolute and relative error limits, @var{epsabs} and - @var{epsrel}. The function returns the final approximation, + of the integral of f over (a,b) is achieved within the + desired absolute and relative error limits, absolute-error and + relative-error. The function returns the final approximation, and an estimate of the absolute error. The integration rule - is determined by the value of @var{method}, which should + is determined by the value of method, which should be chosen from the following symbolic names, :gauss15 :gauss21 :gauss31 :gauss41 :gauss51 :gauss61 corresponding to the 15, 21, 31, 41, 51 and 61 point Gauss-Kronrod @@ -85,72 +87,73 @@ difficulties, such as discontinuities. On each iteration the adaptive integration strategy bisects the interval with the largest error estimate. The subintervals and their results are - stored in the memory provided by @var{workspace}. The maximum number of - subintervals is given by @var{limit}, which may not exceed the allocated + stored in the memory provided by workspace. The maximum number of + subintervals is given by limit, which may not exceed the allocated size of the workspace.") ;;;;**************************************************************************** ;;;; QAGS adaptive integration with singularity ;;;;**************************************************************************** -(defun-gsl integration-QAGS - (function a b limit workspace &optional (epsabs 1.0d0) (epsrel 1.0d0)) +(defmfun integration-QAGS + (function a b limit workspace + &optional (absolute-error 1.0d0) (relative-error 1.0d0)) "gsl_integration_qags" ((function :pointer) (a :double) (b :double) - (epsabs :double) (epsrel :double) (limit :size) (workspace :pointer) + (absolute-error :double) (relative-error :double) (limit size) (workspace :pointer) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Apply the Gauss-Kronrod 21-point integration rule - adaptively until an estimate of the integral of @math{f} over - @math{(a,b)} is achieved within the desired absolute and relative error - limits, @var{epsabs} and @var{epsrel}. The results are extrapolated + adaptively until an estimate of the integral of f over + (a,b) is achieved within the desired absolute and relative error + limits, absolute-error and relative-error. The results are extrapolated using the epsilon-algorithm, which accelerates the convergence of the integral in the presence of discontinuities and integrable singularities. The function returns the final approximation from the - extrapolation, @var{result}, and an estimate of the absolute error, - @var{abserr}. The subintervals and their results are stored in the - memory provided by @var{workspace}. The maximum number of subintervals - is given by @var{limit}, which may not exceed the allocated size of the + extrapolation, and an estimate of the absolute error. The subintervals + and their results are stored in the + memory provided by workspace. The maximum number of subintervals + is given by limit, which may not exceed the allocated size of the workspace.") ;;;;**************************************************************************** ;;;; QAGP adaptive integration with known singular points ;;;;**************************************************************************** -(defun-gsl integration-QAGP - (function points limit workspace &optional (epsabs 1.0d0) (epsrel 1.0d0)) +(defmfun integration-QAGP + (function points limit workspace &optional (absolute-error 1.0d0) (relative-error 1.0d0)) "gsl_integration_qagp" ((function :pointer) - ((pointer points) :pointer) ((dim0 points) :size) - (epsabs :double) (epsrel :double) (limit :size) (workspace :pointer) + ((pointer points) :pointer) ((dim0 points) size) + (absolute-error :double) (relative-error :double) (limit size) (workspace :pointer) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Apply the adaptive integration algorithm QAGS taking account of the user-supplied locations of singular points. The array - @var{pts} of length @var{npts} should contain the endpoints of the + pts of length npts should contain the endpoints of the integration ranges defined by the integration region and locations of the singularities. For example, to integrate over the region - @math{(a,b)} with break-points at @math{x_1, x_2, x_3} (where - @math{a < x_1 < x_2 < x_3 < b}) then an array with + (a,b) with break-points at x_1, x_2, x_3 (where + a < x_1 < x_2 < x_3 < b) then an array with (setf (data array) #(a x_1 x_2 x_3 b)) should be used. If you know the locations of the singular points in the integration - region then this routine will be faster than @code{QAGS}.") + region then this routine will be faster than #'integration-QAGS.") ;;;;**************************************************************************** ;;;; QAGI adaptive integration on infinite intervals ;;;;**************************************************************************** -(defun-gsl integration-QAGi - (function limit workspace &optional (epsabs 1.0d0) (epsrel 1.0d0)) +(defmfun integration-QAGi + (function limit workspace &optional (absolute-error 1.0d0) (relative-error 1.0d0)) "gsl_integration_qagi" ((function :pointer) - (epsabs :double) (epsrel :double) (limit :size) (workspace :pointer) + (absolute-error :double) (relative-error :double) (limit size) (workspace :pointer) (result :double) (abserr :double)) - :documentation - "Compute the integral of the function @var{f} over the - infinite interval @math{(-\infty,+\infty)}. The integral is mapped onto the - semi-open interval @math{(0,1]} using the transformation @math{x = (1-t)/t}, + :documentation ; FDL + "Compute the integral of the function f over the + infinite interval (-\infty,+\infty). The integral is mapped onto the + semi-open interval (0,1] using the transformation x = (1-t)/t, \int_{-\infty}^{+\infty} dx \, f(x) = \int_0^1 dt \, (f((1-t)/t) + f(-(1-t)/t))/t^2. It is then integrated using the QAGS algorithm. The normal 21-point @@ -158,56 +161,56 @@ transformation can generate an integrable singularity at the origin. In this case a lower-order rule is more efficient.") -(defun-gsl integration-QAGiu - (function a limit workspace &optional (epsabs 1.0d0) (epsrel 1.0d0)) +(defmfun integration-QAGiu + (function a limit workspace &optional (absolute-error 1.0d0) (relative-error 1.0d0)) "gsl_integration_qagiu" ((function :pointer) (a :double) - (epsabs :double) (epsrel :double) (limit :size) (workspace :pointer) + (absolute-error :double) (relative-error :double) (limit size) (workspace :pointer) (result :double) (abserr :double)) - :documentation - "Compute the integral of the function @var{f} over the - semi-infinite interval @math{(a,+\infty)}. The integral is mapped onto the - semi-open interval @math{(0,1]} using the transformation @math{x = a + (1-t)/t}, - \int_{a}^{+\infty} dx \, f(x) = \int_0^1 dt \, f(a + (1-t)/t)/t^2 + :documentation ; FDL + "Compute the integral of the function f over the + semi-infinite interval (a,+\infty). The integral is mapped onto the + semi-open interval (0,1] using the transformation x = a + (1-t)/t, + int_{a}^{+\infty} dx, f(x) = \int_0^1 dt f(a + (1-t)/t)/t^2 and then integrated using the QAGS algorithm.") -(defun-gsl integration-QAGil - (function b limit workspace &optional (epsabs 1.0d0) (epsrel 1.0d0)) +(defmfun integration-QAGil + (function b limit workspace &optional (absolute-error 1.0d0) (relative-error 1.0d0)) "gsl_integration_qagil" ((function :pointer) (b :double) - (epsabs :double) (epsrel :double) (limit :size) (workspace :pointer) + (absolute-error :double) (relative-error :double) (limit size) (workspace :pointer) (result :double) (abserr :double)) - :documentation - "Compute the integral of the function @var{f} over the - semi-infinite interval @math{(-\infty,b)}. The integral is mapped onto the - semi-open interval @math{(0,1]} using the transformation @math{x = b - (1-t)/t}, - \int_{-\infty}^{b} dx \, f(x) = \int_0^1 dt \, f(b - (1-t)/t)/t^2 + :documentation ; FDL + "Compute the integral of the function f over the + semi-infinite interval (-\infty,b). The integral is mapped onto the + semi-open interval (0,1] using the transformation x = b - (1-t)/t, + \int_{-\infty}^{b} dx, f(x) = \int_0^1 dt, f(b - (1-t)/t)/t^2 and then integrated using the QAGS algorithm.") ;;;;**************************************************************************** ;;;; QAWC adaptive integration for Cauchy principal values ;;;;**************************************************************************** -(defun-gsl integration-QAWC - (function a b c limit workspace &optional (epsabs 1.0d0) (epsrel 1.0d0)) +(defmfun integration-QAWC + (function a b c limit workspace + &optional (absolute-error 1.0d0) (relative-error 1.0d0)) "gsl_integration_qawc" ((function :pointer) (a :double) (b :double) (c :double) - (epsabs :double) (epsrel :double) (limit :size) (workspace :pointer) + (absolute-error :double) (relative-error :double) (limit size) (workspace :pointer) (result :double) (abserr :double)) - :documentation + :documentation ; FDL "Compute the Cauchy principal value of the integral of - @math{f} over @math{(a,b)}, with a singularity at @var{c}, - I = \int_a^b dx\, {f(x) \over x - c} = \lim_{\epsilon \to 0} - \left\{\int_a^{c-\epsilon} dx\, {f(x) \over x - c} + - \int_{c+\epsilon}^b dx\, {f(x) \over x - c} \right\} + f over (a,b), with a singularity at c, + I = \int_a^b dx, {f(x)/x - c} = lim_{epsilon -> 0} + {\int_a^{c-epsilon} dx, {f(x)/x - c} + \int_{c+epsilon}^b dx, + {f(x) \over x - c}} The adaptive bisection algorithm of QAG is used, with modifications to - ensure that subdivisions do not occur at the singular point @math{x = c}. - When a subinterval contains the point @math{x = c} or is close to + ensure that subdivisions do not occur at the singular point x = c. + When a subinterval contains the point x = c or is close to it then a special 25-point modified Clenshaw-Curtis rule is used to control - the singularity. Further away from the - singularity the algorithm uses an ordinary 15-point Gauss-Kronrod - integration rule.") + the singularity. Further away from the singularity the algorithm + uses an ordinary 15-point Gauss-Kronrod integration rule.") ;;;;**************************************************************************** @@ -222,15 +225,28 @@ (defun-single two-sine (x) (sin (* mult x)))) |# -(lisp-unit:define-test numerical-integration - (lisp-unit:assert-first-fp-equal - "0.200000000000d+01" - (integration-qng one-sine 0.0d0 pi)) - (lisp-unit:assert-first-fp-equal - "0.200000000000d+01" - (letm ((ws (integration-workspace 20))) - (integration-QAG one-sine 0.0d0 pi :gauss15 20 ws))) - (lisp-unit:assert-error - 'gsl-error - (letm ((ws (integration-workspace 20))) - (integration-QAG one-sine 0.0d0 pi :gauss15 50 ws)))) +#| +(make-tests numerical-integration + (integration-qng one-sine 0.0d0 pi) + (letm ((ws (integration-workspace 20))) + (integration-QAG one-sine 0.0d0 pi :gauss15 20 ws)) + (letm ((ws (integration-workspace 20))) + (integration-QAG one-sine 0.0d0 pi :gauss15 50 ws))) +|# + +(LISP-UNIT:DEFINE-TEST NUMERICAL-INTEGRATION + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.0d0 2.220446049250313d-14 21) + (MULTIPLE-VALUE-LIST + (INTEGRATION-QNG ONE-SINE 0.0d0 PI))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.0d0 2.220446049250313d-14) + (MULTIPLE-VALUE-LIST + (LETM ((WS (INTEGRATION-WORKSPACE 20))) + (INTEGRATION-QAG ONE-SINE 0.0d0 PI :GAUSS15 20 + WS)))) + (LISP-UNIT:ASSERT-ERROR + 'GSL-ERROR + (LETM ((WS (INTEGRATION-WORKSPACE 20))) + (INTEGRATION-QAG ONE-SINE 0.0d0 PI :GAUSS15 50 WS)))) + diff --git a/ordinary-differential-equations/control.lisp b/ordinary-differential-equations/control.lisp index 6df8bd6c25df646fa9ed96e0e0a56bd3b629e4cc..8b8bf943580e078ee29b65f16ccf241fa9278979 100644 --- a/ordinary-differential-equations/control.lisp +++ b/ordinary-differential-equations/control.lisp @@ -1,128 +1,124 @@ -;******************************************************** -; file: control.lisp -; description: Adaptive step-size control -; date: Sat Sep 29 2007 - 18:51 -; author: Liam Healy -; modified: Sat Sep 29 2007 - 22:51 -;******************************************************** -;;; $Id: $ +;; Adaptive step-size control +;; Liam Healy 2008-02-17 17:30:04EST control.lisp +;; Time-stamp: <2008-02-17 17:41:02EST control.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl new-standard-control (absolute-error relative-error y dydt) +(defmfun new-standard-control (absolute-error relative-error y dydt) "gsl_odeiv_control_standard_new" - ((absolute-error :double) (relative-error :double) (y :double) (dydt :double)) + ((absolute-error :double) (relative-error :double) + (ay :double) (adydt :double)) :c-return (ptr :pointer) :return (ptr) - :documentation + :documentation ; FDL "The standard control object is a four parameter heuristic based on - absolute and relative errors @var{eps_absolute} and @var{eps_relative}, and - scaling factors @var{a_y} and @var{a_dydt} for the system state - @math{y(t)} and derivatives @math{y'(t)} respectively. + absolute and relative errors absolute-error and relative-error, and + scaling factors ay and adydt for the system state y(t) and derivatives + y'(t) respectively. The step-size adjustment procedure for this method begins by computing - the desired error level @math{D_i} for each component, - D_i = \epsilon_{absolute} + \epsilon_{relative} * (a_{y} |y_i| + a_{dydt} h |y'_i|) - and comparing it with the observed error @math{E_i = |yerr_i|}. If the - observed error @var{E} exceeds the desired error level @var{D} by more + the desired error level D_i for each component, + D_i = epsilon_{absolute} + epsilon_{relative} * (a_{y} |y_i| + a_{dydt} h |y'_i|) + and comparing it with the observed error E_i = |yerr_i|. If the + observed error E exceeds the desired error level D by more than 10% for any component then the method reduces the step-size by an appropriate factor, h_{new} = h_{old} * S * (E/D)^{-1/q} - where @math{q} is the consistency order of the method (e.g. @math{q=4} for - 4(5) embedded RK), and @math{S} is a safety factor of 0.9. The ratio - @math{E/D} is taken to be the maximum of the ratios @math{E_i/D_i}. + where g is the consistency order of the method (e.g. q=4 for + 4(5) embedded RK), and S is a safety factor of 0.9. The ratio + E/D is taken to be the maximum of the ratios E_i/D_i. - If the observed error @math{E} is less than 50% of the desired error - level @var{D} for the maximum ratio @math{E_i/D_i} then the algorithm + If the observed error E is less than 50% of the desired error + level D for the maximum ratio E_i/D_i then the algorithm takes the opportunity to increase the step-size to bring the error in line with the desired level, h_{new} = h_{old} * S * (E/D)^{-1/(q+1)} This encompasses all the standard error scaling methods. To avoid uncontrolled changes in the stepsize, the overall scaling factor is - limited to the range @math{1/5} to 5.") + limited to the range 1/5 to 5.") -(defun-gsl new-y-control (absolute-error relative-error) +(defmfun new-y-control (absolute-error relative-error) "gsl_odeiv_control_y_new" ((absolute-error :double) (relative-error :double)) :c-return (ptr :pointer) :return (ptr) - :documentation + :documentation ; FDL "Create a new control object which will keep the local - error on each step within an absolute error of @var{eps_absolute} and - relative error of @var{eps_relative} with respect to the solution @math{y_i(t)}. - This is equivalent to the standard control object with @var{a_y}=1 and - @var{a_dydt}=0.") + error on each step within an absolute error of absolute-error and + relative error of relative-error with respect to the solution y_i(t). + This is equivalent to the standard control object with ay=1 and + adydt=0.") -(defun-gsl new-yp-control (absolute-error relative-error) +(defmfun new-yp-control (absolute-error relative-error) "gsl_odeiv_control_yp_new" ((absolute-error :double) (relative-error :double)) :c-return (ptr :pointer) :return (ptr) - :documentation + :documentation ; FDL "Create a new control object which will keep the local - error on each step within an absolute error of @var{eps_absolute} and - relative error of @var{eps_relative} with respect to the derivatives of the - solution @math{y'_i(t)}. This is equivalent to the standard control - object with @var{a_y}=0 and @var{a_dydt}=1.") + error on each step within an absolute error of absolute-error and + relative error of relative-error with respect to the derivatives of the + solution y'_i(t). This is equivalent to the standard control + object with ay=0 and adydt=1.") -(defun-gsl new-scaled-control +(defmfun new-scaled-control (absolute-error relative-error y dydt absolute-scale dimension) "gsl_odeiv_control_scaled_new" ((absolute-error :double) (relative-error :double) (y :double) (dydt :double) - (absolute-scale :pointer) (dimension :size)) + (absolute-scale :pointer) (dimension size)) :c-return (ptr :pointer) :return (ptr) - :documentation + :documentation ; FDL "Create a new control object which uses the same algorithm - as @code{gsl_odeiv_control_standard_new} but with an absolute error - which is scaled for each component by the array @var{scale_abs}. - The formula for @math{D_i} for this control object is - D_i = \epsilon_{abs} s_i + \epsilon_{rel} * (a_{y} |y_i| + a_{dydt} h |y'_i|) - where @math{s_i} is the @math{i}-th component of the array @var{scale_abs}. - The same error control heuristic is used by the Matlab @sc{ode} suite.") + as #'new-standard-control but with an absolute error + which is scaled for each component by the array absolute-error. + The formula for D_i for this control object is + D_i = epsilon_{abs} s_i + epsilon_{rel} * (a_{y} |y_i| + a_{dydt} h |y'_i|) + where s_i is the i-th component of the array absolute-scale. + The same error control heuristic is used by the Matlab ode suite.") -(defun-gsl control-alloc (control-type) +(defmfun control-alloc (control-type) "gsl_odeiv_control_alloc" ((control-type :pointer)) :c-return (ptr :pointer) :return (ptr) - :documentation + :documentation ; FDL "Return a pointer to a newly allocated instance of a - control function of type @var{T}. This function is only needed for + control function of type control-type. This function is only needed for defining new types of control functions. For most purposes the standard control functions described above should be sufficient.") -(defun-gsl initialize-control +(defmfun initialize-control (control absolute-error relative-error y-scaling dydt-scaling) "gsl_odeiv_control_init" ((control :pointer) (absolute-error :double) (relative-error :double) (y-scaling :double) (dydt-scaling :double)) - :documentation - "Initialize the control function @var{control} with the + :documentation ; FDL + "Initialize the control function control with the parameters absolute-error, relative-error, y-scaling (scaling factor for y) and dydt-scaling (scaling factor for derivatives).") -(defun-gsl free-control (control) +(defmfun free-control (control) "gsl_odeiv_control_free" ((control :pointer)) :c-return :void - :documentation - "Free all the memory associated with the control function - @var{control}.") + :documentation ; FDL + "Free all the memory associated with the control function control.") (cffi:defcenum step-size-adjustment (:step-size-decreased -1) :step-size-unchanged :step-size-increased) -(defun-gsl adjust-stepsize (control stepper current-y y-error dydt step-size) +(defmfun adjust-stepsize (control stepper current-y y-error dydt step-size) "gsl_odeiv_control_hadjust" ((control :pointer) (stepper :pointer) (current-y :pointer) (y-error :pointer) (dydt :pointer) (step-size :pointer)) :c-return :enumerate :enumeration step-size-adjustment - :documentation - "Adjust the step-size @var{h} using the control function - and the current values of current-y, y-error and @var{dydt}. + :documentation ; FDL + "Adjust the step-size using the control function + and the current values of current-y, y-error and dydt. The stepping function stepper is also needed to determine the order of the method. If the error in the y-values y-error is found to be too large then the step-size is reduced and the function returns @@ -133,8 +129,9 @@ step-size which satisfies the user-specified accuracy requirements for the current point.") -(defun-gsl control-name (control) +(defmfun control-name (control) "gsl_odeiv_control_name" ((control :pointer)) :c-return :string - :documentation "The name of the control function.") + :documentation ; FDL + "The name of the control function.") diff --git a/ordinary-differential-equations/evolution.lisp b/ordinary-differential-equations/evolution.lisp index 82650ebfae67105e7765cd4bb7ee39738c544df9..b433a4e8dcd78d661db4fa5718db7bc067009bce 100644 --- a/ordinary-differential-equations/evolution.lisp +++ b/ordinary-differential-equations/evolution.lisp @@ -1,49 +1,45 @@ -;******************************************************** -; file: evolution.lisp -; description: Evolution functions for ODE integration. -; date: Sun Sep 30 2007 - 14:31 -; author: Liam Healy -; modified: Thu Oct 18 2007 - 22:18 -;******************************************************** -;;; $Id: $ +;; Evolution functions for ODE integration. +;; Liam Healy, Sun Sep 30 2007 - 14:31 +;; Time-stamp: <2008-02-17 17:43:24EST evolution.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl allocate-evolution (dimension) +(defmfun allocate-evolution (dimension) "gsl_odeiv_evolve_alloc" - ((dimension :size)) + ((dimension size)) :c-return :pointer - :documentation + :documentation ; FDL "Allocate a new instance of an evolution function for a system of dimension dimensions and return the pointer.") -(defun-gsl apply-evolution +(defmfun apply-evolution (evolve control step dydt time max-time step-size y) "gsl_odeiv_evolve_apply" ((evolve :pointer) (control :pointer) (step :pointer) (dydt :pointer) (time :pointer) (max-time :double) (step-size :pointer) (y :pointer)) - :documentation - "Advance the system (@var{e}, @var{dydt}) from time - @var{t} and position @var{y} using the stepping function @var{step}. - The new time and position are stored in @var{time} and @var{y} on output. - The initial step-size is taken as @var{step-size}, but this will be modified - using the control function @var{c} to achieve the appropriate error - bound if necessary. The routine may make several calls to @var{step} in + :documentation ; FDL + "Advance the system (e, dydt) from time + and position y using the stepping function step. + The new time and position are stored in time and y on output. + The initial step-size supplied, but this will be modified + using the control function to achieve the appropriate error + bound if necessary. The routine may make several calls to step in order to determine the optimum step-size. If the step-size has been - changed the value of @var{h} will be modified on output. The maximum - time @var{max-time} is guaranteed not to be exceeded by the time-step. On the - final time-step the value of @var{time} will be set to @var{t1} exactly.") + changed the value of step-size will be modified on output. The maximum + time max-time is guaranteed not to be exceeded by the time-step. On the + final time-step the value of time will be set to t1 exactly.") -(defun-gsl reset-evolution (evolve) +(defmfun reset-evolution (evolve) "gsl_odeiv_evolve_reset" ((evolve :pointer)) :documentation - "Reset the evolution function @var{evolve}. It should be used - whenever the next use of @var{evolve} will not be a continuation of a + "Reset the evolution function evolve. It should be used + whenever the next use of evolve will not be a continuation of a previous step.") -(defun-gsl free-evolution (evolve) +(defmfun free-evolution (evolve) "gsl_odeiv_evolve_free" ((evolve :pointer)) :c-return :void diff --git a/ordinary-differential-equations/ode-system.lisp b/ordinary-differential-equations/ode-system.lisp index ad3b40433b6939130571a96103ae4da867977a47..807e9a19149662a2244bdc5388ef4d18eac728f8 100644 --- a/ordinary-differential-equations/ode-system.lisp +++ b/ordinary-differential-equations/ode-system.lisp @@ -1,6 +1,6 @@ ;; ODE system setup ;; Liam Healy, Sun Apr 15 2007 - 14:19 -;; Time-stamp: <2008-01-28 22:21:08EST ode-system.lisp> +;; Time-stamp: <2008-02-17 17:25:09EST ode-system.lisp> ;; $Id: $ (in-package :gsl) @@ -10,7 +10,7 @@ "The definition of an ordinary differential equation system for GSL." (function :pointer) (jacobian :pointer) - (dimension :size) + (dimension size) (parameters :pointer)) (export '(def-ode-functions with-ode-integration)) diff --git a/ordinary-differential-equations/stepping.lisp b/ordinary-differential-equations/stepping.lisp index 60082a1bbd11f0a49c5b1302508b3f64e90787de..2b2fe98a83a980e5100d7e36623784dc6fd58c80 100644 --- a/ordinary-differential-equations/stepping.lisp +++ b/ordinary-differential-equations/stepping.lisp @@ -1,52 +1,50 @@ -;******************************************************** -; file: stepping.lisp -; description: Stepping functions for ODE systems -; date: Mon Sep 24 2007 - 21:33 -; author: Liam Healy -; modified: Sun Nov 4 2007 - 17:54 -;******************************************************** -;;; $Id: $ +;; Stepping functions for ODE systems. +;; Liam Healy, Mon Sep 24 2007 - 21:33 +;; Time-stamp: <2008-02-17 17:29:49EST stepping.lisp> +;; $Id: $ (in-package :gsl) -(defun-gsl step-allocate (step-type dim) +(defmfun step-allocate (step-type dim) "gsl_odeiv_step_alloc" - ((step-type :pointer) (dim :size)) + ((step-type :pointer) (dim size)) :c-return :pointer - :documentation + :documentation ; FDL "Allocate a new instance of a stepping function of - type @var{T} for a system of @var{dim} dimensions, + type step-type for a system of dim dimensions, returning the pointer.") -(defun-gsl step-reset (stepper) +(defmfun step-reset (stepper) "gsl_odeiv_step_reset" ((stepper :pointer)) - :documentation - "Reset the stepping function @var{s}. It should be used whenever - the next use of @var{s} will not be a continuation of a previous + :documentation ; FDL + "Reset the stepping function. It should be used whenever + the next use of it will not be a continuation of a previous step.") -(defun-gsl step-free (stepper) +(defmfun step-free (stepper) "gsl_odeiv_step_free" ((stepper :pointer)) :c-return :void - :documentation + :documentation ; FDL "Free all the memory associated with the stepping function.") -(defun-gsl step-name (stepper) +(defmfun step-name (stepper) "gsl_odeiv_step_name" ((stepper :pointer)) :c-return :string - :documentation "The name of the stepping function.") + :documentation ; FDL + "The name of the stepping function.") -(defun-gsl step-order (stepper) +(defmfun step-order (stepper) "gsl_odeiv_step_order" ((stepper :pointer)) :c-return :uint - :documentation "The order of the stepping function on the previous + :documentation ; FDL + "The order of the stepping function on the previous step, which can vary if the stepping function itself is adaptive.") -(defun-gsl step-apply +(defmfun step-apply (stepper time step-size y yerr dydt-in dydt-out dydt) "gsl_odeiv_step_apply" ((stepper :pointer) @@ -57,55 +55,60 @@ (dydt-in :pointer) (dydt-out :pointer) (dydt :pointer)) - :documentation + :documentation ; FDL "Apply the stepping function stepper to the system of - equations defined by @var{dydt}, using the step size step-size to advance - the system from time @var{t} and state @var{y} to time @var{t}+@var{h}. - The new state of the system is stored in @var{y} on output, with an - estimate of the absolute error in each component stored in @var{yerr}. - If the argument @var{dydt_in} is not null it should point an array - containing the derivatives for the system at time @var{t} on input. This + equations defined by dydt, using the step size step-size to advance + the system from time time and state y to time t+h. + The new state of the system is stored in y on output, with an + estimate of the absolute error in each component stored in yerr + If the argument dydt_in is not null it should point an array + containing the derivatives for the system at time t on input. This is optional as the derivatives will be computed internally if they are not provided, but allows the reuse of existing derivative information. - On output the new derivatives of the system at time @var{t}+@var{h} will - be stored in @var{dydt_out} if it is not null. - - If the user-supplied functions defined in the system @var{dydt} return a - status other than @code{GSL_SUCCESS} the step will be aborted. In this - case, the elements of @var{y} will be restored to their pre-step values - and the error code from the user-supplied function will be returned. To - distinguish between error codes from the user-supplied functions and - those from @code{gsl_odeiv_step_apply} itself, any user-defined return - values should be distinct from the standard GSL error codes.") - -(defvariable *step-rk2* "gsl_odeiv_step_rk2" + On output the new derivatives of the system at time t+h will + be stored in dydt-out if it is not null. + + User-supplied functions defined in the system dydt + should signal an error or return the correct value.") + +(defmpar *step-rk2* "gsl_odeiv_step_rk2" + ;; FDL "Embedded Runge-Kutta (2, 3) method.") -(defvariable *step-rk4* "gsl_odeiv_step_rk4" +(defmpar *step-rk4* "gsl_odeiv_step_rk4" + ;; FDL "4th order (classical) Runge-Kutta.") -(defvariable *step-rkf45* "gsl_odeiv_step_rkf45" +(defmpar *step-rkf45* "gsl_odeiv_step_rkf45" + ;; FDL "Embedded Runge-Kutta-Fehlberg (4, 5) method. This method is a good general-purpose integrator.") -(defvariable *step-rkck* "gsl_odeiv_step_rkck" +(defmpar *step-rkck* "gsl_odeiv_step_rkck" + ;; FDL "Embedded Runge-Kutta Cash-Karp (4, 5) method.") -(defvariable *step-rk8pd* "gsl_odeiv_step_rk8pd" +(defmpar *step-rk8pd* "gsl_odeiv_step_rk8pd" + ;; FDL "Embedded Runge-Kutta Prince-Dormand (8,9) method.") -(defvariable *step-rk2imp* "gsl_odeiv_step_rk2imp" +(defmpar *step-rk2imp* "gsl_odeiv_step_rk2imp" + ;; FDL "Implicit 2nd order Runge-Kutta at Gaussian points.") -(defvariable *step-rk4imp* "gsl_odeiv_step_rk4imp" +(defmpar *step-rk4imp* "gsl_odeiv_step_rk4imp" + ;; FDL "Implicit 4th order Runge-Kutta at Gaussian points.") -(defvariable *step-bsimp* "gsl_odeiv_step_bsimp" +(defmpar *step-bsimp* "gsl_odeiv_step_bsimp" + ;; FDL "Implicit Bulirsch-Stoer method of Bader and Deuflhard. This algorithm requires the Jacobian.") -(defvariable *step-gear1* "gsl_odeiv_step_gear1" +(defmpar *step-gear1* "gsl_odeiv_step_gear1" + ;; FDL "M=1 implicit Gear method.") -(defvariable *step-gear2* "gsl_odeiv_step_gear2" +(defmpar *step-gear2* "gsl_odeiv_step_gear2" + ;; FDL "M=2 implicit Gear method.") diff --git a/polynomial.lisp b/polynomial.lisp index 8b633f5f7439fe72ab980e3d7c2c1e97fca8947d..f28af3c33dae5564392909f89d23471fbe0c7012 100644 --- a/polynomial.lisp +++ b/polynomial.lisp @@ -1,6 +1,6 @@ ;; Polynomials ;; Liam Healy, Tue Mar 21 2006 - 18:33 -;; Time-stamp: <2008-02-16 11:17:51EST polynomial.lisp> +;; Time-stamp: <2008-02-17 08:49:41EST polynomial.lisp> ;; $Id: $ (in-package :gsl) @@ -12,9 +12,9 @@ ;;;; Polynomial Evaluation ;;;;**************************************************************************** -(defun-gsl polynomial-eval (coefficients x) +(defmfun polynomial-eval (coefficients x) "gsl_poly_eval" - (((gsl-array coefficients) :pointer) ((dim0 coefficients) :size) (x :double)) + (((gsl-array coefficients) :pointer) ((dim0 coefficients) size) (x :double)) :documentation ; FDL "Evaluate the polyonomial with coefficients at the point x." :c-return :double) @@ -23,11 +23,11 @@ ;;;; Divided Difference Representation of Polynomials ;;;;**************************************************************************** -(defun-gsl divided-difference-int (dd xa ya) +(defmfun divided-difference-int (dd xa ya) "gsl_poly_dd_init" (((gsl-array dd) :pointer) ((gsl-array xa) :pointer) ((gsl-array ya) :pointer) - ((dim0 xa) :size)) + ((dim0 xa) size)) :return (dd) :export nil :index divided-difference) @@ -46,24 +46,24 @@ (make-data 'vector-double nil (length xa)) xad yad))) -(defun-gsl polynomial-eval-divided-difference (dd xa x) +(defmfun polynomial-eval-divided-difference (dd xa x) "gsl_poly_dd_eval" (((gsl-array dd) :pointer) ((gsl-array xa) :pointer) - ((dim0 xa) :size) + ((dim0 xa) size) (x :double)) :c-return :double :documentation ; FDL "Evaluate the polynomial stored in divided-difference form in the arrays dd and xa at the point x.") -(defun-gsl taylor-divided-difference (coefs xp dd xa workspace) +(defmfun taylor-divided-difference (coefs xp dd xa workspace) "gsl_poly_dd_taylor" (((gsl-array coefs) :pointer) (xp :double) ((gsl-array dd) :pointer) ((gsl-array xa) :pointer) - ((dim0 xa) :size) + ((dim0 xa) size) ((gsl-array workspace) :pointer)) :invalidate (coefs) :documentation ; FDL @@ -78,7 +78,7 @@ ;;;; Quadratic Equations ;;;;**************************************************************************** -(defun-gsl solve-quadratic (a b c) +(defmfun solve-quadratic (a b c) "gsl_poly_solve_quadratic" ((a :double) (b :double) (c :double) (root1 :double) (root2 :double)) :c-return :number-of-answers @@ -87,7 +87,7 @@ Two values are always returned; if the roots are not real, these values are NIL.") -(defun-gsl solve-quadratic-complex (a b c) +(defmfun solve-quadratic-complex (a b c) "gsl_poly_complex_solve_quadratic" ((a :double) (b :double) (c :double) (root1 gsl-complex) (root2 gsl-complex)) :c-return :number-of-answers @@ -100,7 +100,7 @@ ;;;; Cubic Equations ;;;;**************************************************************************** -(defun-gsl solve-cubic (a b c) +(defmfun solve-cubic (a b c) "gsl_poly_solve_cubic" ((a :double) (b :double) (c :double) (root1 :double) (root2 :double) (root3 :double)) @@ -111,7 +111,7 @@ in ascending order. Three values are always returned; if a root is not real, the value returned for it will be NIL.") -(defun-gsl solve-cubic-complex (a b c) +(defmfun solve-cubic-complex (a b c) "gsl_poly_complex_solve_cubic" ((a :double) (b :double) (c :double) (root1 gsl-complex) (root2 gsl-complex) (root3 gsl-complex)) @@ -128,13 +128,13 @@ (defgo-s (complex-workspace n) allocate-complex-workspace free-complex-workspace) -(defun-gsl allocate-complex-workspace (n) - "gsl_poly_complex_workspace_alloc" ((n :size)) +(defmfun allocate-complex-workspace (n) + "gsl_poly_complex_workspace_alloc" ((n size)) :c-return :pointer :export nil :index (letm complex-workspace)) -(defun-gsl free-complex-workspace (ws) +(defmfun free-complex-workspace (ws) "gsl_poly_complex_workspace_free" ((ws :pointer)) :c-return :void :export nil @@ -156,9 +156,9 @@ (ws (complex-workspace len))) (values-list (polynomial-solve-ws coef ws answer))))) -(defun-gsl polynomial-solve-ws (coefficients workspace answer-pd) +(defmfun polynomial-solve-ws (coefficients workspace answer-pd) "gsl_poly_complex_solve" - (((gsl-array coefficients) :pointer) ((dim0 coefficients) :size) + (((gsl-array coefficients) :pointer) ((dim0 coefficients) size) (workspace :pointer) ((gsl-array answer-pd) :pointer)) :return ((loop for i from 0 below (dim0 answer-pd) by 2 @@ -175,35 +175,53 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test polynomial - (lisp-unit:assert-first-fp-equal - "0.200000000000d+01" - (letm ((vec (vector-double #(1.0d0 2.0d0 3.0d0)))) - (polynomial-eval vec -1.0d0))) - (lisp-unit:assert-equal - '(NIL NIL) - (multiple-value-list (solve-quadratic 1.0d0 0.0d0 1.0d0))) - (lisp-unit:assert-equal - '(1.0d0 1.0d0) - (multiple-value-list (solve-quadratic 1.0d0 -2.0d0 1.0d0))) - (lisp-unit:assert-equal - '(#C(1.0d0 0.0d0) #C(1.0d0 0.0d0)) - (multiple-value-list (solve-quadratic-complex 1.0d0 -2.0d0 1.0d0))) - (lisp-unit:assert-equal - '("-0.300000000000d+01" "0.200000000000d+01" "0.700000000000d+01") - (lisp-unit:fp-values (solve-cubic -6.0d0 -13.0d0 42.0d0))) - ;; This should use double-float-unequal - (lisp-unit:assert-equal - '(("0.000000000000d+01" "-1.000000000000d+00") - ("0.000000000000d+01" "1.000000000000d+00") - ("0.100000000000d+01" "0.000000000000d+01")) - (lisp-unit:fp-values (solve-cubic-complex -1.0d0 1.0d0 -1.0d0))) - (lisp-unit:assert-equal - '(("-0.809016994375d+00" "0.587785252292d+00") - ("-0.809016994375d+00" "-0.587785252292d+00") - ("0.309016994375d+00" "0.951056516295d+00") - ("0.309016994375d+00" "-0.951056516295d+00") - ("0.100000000000d+01" "0.000000000000d+01")) - ;; Example from GSL manual - (lisp-unit:fp-values - (polynomial-solve #(-1.0d0 0.0d0 0.0d0 0.0d0 0.0d0 1.0d0))))) +#| +(make-tests polynomial + (letm ((vec (vector-double #(1.0d0 2.0d0 3.0d0)))) + (polynomial-eval vec -1.0d0)) + (solve-quadratic 1.0d0 0.0d0 1.0d0) + (solve-quadratic 1.0d0 -2.0d0 1.0d0) + (solve-quadratic-complex 1.0d0 -2.0d0 1.0d0) + (solve-cubic -6.0d0 -13.0d0 42.0d0) + (solve-cubic-complex -1.0d0 1.0d0 -1.0d0) + ;; Example from GSL manual + (polynomial-solve #(-1.0d0 0.0d0 0.0d0 0.0d0 0.0d0 1.0d0))) +|# + +(LISP-UNIT:DEFINE-TEST POLYNOMIAL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0)))) + (POLYNOMIAL-EVAL VEC -1.0d0)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST) (LIST)) + (MULTIPLE-VALUE-LIST + (SOLVE-QUADRATIC 1.0d0 0.0d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0d0 1.0d0) + (MULTIPLE-VALUE-LIST (SOLVE-QUADRATIC 1.0d0 -2.0d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #C(1.0d0 0.0d0) #C(1.0d0 0.0d0)) + (MULTIPLE-VALUE-LIST + (SOLVE-QUADRATIC-COMPLEX 1.0d0 -2.0d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST -3.000000000000001d0 1.9999999999999996d0 + 7.000000000000001d0) + (MULTIPLE-VALUE-LIST + (SOLVE-CUBIC -6.0d0 -13.0d0 42.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #C(-5.551115123125783d-17 -0.9999999999999999d0) + #C(-5.551115123125783d-17 0.9999999999999999d0) + #C(1.0d0 0.0d0)) + (MULTIPLE-VALUE-LIST + (SOLVE-CUBIC-COMPLEX -1.0d0 1.0d0 -1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #C(-0.8090169943749477d0 0.5877852522924734d0) + #C(-0.8090169943749477d0 -0.5877852522924734d0) + #C(0.3090169943749475d0 0.951056516295153d0) + #C(0.3090169943749475d0 -0.951056516295153d0) + #C(0.9999999999999999d0 0.0d0)) + (MULTIPLE-VALUE-LIST + (POLYNOMIAL-SOLVE + #(-1.0d0 0.0d0 0.0d0 0.0d0 0.0d0 1.0d0))))) diff --git a/random/bernoulli.lisp b/random/bernoulli.lisp index ed9e8a0f4b1a867af72ffeea87304195d59e1044..5d6ecf3b4a5d1887a7038ccb4753a8e8349db726 100644 --- a/random/bernoulli.lisp +++ b/random/bernoulli.lisp @@ -1,11 +1,11 @@ ;; Bernoulli distribution ;; Liam Healy, Sat Nov 25 2006 - 16:59 -;; Time-stamp: <2008-02-03 11:16:35EST bernoulli.lisp> +;; Time-stamp: <2008-02-17 13:39:15EST bernoulli.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl bernoulli (generator p) +(defmfun bernoulli (generator p) "gsl_ran_bernoulli" (((generator generator) :pointer) (p :double)) :c-return :uint @@ -16,7 +16,7 @@ p(0) = 1 - p p(1) = p.") -(defun-gsl bernoulli-pdf (k p) +(defmfun bernoulli-pdf (k p) "gsl_ran_bernoulli_pdf" ((k :uint) (p :double)) :c-return :double :documentation ; FDL @@ -25,13 +25,23 @@ p, using the formula given in #'bernoulli.") ;;; Examples and unit test -(lisp-unit:define-test bernoulli - (lisp-unit:assert-equal - '(0 1 1 0 1 1 0 0 0 0 0) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests bernoulli + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (bernoulli rng 0.5d0)))) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (bernoulli-pdf 0 0.5d0))) + (bernoulli rng 0.5d0))) + (bernoulli-pdf 0 0.5d0)) +|# + +(LISP-UNIT:DEFINE-TEST BERNOULLI + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 0 1 1 0 1 1 0 0 0 0 0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (BERNOULLI RNG 0.5d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5d0) + (MULTIPLE-VALUE-LIST (BERNOULLI-PDF 0 0.5d0)))) + diff --git a/random/beta.lisp b/random/beta.lisp index d71a1747d5bd61b57a7b13a8d921a440be7b6f83..adb1a77e420f58e8bc24d1452f3ea9dcdc58ec96 100644 --- a/random/beta.lisp +++ b/random/beta.lisp @@ -1,11 +1,11 @@ ;; Beta distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 09:52:01EST beta.lisp> +;; Time-stamp: <2008-02-17 13:18:37EST beta.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl beta-rd (generator a b) +(defmfun beta-rd (generator a b) ;; Named #'beta-rd to avoid confusion with the special function #'beta. "gsl_ran_beta" (((generator generator) :pointer) (a :double) (b :double)) @@ -15,7 +15,7 @@ p(x) dx = {\Gamma(a+b) \over \Gamma(a) \Gamma(b)} x^{a-1} (1-x)^{b-1} dx 0 <= x <= 1.") -(defun-gsl beta-pdf (x a b) +(defmfun beta-pdf (x a b) "gsl_ran_beta_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -23,28 +23,28 @@ for a beta distribution with parameters a and b, using the formula given in #'beta.") -(defun-gsl beta-P (x a b) +(defmfun beta-P (x a b) "gsl_cdf_beta_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the beta distribution with parameters a and b.") -(defun-gsl beta-Q (x a b) +(defmfun beta-Q (x a b) "gsl_cdf_beta_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the beta distribution with parameters a and b.") -(defun-gsl beta-Pinv (P a b) +(defmfun beta-Pinv (P a b) "gsl_cdf_beta_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the beta distribution with parameters a and b.") -(defun-gsl beta-Qinv (Q a b) +(defmfun beta-Qinv (Q a b) "gsl_cdf_beta_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -52,29 +52,45 @@ Q(x) for the beta distribution with parameters a and b.") ;;; Examples and unit test -(lisp-unit:define-test beta - (lisp-unit:assert-equal - '("0.839000941902d-04" "0.242116468139d-01" "0.455077134726d-01" - "0.303211445340d+00" "0.569357215111d+00" "0.514651520667d+00" - "0.230096194773d+00" "0.392834882565d+00" "0.514387412254d+00" - "0.233783685805d+00" "0.198512886686d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests beta + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (beta-rd rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.180000000000d+01" - (beta-pdf 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.190000000000d+00" - (beta-P 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.810000000000d+00" - (beta-Q 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "1.000000000000d-01" - (beta-Pinv 0.19d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "1.000000000000d-01" - (beta-Qinv 0.81d0 1.0d0 2.0d0))) + (beta-rd rng 1.0d0 2.0d0))) + (beta-pdf 0.1d0 1.0d0 2.0d0) + (beta-P 0.1d0 1.0d0 2.0d0) + (beta-Q 0.1d0 1.0d0 2.0d0) + (beta-Pinv 0.19d0 1.0d0 2.0d0) + (beta-Qinv 0.81d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST BETA + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 8.390009419017379d-5 0.024211646813900284d0 + 0.045507713472575685d0 0.30321144534029304d0 + 0.5693572151110255d0 0.5146515206667992d0 + 0.230096194772543d0 0.3928348825648452d0 + 0.5143874122537551d0 0.2337836858050161d0 + 0.19851288668620246d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (BETA-RD RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.8000000000000016d0) + (MULTIPLE-VALUE-LIST (BETA-PDF 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.19000000000000017d0) + (MULTIPLE-VALUE-LIST (BETA-P 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.8099999999999998d0) + (MULTIPLE-VALUE-LIST (BETA-Q 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.09999999999999988d0) + (MULTIPLE-VALUE-LIST (BETA-PINV 0.19d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.09999999999999987d0) + (MULTIPLE-VALUE-LIST (BETA-QINV 0.81d0 1.0d0 2.0d0)))) + diff --git a/random/binomial.lisp b/random/binomial.lisp index f214d0266990e73af86e39ba4d7f40aa356b7ac7..a6dbbe38c599926b2a3eff52755bd2ff50036a2c 100644 --- a/random/binomial.lisp +++ b/random/binomial.lisp @@ -1,11 +1,11 @@ ;; Binomial distribution ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 11:25:08EST binomial.lisp> +;; Time-stamp: <2008-02-17 13:46:01EST binomial.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl binomial (generator p n) +(defmfun binomial (generator p n) "gsl_ran_binomial" (((generator generator) :pointer) (p :double) (n :uint)) :c-return :uint @@ -16,7 +16,7 @@ p(k) = {n! \over k! (n-k)!} p^k (1-p)^{n-k} 0 <= k <= n.") -(defun-gsl binomial-pdf (k p n) +(defmfun binomial-pdf (k p n) "gsl_ran_binomial_pdf" ((k :uint) (p :double) (n :uint)) :c-return :double :documentation ; FDL @@ -24,14 +24,14 @@ from a binomial distribution with parameters p and n, using the formula given in #'binomial.") -(defun-gsl binomial-P (k p n) +(defmfun binomial-P (k p n) "gsl_cdf_binomial_P" ((k :uint) (p :double) (n :uint)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(k) for the Binomial distribution with parameters p and n.") -(defun-gsl binomial-Q (k p n) +(defmfun binomial-Q (k p n) "gsl_cdf_binomial_Q" ((k :uint) (p :double) (n :uint)) :c-return :double :documentation ; FDL @@ -40,19 +40,31 @@ with parameters p and n.") ;;; Examples and unit test -(lisp-unit:define-test binomial - (lisp-unit:assert-equal - '(11 3 4 8 4 5 8 6 5 6 6) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests binomial + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (binomial rng 0.4d0 12)))) - (lisp-unit:assert-first-fp-equal - "0.227030335488d+00" - (binomial-pdf 5 0.4d0 12)) - (lisp-unit:assert-first-fp-equal - "0.665208557568d+00" - (binomial-P 5 0.4d0 12)) - (lisp-unit:assert-first-fp-equal - "0.334791442432d+00" - (binomial-Q 5 0.4d0 12))) + (binomial rng 0.4d0 12))) + (binomial-pdf 5 0.4d0 12) + (binomial-P 5 0.4d0 12) + (binomial-Q 5 0.4d0 12)) +|# + +(LISP-UNIT:DEFINE-TEST BINOMIAL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 11 3 4 8 4 5 8 6 5 6 6)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (BINOMIAL RNG 0.4d0 12))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.22703033548799986d0) + (MULTIPLE-VALUE-LIST (BINOMIAL-PDF 5 0.4d0 12))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6652085575680018d0) + (MULTIPLE-VALUE-LIST (BINOMIAL-P 5 0.4d0 12))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.33479144243199815d0) + (MULTIPLE-VALUE-LIST (BINOMIAL-Q 5 0.4d0 12)))) + diff --git a/random/cauchy.lisp b/random/cauchy.lisp index e05cdfbc3a143d6d06df562ed17383b62ac62125..aefa9671cd56ad71f54158976ae308f8e8212b9a 100644 --- a/random/cauchy.lisp +++ b/random/cauchy.lisp @@ -1,11 +1,11 @@ ;; Cauchy distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 11:02:19EST cauchy.lisp> +;; Time-stamp: <2008-02-17 12:55:30EST cauchy.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl cauchy (generator a) +(defmfun cauchy (generator a) "gsl_ran_cauchy" (((generator generator) :pointer) (a :double)) :c-return :double @@ -17,7 +17,7 @@ for x in the range -\infty to +\infty. The Cauchy distribution is also known as the Lorentz distribution.") -(defun-gsl cauchy-pdf (x a) +(defmfun cauchy-pdf (x a) "gsl_ran_cauchy_pdf" ((x :double) (a :double)) :c-return :double :documentation ; FDL @@ -25,28 +25,28 @@ for a Cauchy distribution with scale parameter a, using the formula given for #'cauchy.") -(defun-gsl cauchy-P (x a) +(defmfun cauchy-P (x a) "gsl_cdf_cauchy_P" ((x :double) (a :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the Cauchy distribution with scale parameter a.") -(defun-gsl cauchy-Q (x a) +(defmfun cauchy-Q (x a) "gsl_cdf_cauchy_Q" ((x :double) (a :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the Cauchy distribution with scale parameter a.") -(defun-gsl cauchy-Pinv (P a) +(defmfun cauchy-Pinv (P a) "gsl_cdf_cauchy_Pinv" ((P :double) (a :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the Cauchy distribution with scale parameter a.") -(defun-gsl cauchy-Qinv (Q a) +(defmfun cauchy-Qinv (Q a) "gsl_cdf_cauchy_Qinv" ((Q :double) (a :double)) :c-return :double :documentation ; FDL @@ -54,29 +54,46 @@ Q(x) for the Cauchy distribution with scale parameter a.") ;;; Examples and unit test -(lisp-unit:define-test cauchy - (lisp-unit:assert-equal - '("-0.811319915595d-02" "0.561719641059d+01" "0.122923698289d+02" - "-0.167410883578d+01" "0.890910448626d+01" "0.211676586154d+03" - "-0.134390491844d+01" "-0.103643632829d+02" "-0.790709314248d+02" - "-0.106520710880d+02" "-0.939394824349d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests cauchy + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (cauchy rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.318309886184d-01" - (cauchy-pdf 0.0d0 10.0d0)) - (lisp-unit:assert-first-fp-equal - "0.647583617650d+00" - (cauchy-P 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.352416382350d+00" - (cauchy-Q 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "1.000000000000d+00" - (cauchy-Pinv 0.6475836176504333d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (cauchy-Qinv 0.35241638234956674d0 2.0d0))) + (cauchy rng 10.0d0))) + (cauchy-pdf 0.0d0 10.0d0) + (cauchy-P 1.0d0 2.0d0) + (cauchy-Q 1.0d0 2.0d0) + (cauchy-Pinv 0.6475836176504333d0 2.0d0) + (cauchy-Qinv 0.35241638234956674d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST CAUCHY + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST -0.00811319915595434d0 5.617196410586812d0 + 12.292369828923075d0 -1.6741088357812182d0 + 8.909104486260928d0 211.6765861544609d0 + -1.3439049184367153d0 -10.364363282910663d0 + -79.0709314248171d0 -10.652071087998578d0 + -9.393948243493877d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (CAUCHY RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.03183098861837907d0) + (MULTIPLE-VALUE-LIST (CAUCHY-PDF 0.0d0 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6475836176504333d0) + (MULTIPLE-VALUE-LIST (CAUCHY-P 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.35241638234956674d0) + (MULTIPLE-VALUE-LIST (CAUCHY-Q 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9999999999999998d0) + (MULTIPLE-VALUE-LIST + (CAUCHY-PINV 0.6475836176504333d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0000000000000002d0) + (MULTIPLE-VALUE-LIST + (CAUCHY-QINV 0.35241638234956674d0 2.0d0)))) diff --git a/random/chi-squared.lisp b/random/chi-squared.lisp index 1ae331d4a973f3711d3c4201374ffd1f23157a3f..6a392512da49543c5567e2c6ff41c0159e5532c1 100644 --- a/random/chi-squared.lisp +++ b/random/chi-squared.lisp @@ -1,11 +1,11 @@ ;; Chi-squared distribution ;; Liam Healy, Sat Oct 7 2006 - 16:13 -;; Time-stamp: <2008-02-03 10:23:21EST chi-squared.lisp> +;; Time-stamp: <2008-02-17 13:12:43EST chi-squared.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl chi-squared (generator nu) +(defmfun chi-squared (generator nu) "gsl_ran_chisq" (((generator generator) :pointer) (nu :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = {1 \over 2 \Gamma(\nu/2) } (x/2)^{\nu/2 - 1} \exp(-x/2) dx x >= 0. ") -(defun-gsl chi-squared-pdf (x nu) +(defmfun chi-squared-pdf (x nu) "gsl_ran_chisq_pdf" ((x :double) (nu :double)) :c-return :double :documentation ; FDL @@ -23,28 +23,28 @@ for a chi-squared distribution with nu degrees of freedom, using the formula given in #'chi-squared.") -(defun-gsl chi-squared-P (x nu) +(defmfun chi-squared-P (x nu) "gsl_cdf_chisq_P" ((x :double) (nu :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the chi-squared distribution with nu degrees of freedom.") -(defun-gsl chi-squared-Q (x nu) +(defmfun chi-squared-Q (x nu) "gsl_cdf_chisq_Q" ((x :double) (nu :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the chi-squared distribution with nu degrees of freedom.") -(defun-gsl chi-squared-Pinv (P nu) +(defmfun chi-squared-Pinv (P nu) "gsl_cdf_chisq_Pinv" ((P :double) (nu :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the chi-squared distribution with nu degrees of freedom.") -(defun-gsl chi-squared-Qinv (Q nu) +(defmfun chi-squared-Qinv (Q nu) "gsl_cdf_chisq_Qinv" ((Q :double) (nu :double)) :c-return :double :documentation ; FDL @@ -52,29 +52,47 @@ Q(x) for the chi-squared distribution with nu degrees of freedom.") ;;; Examples and unit test -(lisp-unit:define-test chi-squared - (lisp-unit:assert-equal - '("0.919043905723d+01" "0.395938453123d+01" "0.543493338508d+01" - "0.130231074199d+02" "0.136706908417d+02" "0.698235971535d+01" - "0.137566397216d+02" "0.113594580454d+02" "0.160682825906d+02" - "0.129995142525d+02" "0.111473474244d+02") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests chi-squared + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (chi-squared rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.439391289468d+00" - (chi-squared-pdf 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.520499877813d+00" - (chi-squared-P 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.479500122187d+00" - (chi-squared-Q 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (chi-squared-Pinv 0.5204998778130463d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (chi-squared-Qinv 0.4795001221869537d0 1.0d0))) + (chi-squared rng 10.0d0))) + (chi-squared-pdf 0.5d0 1.0d0) + (chi-squared-P 0.5d0 1.0d0) + (chi-squared-Q 0.5d0 1.0d0) + (chi-squared-Pinv 0.5204998778130463d0 1.0d0) + (chi-squared-Qinv 0.4795001221869537d0 1.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST CHI-SQUARED + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 9.190439057230117d0 3.9593845312309113d0 + 5.434933385075541d0 13.023107419896268d0 + 13.670690841729192d0 6.982359715352029d0 + 13.75663972164132d0 11.359458045417648d0 + 16.06828259064875d0 12.999514252538129d0 + 11.147347424355443d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (CHI-SQUARED RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.43939128946772227d0) + (MULTIPLE-VALUE-LIST (CHI-SQUARED-PDF 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5204998778130462d0) + (MULTIPLE-VALUE-LIST (CHI-SQUARED-P 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.4795001221869538d0) + (MULTIPLE-VALUE-LIST (CHI-SQUARED-Q 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5000000000000003d0) + (MULTIPLE-VALUE-LIST + (CHI-SQUARED-PINV 0.5204998778130463d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5000000000000003d0) + (MULTIPLE-VALUE-LIST + (CHI-SQUARED-QINV 0.4795001221869537d0 1.0d0)))) + diff --git a/random/dirichlet.lisp b/random/dirichlet.lisp index 86bec3be5585d5bbc3602610da07706d3e230084..055b240b39ec4422bfb9385d2fbe3d7b4559c4d5 100644 --- a/random/dirichlet.lisp +++ b/random/dirichlet.lisp @@ -1,14 +1,14 @@ ;; Dirichlet distribution ;; Liam Healy, Sun Oct 29 2006 -;; Time-stamp: <2008-02-03 09:49:17EST dirichlet.lisp> +;; Time-stamp: <2008-02-17 13:33:49EST dirichlet.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl dirichlet (generator alpha theta) +(defmfun dirichlet (generator alpha theta) "gsl_ran_dirichlet" (((generator generator) :pointer) - ((dim0 alpha) :size) + ((dim0 alpha) size) ((gsl-array alpha) :pointer) ;; theta had better be at least as long as alpha, or they'll be trouble ((gsl-array theta) :pointer)) @@ -29,9 +29,9 @@ See A.M. Law, W.D. Kelton, \"Simulation Modeling and Analysis\" (1991).") -(defun-gsl dirichlet-pdf (alpha theta) +(defmfun dirichlet-pdf (alpha theta) "gsl_ran_dirichlet_pdf" - (((1- (dim0 alpha)) :size) + (((1- (dim0 alpha)) size) ((gsl-array alpha) :pointer) ;; theta had better be at least as long as alpha, or they'll be trouble ((gsl-array theta) :pointer)) @@ -41,9 +41,9 @@ at theta[K] for a Dirichlet distribution with parameters alpha[K], using the formula given for #'dirichlet.") -(defun-gsl dirichlet-log-pdf (alpha theta) +(defmfun dirichlet-log-pdf (alpha theta) "gsl_ran_dirichlet_lnpdf" - (((1- (dim0 alpha)) :size) + (((1- (dim0 alpha)) size) ((gsl-array alpha) :pointer) ;; theta had better be at least as long as alpha, or they'll be trouble ((gsl-array theta) :pointer)) @@ -55,23 +55,44 @@ alpha[K].") ;;; Examples and unit test -(lisp-unit:define-test dirichlet - (lisp-unit:assert-equal - '("0.392833324564d-04" "0.468176310887d+00" - "0.340750440311d+00" "0.191033965469d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0)) +#| +(make-tests dirichlet + (letm ((rng (random-number-generator *mt19937* 0)) (alpha (vector-double #(1.0d0 2.0d0 3.0d0 4.0d0))) (theta (vector-double 4))) (dirichlet rng alpha theta) - (data theta)))) - (lisp-unit:assert-first-fp-equal - "0.288000000000d+01" - (letm ((alpha (vector-double #(1.0d0 2.0d0 3.0d0 4.0d0))) + (data theta)) + (letm ((alpha (vector-double #(1.0d0 2.0d0 3.0d0 4.0d0))) (theta (vector-double #(0.1d0 0.3d0 0.4d0 0.2d0)))) - (dirichlet-pdf alpha theta))) - (lisp-unit:assert-first-fp-equal - "0.105779029415d+01" - (letm ((alpha (vector-double #(1.0d0 2.0d0 3.0d0 4.0d0))) + (dirichlet-pdf alpha theta)) + (letm ((alpha (vector-double #(1.0d0 2.0d0 3.0d0 4.0d0))) (theta (vector-double #(0.1d0 0.3d0 0.4d0 0.2d0)))) - (dirichlet-log-pdf alpha theta)))) + (dirichlet-log-pdf alpha theta))) +|# + +(LISP-UNIT:DEFINE-TEST DIRICHLET + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + #(3.9283332456352124d-5 0.468176310887376d0 + 0.34075044031099977d0 0.19103396546916782d0)) + (MULTIPLE-VALUE-LIST + (LETM + ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0)) + (ALPHA (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0 4.0d0))) + (THETA (VECTOR-DOUBLE 4))) + (DIRICHLET RNG ALPHA THETA) (DATA THETA)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.8800000000000043d0) + (MULTIPLE-VALUE-LIST + (LETM + ((ALPHA (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0 4.0d0))) + (THETA (VECTOR-DOUBLE #(0.1d0 0.3d0 0.4d0 0.2d0)))) + (DIRICHLET-PDF ALPHA THETA)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.057790294147856d0) + (MULTIPLE-VALUE-LIST + (LETM + ((ALPHA (VECTOR-DOUBLE #(1.0d0 2.0d0 3.0d0 4.0d0))) + (THETA (VECTOR-DOUBLE #(0.1d0 0.3d0 0.4d0 0.2d0)))) + (DIRICHLET-LOG-PDF ALPHA THETA))))) + diff --git a/random/discrete.lisp b/random/discrete.lisp index 45e9b682d86ed437d4124d45372315c822fe420c..a148d89d4119dc2314ec3807b3affe1acaae558a 100644 --- a/random/discrete.lisp +++ b/random/discrete.lisp @@ -1,21 +1,21 @@ ;; Discrete random variables ;; Liam Healy, Sat Nov 11 2006 - 21:51 -;; Time-stamp: <2008-02-03 13:22:45EST discrete.lisp> +;; Time-stamp: <2008-02-17 13:36:26EST discrete.lisp> ;; $Id: $ (in-package :gsl) (cffi:defcstruct discrete-t "Structure for Walker algorithm." - (K :size) + (K size) (A :pointer) (F :pointer)) (defgo-s (discrete-random probabilities) discrete-preprocess discrete-free) -(defun-gsl discrete-preprocess (probabilities) +(defmfun discrete-preprocess (probabilities) "gsl_ran_discrete_preproc" - (((dim0 probabilities) :size) ((gsl-array probabilities) :pointer)) + (((dim0 probabilities) size) ((gsl-array probabilities) :pointer)) :c-return :pointer :export nil :index (letm discrete-random) @@ -27,7 +27,7 @@ generally as ``weights'')---the preprocessor will normalize appropriately. This return value is used as an argument to #'discrete.") -(defun-gsl discrete-free (table) +(defmfun discrete-free (table) "gsl_ran_discrete_free" ((table :pointer)) :c-return :void :export nil @@ -35,17 +35,17 @@ :documentation ; FDL "De-allocates the lookup table created by #'discrete-preprocess.") -(defun-gsl discrete (generator table) +(defmfun discrete (generator table) "gsl_ran_discrete" (((generator generator) :pointer) (table :pointer)) - :c-return :size + :c-return size :documentation ; FDL "Generate discrete random numbers after running #'discrete-preprocess; the argument 'table is the value returned by #'discrete-preprocess.") -(defun-gsl discrete-pdf (k table) +(defmfun discrete-pdf (k table) "gsl_ran_discrete_pdf" - ((k :size) (table :pointer)) + ((k size) (table :pointer)) :c-return :double :documentation ; FDL "The probability P[k] of observing the variable k. @@ -56,9 +56,8 @@ around.") ;;; Examples and unit test -(lisp-unit:define-test discrete - (lisp-unit:assert-equal - '(1 0 1 1 0 1 1 2 1 2 2) +#| +(make-tests discrete ;; Must have two letms because the vector value is not set until ;; the body, but the discrete-random needs that set value. (letm ((probabilities (vector-double #(0.25d0 0.5d0 0.25d0)))) @@ -67,8 +66,25 @@ (loop for i from 0 to 10 collect (discrete rng table)))) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (letm ((probabilities (vector-double #(0.25d0 0.5d0 0.25d0)))) + (letm ((probabilities (vector-double #(0.25d0 0.5d0 0.25d0)))) (letm ((table (discrete-random probabilities))) - (discrete-pdf 1 table)))))) + (discrete-pdf 1 table)))) +|# + +(LISP-UNIT:DEFINE-TEST DISCRETE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 1 0 1 1 0 1 1 2 1 2 2)) + (MULTIPLE-VALUE-LIST + (LETM ((PROBABILITIES + (VECTOR-DOUBLE #(0.25d0 0.5d0 0.25d0)))) + (LETM ((TABLE (DISCRETE-RANDOM PROBABILITIES)) + (RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (DISCRETE RNG TABLE)))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5d0) + (MULTIPLE-VALUE-LIST + (LETM ((PROBABILITIES (VECTOR-DOUBLE #(0.25d0 0.5d0 0.25d0)))) + (LETM ((TABLE (DISCRETE-RANDOM PROBABILITIES))) + (DISCRETE-PDF 1 TABLE)))))) + diff --git a/random/exponential-power.lisp b/random/exponential-power.lisp index 4d69f7083b1c510577ea1b76000a7b32155d01e0..e800b7b52dd6781b4d515985c86824152bc8c0a1 100644 --- a/random/exponential-power.lisp +++ b/random/exponential-power.lisp @@ -1,11 +1,11 @@ ;; Exponential power distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 11:12:27EST exponential-power.lisp> +;; Time-stamp: <2008-02-17 12:53:01EST exponential-power.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl exponential-power (generator a b) +(defmfun exponential-power (generator a b) "gsl_ran_exppow" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double @@ -17,7 +17,7 @@ distribution. For b = 2 it has the same form as a gaussian distribution, but with a = \sqrt{2} \sigma.") -(defun-gsl exponential-power-pdf (x a b) +(defmfun exponential-power-pdf (x a b) "gsl_ran_exppow_pdf" ((x :double) (a :double) (b :double)) :c-return :double @@ -26,7 +26,7 @@ for an exponential power distribution with scale parameter a and exponent b, using the formula given for #'exponential-power.") -(defun-gsl exponential-power-P (x a b) +(defmfun exponential-power-P (x a b) "gsl_cdf_exppow_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -34,7 +34,7 @@ P(x), for the exponential power distribution with parameters a and b.") -(defun-gsl exponential-power-Q (x a b) +(defmfun exponential-power-Q (x a b) "gsl_cdf_exppow_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -43,23 +43,39 @@ parameters a and b.") ;;; Examples and unit test -(lisp-unit:define-test exponential-power - (lisp-unit:assert-equal - '("0.946947559278d-01" "-0.622968087533d-01" "0.118398553854d+01" - "0.518762601924d+00" "0.705356431406d+00" "-0.903330384457d+00" - "-0.169473362899d+01" "-0.480323610806d+00" "-0.276417363499d-01" - "0.631839185605d+00" "-0.124788752274d-01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests exponential-power + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (exponential-power rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.564189583548d+00" - (exponential-power-pdf 0.0d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.921350396475d+00" - (exponential-power-P 1.0d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.786496035251d-01" - (exponential-power-Q 1.0d0 1.0d0 2.0d0))) + (exponential-power rng 1.0d0 2.0d0))) + (exponential-power-pdf 0.0d0 1.0d0 2.0d0) + (exponential-power-P 1.0d0 1.0d0 2.0d0) + (exponential-power-Q 1.0d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST EXPONENTIAL-POWER + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.09469475592777954d0 -0.06229680875327071d0 + 1.183985538537803d0 0.5187626019237904d0 + 0.7053564314063956d0 -0.9033303844569821d0 + -1.6947336289940842d0 -0.4803236108055401d0 + -0.027641736349912214d0 0.6318391856046153d0 + -0.012478875227423025d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (EXPONENTIAL-POWER RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5641895835477557d0) + (MULTIPLE-VALUE-LIST + (EXPONENTIAL-POWER-PDF 0.0d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9213503964748571d0) + (MULTIPLE-VALUE-LIST + (EXPONENTIAL-POWER-P 1.0d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.07864960352514248d0) + (MULTIPLE-VALUE-LIST + (EXPONENTIAL-POWER-Q 1.0d0 1.0d0 2.0d0)))) diff --git a/random/exponential.lisp b/random/exponential.lisp index b8582069bc7a336dd06352c98716c78cf5d09b04..09f4abf2a2ce6619ed05d8f0630d3ae29d752c91 100644 --- a/random/exponential.lisp +++ b/random/exponential.lisp @@ -1,11 +1,11 @@ ;; Exponential distribution ;; Liam Healy, Sat Sep 2 2006 - 19:04 -;; Time-stamp: <2008-02-03 10:42:55EST exponential.lisp> +;; Time-stamp: <2008-02-17 12:34:11EST exponential.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl exponential (generator mu) +(defmfun exponential (generator mu) "gsl_ran_exponential" (((generator generator) :pointer) (mu :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = {1 \over \mu} \exp(-x/\mu) dx x >= 0.") -(defun-gsl exponential-pdf (x mu) +(defmfun exponential-pdf (x mu) "gsl_ran_exponential_pdf" ((x :double) (mu :double)) :c-return :double :documentation ; FDL @@ -23,28 +23,28 @@ for an exponential distribution with mean mu, using the formula given for exponential.") -(defun-gsl exponential-P (x mu) +(defmfun exponential-P (x mu) "gsl_cdf_exponential_P" ((x :double) (mu :double)) :c-return :double :documentation ; FDL "The cumulative distribution function P(x) for the exponential distribution with mean mu.") -(defun-gsl exponential-Q (x mu) +(defmfun exponential-Q (x mu) "gsl_cdf_exponential_Q" ((x :double) (mu :double)) :c-return :double :documentation ; FDL "The cumulative distribution function Q(x) for the exponential distribution with mean mu.") -(defun-gsl exponential-Pinv (P mu) +(defmfun exponential-Pinv (P mu) "gsl_cdf_exponential_Pinv" ((P :double) (mu :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution function P(x) for the exponential distribution with mean mu.") -(defun-gsl exponential-Qinv (Q mu) +(defmfun exponential-Qinv (Q mu) "gsl_cdf_exponential_Qinv" ((Q :double) (mu :double)) :c-return :double :documentation ; FDL @@ -52,30 +52,49 @@ Q(x) for the exponential distribution with mean mu.") ;;; Examples and unit test -(lisp-unit:define-test exponential - (lisp-unit:assert-equal - '("0.258284445884d-02" "0.181455814280d+02" "0.126365980543d+02" - "0.542438725206d+00" "0.146249942342d+02" "0.723660792954d+01" - "0.434536244968d+00" "0.295303920905d+01" "0.616105293907d+01" - "0.301168633354d+01" "0.274510798194d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests exponential + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (exponential rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+00" - (exponential-pdf 0.0d0 10.0d0)) - (lisp-unit:assert-first-fp-equal - "0.393469340287d+00" - (exponential-p 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.606530659713d+00" - (exponential-q 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (exponential-pinv 0.3934693402873666d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (exponential-qinv 0.6065306597126334d0 2.0d0))) - + (exponential rng 10.0d0))) + (exponential-pdf 0.0d0 10.0d0) + (exponential-p 1.0d0 2.0d0) + (exponential-q 1.0d0 2.0d0) + (exponential-pinv 0.3934693402873666d0 2.0d0) + (exponential-qinv 0.6065306597126334d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST EXPONENTIAL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.0025828444588394794d0 18.145581427987647d0 + 12.636598054339759d0 0.5424387252062355d0 + 14.624994234158105d0 7.236607929535993d0 + 0.4345362449683603d0 2.95303920904529d0 + 6.161052939065796d0 3.011686333539114d0 + 2.7451079819355364d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (EXPONENTIAL RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 0.1d0) + (MULTIPLE-VALUE-LIST + (EXPONENTIAL-PDF + 0.0d0 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.3934693402873666d0) + (MULTIPLE-VALUE-LIST (EXPONENTIAL-P 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6065306597126334d0) + (MULTIPLE-VALUE-LIST (EXPONENTIAL-Q 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 1.0d0) + (MULTIPLE-VALUE-LIST + (EXPONENTIAL-PINV + 0.3934693402873666d0 + 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL (LIST 1.0d0) + (MULTIPLE-VALUE-LIST + (EXPONENTIAL-QINV + 0.6065306597126334d0 + 2.0d0)))) diff --git a/random/fdist.lisp b/random/fdist.lisp index a15dee02879d734bf98b227f543a02259110c19c..6bcfe965f558c4d66021876e377f78a7db4aef2e 100644 --- a/random/fdist.lisp +++ b/random/fdist.lisp @@ -1,11 +1,11 @@ ;; Fdist distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 10:17:28EST fdist.lisp> +;; Time-stamp: <2008-02-17 13:14:44EST fdist.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl fdist (generator nu1 nu2) +(defmfun fdist (generator nu1 nu2) "gsl_ran_fdist" (((generator generator) :pointer) (nu1 :double) (nu2 :double)) :c-return :double @@ -19,7 +19,7 @@ x^{\nu_1/2 - 1} (\nu_2 + \nu_1 x)^{-\nu_1/2 -\nu_2/2} for x >= 0.") -(defun-gsl fdist-pdf (x nu1 nu2) +(defmfun fdist-pdf (x nu1 nu2) "gsl_ran_fdist_pdf" ((x :double) (nu1 :double) (nu2 :double)) :c-return :double :documentation ; FDL @@ -27,7 +27,7 @@ for an F-distribution with nu1 and nu2 degrees of freedom, using the formula given #'fdist.") -(defun-gsl fdist-P (x nu1 nu2) +(defmfun fdist-P (x nu1 nu2) "gsl_cdf_fdist_P" ((x :double) (nu1 :double) (nu2 :double)) :c-return :double :documentation ; FDL @@ -35,7 +35,7 @@ P(x) for the fdist distribution with nu1 and nu2 degrees of freedom.") -(defun-gsl fdist-Q (x nu1 nu2) +(defmfun fdist-Q (x nu1 nu2) "gsl_cdf_fdist_Q" ((x :double) (nu1 :double) (nu2 :double)) :c-return :double :documentation ; FDL @@ -43,7 +43,7 @@ Q(x) for the fdist distribution with nu1 and nu2 degrees of freedom.") -(defun-gsl fdist-Pinv (P nu1 nu2) +(defmfun fdist-Pinv (P nu1 nu2) "gsl_cdf_fdist_Pinv" ((P :double) (nu1 :double) (nu2 :double)) :c-return :double :documentation ; FDL @@ -51,7 +51,7 @@ P(x) for the fdist distribution with nu1 and nu2 degrees of freedom.") -(defun-gsl fdist-Qinv (Q nu1 nu2) +(defmfun fdist-Qinv (Q nu1 nu2) "gsl_cdf_fdist_Qinv" ((Q :double) (nu1 :double) (nu2 :double)) :c-return :double :documentation ; FDL @@ -60,29 +60,47 @@ nu1 and nu2 degrees of freedom.") ;;; Examples and unit test -(lisp-unit:define-test fdist - (lisp-unit:assert-equal - '("0.103774233365d+03" "0.212485013221d+01" "0.304410694709d+00" - "0.300188687388d+00" "0.112282068448d-02" "0.292109400785d+00" - "0.635729092565d-01" "0.477966365217d+00" "0.347211676079d-01" - "0.486974823041d+00" "0.253179451696d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests fdist + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (fdist rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.159471988462d+00" - (fdist-pdf 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.612372435696d+00" - (fdist-P 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.387627564304d+00" - (fdist-Q 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+01" - (fdist-Pinv 0.612372435695795d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+01" - (fdist-Qinv 0.38762756430420503d0 1.0d0 2.0d0))) + (fdist rng 1.0d0 2.0d0))) + (fdist-pdf 1.2d0 1.0d0 2.0d0) + (fdist-P 1.2d0 1.0d0 2.0d0) + (fdist-Q 1.2d0 1.0d0 2.0d0) + (fdist-Pinv 0.612372435695795d0 1.0d0 2.0d0) + (fdist-Qinv 0.38762756430420503d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST FDIST + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 103.77423336538772d0 2.124850132212401d0 + 0.3044106947086728d0 0.30018868738752463d0 + 0.0011228206844788875d0 0.29210940078495257d0 + 0.0635729092565007d0 0.4779663652167387d0 + 0.03472116760794376d0 0.4869748230412714d0 + 2.531794516961295d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (FDIST RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.1594719884624466d0) + (MULTIPLE-VALUE-LIST (FDIST-PDF 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6123724356957948d0) + (MULTIPLE-VALUE-LIST (FDIST-P 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.3876275643042052d0) + (MULTIPLE-VALUE-LIST (FDIST-Q 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.200000000000001d0) + (MULTIPLE-VALUE-LIST + (FDIST-PINV 0.612372435695795d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.2000000000000006d0) + (MULTIPLE-VALUE-LIST + (FDIST-QINV 0.38762756430420503d0 1.0d0 2.0d0)))) + diff --git a/random/flat.lisp b/random/flat.lisp index 4cc16d5b294de1eeaa3f91b754d2417951ea9158..e3d24323f20d2da9213eef0cf9801d6fd8d2e5c7 100644 --- a/random/flat.lisp +++ b/random/flat.lisp @@ -1,11 +1,11 @@ ;; Flat distribution ;; Liam Healy, Oct 7 2006 -;; Time-stamp: <2008-02-03 11:18:30EST flat.lisp> +;; Time-stamp: <2008-02-17 13:08:10EST flat.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl flat (generator a b) +(defmfun flat (generator a b) "gsl_ran_flat" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = {1 \over (b-a)} dx if a <= x < b, and 0 otherwise.") -(defun-gsl flat-pdf (x a b) +(defmfun flat-pdf (x a b) "gsl_ran_flat_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -23,28 +23,28 @@ for a uniform distribution from a to b, using the formula given for #'flat.") -(defun-gsl flat-P (x a b) +(defmfun flat-P (x a b) "gsl_cdf_flat_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for a uniform distribution from a to b.") -(defun-gsl flat-Q (x a b) +(defmfun flat-Q (x a b) "gsl_cdf_flat_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for a uniform distribution from a to b.") -(defun-gsl flat-Pinv (P a b) +(defmfun flat-Pinv (P a b) "gsl_cdf_flat_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for a uniform distribution from a to b.") -(defun-gsl flat-Qinv (Q a b) +(defmfun flat-Qinv (Q a b) "gsl_cdf_flat_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -52,29 +52,47 @@ Q(x) for a uniform distribution from a to b.") ;;; Examples and unit test -(lisp-unit:define-test flat - (lisp-unit:assert-equal - '("0.199974174891d+01" "0.116290987539d+01" "0.128261780529d+01" - "0.194720108202d+01" "0.123165654275d+01" "0.148497361434d+01" - "0.195747695654d+01" "0.174430534313d+01" "0.154004365834d+01" - "0.173995298147d+01" "0.175994379818d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests flat + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (flat rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (flat-pdf 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.200000000000d+00" - (flat-P 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.800000000000d+00" - (flat-Q 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+01" - (flat-Pinv 0.19999999999999996d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+01" - (flat-Qinv 0.8d0 1.0d0 2.0d0))) + (flat rng 1.0d0 2.0d0))) + (flat-pdf 1.2d0 1.0d0 2.0d0) + (flat-P 1.2d0 1.0d0 2.0d0) + (flat-Q 1.2d0 1.0d0 2.0d0) + (flat-Pinv 0.19999999999999996d0 1.0d0 2.0d0) + (flat-Qinv 0.8d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST FLAT + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 1.999741748906672d0 1.1629098753910512d0 + 1.2826178052928299d0 1.9472010820172727d0 + 1.2316565427463502d0 1.4849736143369228d0 + 1.9574769565369934d0 1.7443053431343287d0 + 1.540043658344075d0 1.7399529814720154d0 + 1.7599437981843948d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (FLAT RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0d0) + (MULTIPLE-VALUE-LIST (FLAT-PDF 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.19999999999999996d0) + (MULTIPLE-VALUE-LIST (FLAT-P 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.8d0) + (MULTIPLE-VALUE-LIST (FLAT-Q 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.2d0) + (MULTIPLE-VALUE-LIST + (FLAT-PINV 0.19999999999999996d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.2d0) + (MULTIPLE-VALUE-LIST + (FLAT-QINV 0.8d0 1.0d0 2.0d0)))) + diff --git a/random/gamma.lisp b/random/gamma.lisp index 0df209fee850fc0e999d509fc0d608cb010cc773..2b52bac469f4b1bee24b92b52259ae89f3aadcbe 100644 --- a/random/gamma.lisp +++ b/random/gamma.lisp @@ -1,11 +1,11 @@ ;; Gamma distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 10:43:54EST gamma.lisp> +;; Time-stamp: <2008-02-17 13:10:14EST gamma.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl gamma-rd (generator a b) +(defmfun gamma-rd (generator a b) ;; Named #'gamma-rd to avoid confusion with the special function #'gamma. "gsl_ran_gamma" (((generator generator) :pointer) (a :double) (b :double)) @@ -18,14 +18,14 @@ is known as the Erlang distribution. The variates are computed using the algorithms from Knuth (vol 2).") -(defun-gsl gamma-mt (generator a b) +(defmfun gamma-mt (generator a b) "gsl_ran_gamma_mt" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double :documentation ; FDL "A gamma variate using the Marsaglia-Tsang fast gamma method.") -(defun-gsl gamma-pdf (x a b) +(defmfun gamma-pdf (x a b) "gsl_ran_gamma_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -33,28 +33,28 @@ for a gamma distribution with parameters a and b, using the formula given in #'gamma.") -(defun-gsl gamma-P (x a b) +(defmfun gamma-P (x a b) "gsl_cdf_gamma_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the Gamma distribution with parameters a and b.") -(defun-gsl gamma-Q (x a b) +(defmfun gamma-Q (x a b) "gsl_cdf_gamma_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the Gamma distribution with parameters a and b.") -(defun-gsl gamma-Pinv (P a b) +(defmfun gamma-Pinv (P a b) "gsl_cdf_gamma_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the Gamma distribution with parameters a and b.") -(defun-gsl gamma-Qinv (Q a b) +(defmfun gamma-Qinv (Q a b) "gsl_cdf_gamma_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -62,39 +62,63 @@ Q(x) for the Gamma distribution with parameters a and b.") ;;; Examples and unit test -(lisp-unit:define-test gamma-randist - (lisp-unit:assert-equal - '("0.516568891768d-03" "0.362911628560d+01" "0.252731961087d+01" - "0.108487745041d+00" "0.292499884683d+01" "0.144732158591d+01" - "0.869072489937d-01" "0.590607841809d+00" "0.123221058781d+01" - "0.602337266708d+00" "0.549021596387d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (gamma-rd rng 1.0d0 2.0d0))))) - (lisp-unit:assert-equal - '("0.260013787613d+01" "0.252226669542d+01" "0.773142209213d+01" - "0.422727992649d+01" "0.951930434749d-01" "0.571092010687d+00" - "0.891063771946d+00" "0.826322120255d+00" "0.318306657206d+01" - "0.380840036132d-02" "0.103201173341d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (gamma-mt rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.475614712250d+00" - (gamma-pdf 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.487705754993d-01" - (gamma-P 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.951229424501d+00" - (gamma-Q 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+00" - (gamma-Pinv 0.048770575499286005d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+00" - (gamma-Qinv 0.951229424500714d0 1.0d0 2.0d0))) +#| +(make-tests gamma-randist + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (gamma-rd rng 1.0d0 2.0d0))) + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (gamma-mt rng 1.0d0 2.0d0))) + (gamma-pdf 0.1d0 1.0d0 2.0d0) + (gamma-P 0.1d0 1.0d0 2.0d0) + (gamma-Q 0.1d0 1.0d0 2.0d0) + (gamma-Pinv 0.048770575499286005d0 1.0d0 2.0d0) + (gamma-Qinv 0.951229424500714d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST GAMMA-RANDIST + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 5.165688917678959d-4 3.6291162855975294d0 + 2.5273196108679516d0 0.10848774504124709d0 + 2.9249988468316213d0 1.4473215859071986d0 + 0.08690724899367205d0 0.590607841809058d0 + 1.2322105878131593d0 0.6023372667078228d0 + 0.5490215963871072d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GAMMA-RD RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 2.6001378761310767d0 2.5222666954201554d0 + 7.731422092125877d0 4.227279926486253d0 + 0.09519304347489156d0 0.5710920106874436d0 + 0.8910637719460512d0 0.8263221202545431d0 + 3.1830665720573026d0 0.0038084003613199297d0 + 1.0320117334083205d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GAMMA-MT RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.475614712250357d0) + (MULTIPLE-VALUE-LIST (GAMMA-PDF 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.04877057549928599d0) + (MULTIPLE-VALUE-LIST (GAMMA-P 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.951229424500714d0) + (MULTIPLE-VALUE-LIST (GAMMA-Q 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.10000000000000006d0) + (MULTIPLE-VALUE-LIST + (GAMMA-PINV 0.048770575499286005d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.10000000000000003d0) + (MULTIPLE-VALUE-LIST + (GAMMA-QINV 0.951229424500714d0 1.0d0 2.0d0)))) + diff --git a/random/gaussian-bivariate.lisp b/random/gaussian-bivariate.lisp index 432ccb5ed79a75ca780e5bf9a0cd31c23036bd2a..2fd06d0c91766e501952c49f94a9d9ae4670479b 100644 --- a/random/gaussian-bivariate.lisp +++ b/random/gaussian-bivariate.lisp @@ -1,11 +1,11 @@ ;; Gaussian bivariate distribution ;; Liam Healy, Sat Sep 2 2006 - 16:32 -;; Time-stamp: <2008-02-03 10:30:48EST gaussian-bivariate.lisp> +;; Time-stamp: <2008-02-17 12:32:10EST gaussian-bivariate.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl bivariate-gaussian (generator sigma-x sigma-y rho) +(defmfun bivariate-gaussian (generator sigma-x sigma-y rho) "gsl_ran_bivariate_gaussian" (((generator generator) :pointer) (sigma-x :double) (sigma-y :double) (rho :double) (x :double) (y :double)) @@ -22,7 +22,7 @@ for x,y in the range -\infty to +\infty. The correlation coefficient rho should lie between 1 and -1.") -(defun-gsl bivariate-gaussian-pdf (x y sigma-x sigma-y rho) +(defmfun bivariate-gaussian-pdf (x y sigma-x sigma-y rho) "gsl_ran_bivariate_gaussian_pdf" ((x :double) (y :double) (sigma-x :double) (sigma-y :double) (rho :double)) :c-return :double @@ -33,18 +33,31 @@ rho, using the formula given for bivariate-gaussian.") ;;; Examples and unit test -(lisp-unit:define-test gaussian-bivariate - (lisp-unit:assert-equal - '("-0.650971612449d-01" "-0.157332077491d+01" "0.279427401723d+00" - "0.120215283589d+01" "-0.604153062691d+00" "0.758270271941d-01" - "-0.544622941217d+00" "-0.659202684161d+00" "-0.110295166108d+00" - "0.179318404121d+00" "0.210251049803d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests gaussian-bivariate + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (bivariate-gaussian rng 1.0d0 0.75d0 0.25d0))))) - (lisp-unit:assert-first-fp-equal - "0.554826555797d+00" - (bivariate-gaussian-pdf 0.25d0 0.5d0 0.25d0 - 0.4d0 0.2d0))) + (bivariate-gaussian rng 1.0d0 0.75d0 0.25d0))) + (bivariate-gaussian-pdf 0.25d0 0.5d0 0.25d0 + 0.4d0 0.2d0)) +|# + +(LISP-UNIT:DEFINE-TEST GAUSSIAN-BIVARIATE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST -0.06509716124488897d0 -1.5733207749096374d0 + 0.27942740172325414d0 1.2021528358889673d0 + -0.6041530626907894d0 0.07582702719413444d0 + -0.5446229412165632d0 -0.6592026841613081d0 + -0.11029516610819164d0 0.17931840412143885d0 + 2.1025104980291696d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (BIVARIATE-GAUSSIAN RNG 1.0d0 0.75d0 0.25d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5548265557970462d0) + (MULTIPLE-VALUE-LIST + (BIVARIATE-GAUSSIAN-PDF 0.25d0 0.5d0 0.25d0 0.4d0 0.2d0)))) + diff --git a/random/gaussian-tail.lisp b/random/gaussian-tail.lisp index 3e1715aea7d17be655c657c27a8047514ce0f378..68e208833d04968e2873f85726a64e65aed51bd0 100644 --- a/random/gaussian-tail.lisp +++ b/random/gaussian-tail.lisp @@ -1,11 +1,11 @@ ;; Gaussian tail distribution ;; Liam Healy, Mon Aug 21 2006 - 21:52 -;; Time-stamp: <2008-02-03 10:15:01EST gaussian-tail.lisp> +;; Time-stamp: <2008-02-17 12:28:20EST gaussian-tail.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl gaussian-tail (generator a sigma) +(defmfun gaussian-tail (generator a sigma) "gsl_ran_gaussian_tail" (((generator generator) :pointer) (a :double) (sigma :double)) :c-return :double @@ -22,7 +22,7 @@ for x > a where N(a;\sigma) is the normalization constant, N(a;\sigma) = (1/2) erfc(a / sqrt(2 sigma^2)).") -(defun-gsl gaussian-tail-pdf (x a sigma) +(defmfun gaussian-tail-pdf (x a sigma) "gsl_ran_gaussian_tail_pdf" ((x :double) (a :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -30,44 +30,64 @@ for a Gaussian tail distribution with standard deviation sigma and lower limit a, using the formula given for gaussian-tail.") -(defun-gsl ugaussian-tail (generator a) +(defmfun ugaussian-tail (generator a) "gsl_ran_ugaussian_tail" (((generator generator) :pointer) (a :double)) :c-return :double :documentation ; FDL "Equivalent to gaussian-tail with sigma=1.") -(defun-gsl ugaussian-tail-pdf (x a) +(defmfun ugaussian-tail-pdf (x a) "gsl_ran_ugaussian_tail_pdf" ((x :double) (a :double)) :c-return :double :documentation ; FDL "Equivalent to gaussian-tail-pdf with sigma=1.") ;;; Examples and unit test -(lisp-unit:define-test gaussian-tail - (lisp-unit:assert-equal - '("0.501083703038d+02" "0.514269594531d+02" "0.505871602700d+02" - "0.505987522244d+02" "0.508283057286d+02" "0.504334311213d+02" - "0.534422862873d+02" "0.518376171418d+02" "0.530010742143d+02" - "0.521497741699d+02" "0.501157244350d+02") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (gaussian-tail rng 50.0d0 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.187022708773d+00" - (gaussian-tail-pdf 52.0d0 50.0d0 10.0d0)) - (lisp-unit:assert-equal - '("0.501083703038d+01" "0.514269594531d+01" "0.505871602700d+01" - "0.505987522244d+01" "0.508283057286d+01" "0.504334311213d+01" - "0.534422862873d+01" "0.518376171418d+01" "0.530010742143d+01" - "0.521497741699d+01" "0.501157244350d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (ugaussian-tail rng 5.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.187022708773d+01" - (ugaussian-tail-pdf 5.2d0 5.0d0))) +#| +(make-tests + gaussian-tail + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (gaussian-tail rng 50.0d0 10.0d0))) + (gaussian-tail-pdf 52.0d0 50.0d0 10.0d0) + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (ugaussian-tail rng 5.0d0))) + (ugaussian-tail-pdf 5.2d0 5.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST GAUSSIAN-TAIL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 50.10837030381376d0 51.42695945309931d0 + 50.587160269982604d0 50.59875222444504d0 + 50.82830572864337d0 50.43343112125345d0 + 53.442286287287374d0 51.83761714183811d0 + 53.00107421429086d0 52.149774169929884d0 + 50.11572443504253d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GAUSSIAN-TAIL RNG 50.0d0 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.18702270877331703d0) + (MULTIPLE-VALUE-LIST + (GAUSSIAN-TAIL-PDF 52.0d0 50.0d0 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 5.010837030381376d0 5.142695945309931d0 + 5.05871602699826d0 5.0598752224445045d0 + 5.082830572864337d0 5.043343112125345d0 + 5.344228628728738d0 5.183761714183811d0 + 5.300107421429086d0 5.214977416992989d0 + 5.011572443504253d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (UGAUSSIAN-TAIL RNG 5.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.8702270877331704d0) + (MULTIPLE-VALUE-LIST (UGAUSSIAN-TAIL-PDF 5.2d0 5.0d0)))) diff --git a/random/gaussian.lisp b/random/gaussian.lisp index 6f0bc6e55e415902c5ca15ecb0a69d98556f3aff..570ca62954cadffb54b5bca9102108419f0e5c39 100644 --- a/random/gaussian.lisp +++ b/random/gaussian.lisp @@ -1,11 +1,11 @@ ;; Gaussian distribution ;; Liam Healy, Sun Jul 16 2006 - 22:09 -;; Time-stamp: <2008-02-03 10:21:12EST gaussian.lisp> +;; Time-stamp: <2008-02-17 12:23:52EST gaussian.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl gaussian (generator sigma) +(defmfun gaussian (generator sigma) "gsl_ran_gaussian" (((generator generator) :pointer) (sigma :double)) :c-return :double @@ -20,14 +20,14 @@ mu. This function uses the Box-Mueller algorithm which requires two calls to the random number generator r.") -(defun-gsl gaussian-pdf (x sigma) +(defmfun gaussian-pdf (x sigma) "gsl_ran_gaussian_pdf" ((x :double) (sigma :double)) :c-return :double :documentation ; FDL "Compute the probability density p(x) at x for a Gaussian distribution with standard deviation sigma.") -(defun-gsl gaussian-ziggurat (generator sigma) +(defmfun gaussian-ziggurat (generator sigma) "gsl_ran_gaussian_ziggurat" (((generator generator) :pointer) (sigma :double)) :c-return :double @@ -36,7 +36,7 @@ Marsaglia-Tsang ziggurat method. The Ziggurat algorithm is the fastest available algorithm in most cases.") -(defun-gsl gaussian-ratio-method (generator sigma) +(defmfun gaussian-ratio-method (generator sigma) "gsl_ran_gaussian_ratio_method" (((generator generator) :pointer) (sigma :double)) :c-return :double @@ -44,7 +44,7 @@ "Compute a Gaussian random variate using the Kinderman-Monahan-Leva ratio method.") -(defun-gsl ugaussian (generator) +(defmfun ugaussian (generator) "gsl_ran_ugaussian" (((generator generator) :pointer)) :c-return :double :documentation ; FDL @@ -52,7 +52,7 @@ equivalent to the #'gaussian with a standard deviation of one, sigma = 1.") -(defun-gsl ugaussian-pdf (x) +(defmfun ugaussian-pdf (x) "gsl_ran_ugaussian_pdf" ((x :double)) :c-return :double :documentation ; FDL @@ -60,7 +60,7 @@ equivalent to the #'gaussian-pdf with a standard deviation of one, sigma = 1.") -(defun-gsl ugaussian-ratio-method (generator) +(defmfun ugaussian-ratio-method (generator) "gsl_ran_ugaussian_ratio_method" (((generator generator) :pointer)) :c-return :double @@ -69,56 +69,56 @@ equivalent to the #'gaussian-ration-method with a standard deviation of one, sigma = 1.") -(defun-gsl gaussian-P (x sigma) +(defmfun gaussian-P (x sigma) "gsl_cdf_gaussian_P" ((x :double) (sigma :double)) :c-return :double :documentation ; FDL "The cumulative distribution function P(x) for the Gaussian distribution with standard deviation sigma.") -(defun-gsl gaussian-Q (x sigma) +(defmfun gaussian-Q (x sigma) "gsl_cdf_gaussian_Q" ((x :double) (sigma :double)) :c-return :double :documentation ; FDL "The cumulative distribution function Q(x) for the Gaussian distribution with standard deviation sigma.") -(defun-gsl gaussian-Pinv (P sigma) +(defmfun gaussian-Pinv (P sigma) "gsl_cdf_gaussian_Pinv" ((P :double) (sigma :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution function P(x) for the Gaussian distribution with standard deviation sigma.") -(defun-gsl gaussian-Qinv (Q sigma) +(defmfun gaussian-Qinv (Q sigma) "gsl_cdf_gaussian_Qinv" ((Q :double) (sigma :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution function Q(x) for the Gaussian distribution with standard deviation sigma.") -(defun-gsl ugaussian-P (x) +(defmfun ugaussian-P (x) "gsl_cdf_ugaussian_P" ((x :double)) :c-return :double :documentation ; FDL "The cumulative distribution function P(x) for the Gaussian distribution with unit standard deviation.") -(defun-gsl ugaussian-Q (x) +(defmfun ugaussian-Q (x) "gsl_cdf_ugaussian_Q" ((x :double)) :c-return :double :documentation ; FDL "The cumulative distribution function Q(x) for the Gaussian distribution with unit standard deviation.") -(defun-gsl ugaussian-Pinv (P) +(defmfun ugaussian-Pinv (P) "gsl_cdf_ugaussian_Pinv" ((P :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution function P(x) for the Gaussian distribution with unit standard deviation.") -(defun-gsl ugaussian-Qinv (Q) +(defmfun ugaussian-Qinv (Q) "gsl_cdf_ugaussian_Qinv" ((Q :double)) :c-return :double :documentation ; FDL @@ -126,34 +126,62 @@ distribution with unit standard deviation.") ;;; Examples and unit test -(lisp-unit:define-test gaussian - (lisp-unit:assert-equal - '("0.133918608119d+01" "-0.881009918314d+00" "0.167440840625d+02" - "0.733641107293d+01" "0.997524631602d+01" "-0.127750208100d+02" - "-0.239671528273d+02" "-0.679280164729d+01" "-0.390913184336d+00" - "0.893555545521d+01" "-0.176477945898d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (gaussian rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.398942280401d-01" - (gaussian-pdf 0.0d0 10.0d0)) - (lisp-unit:assert-equal - '("0.610792663776d+01" "-0.157649178949d+02" "-0.720097139253d+01" - "0.195115024682d+02" "0.524820292158d+01" "0.104085102623d+02" - "-0.143332423262d+02" "0.945508871923d+00" "-0.111203439859d+02" - "-0.307919574280d+01" "-0.209068077307d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (gaussian-ziggurat rng 10.0d0))))) - ;; Given in examples in GSL documentation - (lisp-unit:assert-first-fp-equal "0.977249868052d+00" (ugaussian-p 2.0d0)) - (lisp-unit:assert-first-fp-equal "0.227501319482d-01" (ugaussian-q 2.0d0)) - (lisp-unit:assert-first-fp-equal "0.200000000000d+01" - (ugaussian-pinv 0.9772498680518208d0)) - (lisp-unit:assert-first-fp-equal "0.200000000000d+01" - (ugaussian-qinv 0.02275013194817921d0))) +#| +(make-tests + gaussian + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (gaussian rng 10.0d0))) + (gaussian-pdf 0.0d0 10.0d0) + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (gaussian-ziggurat rng 10.0d0))) + ;; Given in examples in GSL documentation + (ugaussian-p 2.0d0) + (ugaussian-q 2.0d0) + (ugaussian-pinv 0.9772498680518208d0) + (ugaussian-qinv 0.02275013194817921d0)) +|# + +(LISP-UNIT:DEFINE-TEST GAUSSIAN + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 1.3391860811867589d0 -0.8810099183143839d0 + 16.744084062537738d0 7.336411072925795d0 + 9.975246316020124d0 -12.775020810027664d0 + -23.967152827332075d0 -6.79280164729211d0 + -0.3909131843358723d0 8.935555455208181d0 + -0.17647794589783283d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GAUSSIAN RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.039894228040143274d0) + (MULTIPLE-VALUE-LIST (GAUSSIAN-PDF 0.0d0 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 6.107926637756835d0 -15.764917894916914d0 + -7.200971392533084d0 19.5115024682162d0 + 5.248202921580308d0 10.408510262302668d0 + -14.333242326151595d0 0.9455088719230575d0 + -11.120343985926329d0 -3.0791957427954d0 + -2.090680773068803d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GAUSSIAN-ZIGGURAT RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9772498680518208d0) + (MULTIPLE-VALUE-LIST (UGAUSSIAN-P 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.022750131948179212d0) + (MULTIPLE-VALUE-LIST (UGAUSSIAN-Q 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.0d0) + (MULTIPLE-VALUE-LIST (UGAUSSIAN-PINV 0.9772498680518208d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 2.0d0) + (MULTIPLE-VALUE-LIST (UGAUSSIAN-QINV 0.02275013194817921d0)))) diff --git a/random/generators.lisp b/random/generators.lisp index 4be815800d4bd5bceffd303fa89e6955cab1ff94..db6c4de01d6605623a5de71387697409a77b951c 100644 --- a/random/generators.lisp +++ b/random/generators.lisp @@ -1,6 +1,6 @@ ;; Generators of random numbers. ;; Liam Healy, Sat Jul 15 2006 - 14:43 -;; Time-stamp: <2008-02-03 13:22:46EST generators.lisp> +;; Time-stamp: <2008-02-17 12:15:46EST generators.lisp> ;; $Id: $ (in-package :gsl) @@ -45,25 +45,26 @@ ;;;; Initialization ;;;;**************************************************************************** -(defun-gsl alloc ((generator random-number-generator)) +(defmfun alloc ((generator random-number-generator)) "gsl_rng_alloc" (((rng-type generator) :pointer)) :type :method :c-return (ptr :pointer) :return ((progn (setf (generator generator) ptr) generator)) - :documentation + :documentation ; FDL "Instatiate a random number generator of specified type. For example, create an instance of the Tausworthe generator: (rng-alloc *taus*). The generator is automatically initialized with the default seed, - @code{gsl_rng_default_seed}. This is zero by default but can be changed - either directly or by using the environment variable @code{GSL_RNG_SEED}") + *default-seed*. This is zero by default but can be changed + either directly or by using the environment variable GSL_RNG_SEED.") -(defun-gsl free ((generator random-number-generator)) +(defmfun free ((generator random-number-generator)) "gsl_rng_free" (((generator generator) :pointer)) :type :method :c-return :void :after ((setf (generator generator) nil)) - :documentation "Free all the memory associated with the generator.") + :documentation ; FDL + "Free all the memory associated with the generator.") ;;;;**************************************************************************** ;;;; Seed @@ -75,39 +76,39 @@ (map-name '*default-seed* "gsl_rng_cmrg") (export '*default-seed*) -(defun-gsl rng-set (rng-instance value) +(defmfun rng-set (rng-instance value) "gsl_rng_set" (((generator rng-instance) :pointer) (value :ulong)) :c-return :void - :documentation + :documentation ; FDL "Initialize (or `seeds') the random number generator. If - the generator is seeded with the same value of @var{s} on two different + the generator is seeded with the same value of s on two different runs, the same stream of random numbers will be generated by successive - calls to the routines below. If different values of @var{s} are + calls to the routines below. If different values of s are supplied, then the generated streams of random numbers should be - completely different. If the seed @var{s} is zero then the standard seed + completely different. If the seed s is zero then the standard seed from the original implementation is used instead. For example, the - original Fortran source code for the @code{ranlux} generator used a seed - of 314159265, and so choosing @var{s} equal to zero reproduces this when - using @code{gsl_rng_ranlux}.") + original Fortran source code for the *ranlux* generator used a seed + of 314159265, and so choosing s equal to zero reproduces this when + using *ranlux*.") ;;;;**************************************************************************** ;;;; Sampling ;;;;**************************************************************************** -(defun-gsl get-random-number (generator) +(defmfun get-random-number (generator) "gsl_rng_get" (((generator generator) :pointer)) :c-return :ulong - :documentation + :documentation ; FDL "Generate a random integer. The minimum and maximum values depend on the algorithm used, but all - integers in the range [@var{min},@var{max}] are equally likely. The - values of @var{min} and @var{max} can determined using the auxiliary - functions @code{gsl_rng_max (r)} and @code{gsl_rng_min (r)}.") + integers in the range [min, max] are equally likely. The + values of min and max can determined using the auxiliary + functions #'rng-max and #'rng-min.") -(defun-gsl uniform (generator) +(defmfun uniform (generator) "gsl_rng_uniform" (((generator generator) :pointer)) :c-return :double - :documentation + :documentation ; FDL "A double precision floating point number uniformly distributed in the range [0,1). The range includes 0.0 but excludes 1.0. The value is typically obtained by dividing the result of @@ -117,20 +118,20 @@ (the maximum number of bits that can be portably represented in a single :ulong.") -(defun-gsl uniform>0 (generator) +(defmfun uniform>0 (generator) "gsl_rng_uniform_pos" (((generator generator) :pointer)) :c-return :double - :documentation + :documentation ; FDL "Return a positive double precision floating point number uniformly distributed in the range (0,1), excluding both 0.0 and 1.0. The number is obtained by sampling the generator with the algorithm of - @code{gsl_rng_uniform} until a non-zero value is obtained. You can use + #'uniform until a non-zero value is obtained. You can use this function if you need to avoid a singularity at 0.0.") -(defun-gsl uniform-fixnum (generator upperbound) +(defmfun uniform-fixnum (generator upperbound) "gsl_rng_uniform_int" (((generator generator) :pointer) (upperbound :ulong)) :c-return :ulong - :documentation + :documentation ; FDL "Generate a random integer from 0 to upperbound-1 inclusive. All integers in the range are equally likely, regardless of the generator used. An offset correction is applied so that zero is @@ -147,21 +148,22 @@ (:documentation ; FDL "The name of the random number generator.")) -(defun-gsl rng-name ((rng-instance random-number-generator)) +(defmfun rng-name ((rng-instance random-number-generator)) "gsl_rng_name" (((generator rng-instance) :pointer)) :type :method :c-return :string) -(defun-gsl rng-max (rng-instance) +(defmfun rng-max (rng-instance) "gsl_rng_max" (((generator rng-instance) :pointer)) :c-return :unsigned-long - :documentation "The largest value that @code{gsl_rng_get} + :documentation "The largest value that #'get-random-number can return.") -(defun-gsl rng-min (rng-instance) +(defmfun rng-min (rng-instance) "gsl_rng_min" (((generator rng-instance) :pointer)) :c-return :unsigned-long - :documentation "The smallest value that @code{gsl_rng_get} + :documentation ; FDL + "The smallest value that #'get-random-number can return. Usually this value is zero. There are some generators with algorithms that cannot return zero, and for these generators the minimum value is 1.") @@ -171,7 +173,7 @@ (:documentation ; FDL "A pointer to the state of generator.")) -(defun-gsl rng-state ((rng-instance random-number-generator)) +(defmfun rng-state ((rng-instance random-number-generator)) "gsl_rng_state" (((generator rng-instance) :pointer)) :c-return :pointer :type :method @@ -182,9 +184,9 @@ (:documentation ; FDL "The size of the generator.")) -(defun-gsl rng-size ((rng-instance random-number-generator)) +(defmfun rng-size ((rng-instance random-number-generator)) "gsl_rng_size" (((generator rng-instance) :pointer)) - :c-return :size + :c-return size :type :method :index gsl-random-state) @@ -206,7 +208,7 @@ ;;;; Copying state ;;;;**************************************************************************** -(defun-gsl copy +(defmfun copy ((destination random-number-generator) (source random-number-generator)) "gsl_rng_memcpy" (((generator destination) :pointer) ((generator source) :pointer)) @@ -223,18 +225,18 @@ "Create a new generator which is an exact copy of the original. Don't use; use #'make-random-number-generator, #'copy instead.")) -(defun-gsl clone-generator ((instance random-number-generator)) +(defmfun clone-generator ((instance random-number-generator)) "gsl_rng_clone" (((generator instance) :pointer)) :c-return :pointer :type :method) -(defun-gsl write-binary +(defmfun write-binary ((object random-number-generator) stream) "gsl_rng_fwrite" ((stream :pointer) ((generator object) :pointer)) :type :method) -(defun-gsl read-binary +(defmfun read-binary ((object random-number-generator) stream) "gsl_block_fread" ((stream :pointer) ((pointer object) :pointer)) @@ -244,18 +246,33 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test random-number-generators - (lisp-unit:assert-equal - '(999 162 282 947 231 484 957 744 540 739 759) - (letm ((rng (random-number-generator *mt19937* 0))) - (loop for i from 0 to 10 - collect - (uniform-fixnum rng 1000)))) - (lisp-unit:assert-equal - '("0.111776229978d+00" "0.959166794996d+00" "0.841526801158d+00" - "0.925403713680d+00" "0.275406984741d+00" "0.709304057392d+00" - "0.554133304187d+00" "0.880695776958d+00" "0.597139396983d+00" - "0.751874113340d+00" "0.931108462127d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *cmrg* 0))) - (loop for i from 0 to 10 collect (uniform rng)))))) +#| +(make-tests random-number-generators + (letm ((rng (random-number-generator *mt19937* 0))) + (loop for i from 0 to 10 + collect + (uniform-fixnum rng 1000))) + (letm ((rng (random-number-generator *cmrg* 0))) + (loop for i from 0 to 10 collect (uniform rng)))) +|# + +(LISP-UNIT:DEFINE-TEST RANDOM-NUMBER-GENERATORS + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 999 162 282 947 231 484 957 744 540 739 759)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (UNIFORM-FIXNUM RNG 1000))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.11177622997750353d0 0.9591667949963206d0 + 0.8415268011584537d0 0.9254037136795947d0 + 0.27540698474059205d0 0.7093040573919677d0 + 0.5541333041871588d0 0.8806957769583426d0 + 0.597139396982798d0 0.7518741133398722d0 + 0.9311084621265104d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *CMRG* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (UNIFORM RNG)))))) diff --git a/random/geometric.lisp b/random/geometric.lisp index fde5be5970cafabdfd5dd892346e1fb202a90aeb..7872a063122ca81ac9963d801fccfb560f3f9ce4 100644 --- a/random/geometric.lisp +++ b/random/geometric.lisp @@ -1,11 +1,11 @@ ;; Geometric distribution ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 11:04:00EST geometric.lisp> +;; Time-stamp: <2008-02-17 13:45:43EST geometric.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl geometric (generator p) +(defmfun geometric (generator p) "gsl_ran_geometric" (((generator generator) :pointer) (p :double)) :c-return :uint @@ -18,7 +18,7 @@ definition. There is another convention in which the exponent k-1 is replaced by k.") -(defun-gsl geometric-pdf (k p) +(defmfun geometric-pdf (k p) "gsl_ran_geometric_pdf" ((k :uint) (p :double)) :c-return :double :documentation ; FDL @@ -26,14 +26,14 @@ from a geometric distribution with probability parameter p, using the formula given in #'geometric.") -(defun-gsl geometric-P (k p) +(defmfun geometric-P (k p) "gsl_cdf_geometric_P" ((k :uint) (p :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(k) for the geometric distribution with parameter p.") -(defun-gsl geometric-Q (k p) +(defmfun geometric-Q (k p) "gsl_cdf_geometric_Q" ((k :uint) (p :double)) :c-return :double :documentation ; FDL @@ -41,19 +41,31 @@ Q(k) for the geometric distribution with parameters p.") ;;; Examples and unit test -(lisp-unit:define-test geometric - (lisp-unit:assert-equal - '(1 4 3 1 3 2 1 1 2 1 1) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests geometric + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (geometric rng 0.4d0)))) - (lisp-unit:assert-first-fp-equal - "0.240000000000d+00" - (geometric-pdf 2 0.4d0)) - (lisp-unit:assert-first-fp-equal - "0.640000000000d+00" - (geometric-P 2 0.4d0)) - (lisp-unit:assert-first-fp-equal - "0.360000000000d+00" - (geometric-Q 2 0.4d0))) + (geometric rng 0.4d0))) + (geometric-pdf 2 0.4d0) + (geometric-P 2 0.4d0) + (geometric-Q 2 0.4d0)) +|# + +(LISP-UNIT:DEFINE-TEST GEOMETRIC + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 1 4 3 1 3 2 1 1 2 1 1)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GEOMETRIC RNG 0.4d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.24d0) + (MULTIPLE-VALUE-LIST (GEOMETRIC-PDF 2 0.4d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.64d0) + (MULTIPLE-VALUE-LIST (GEOMETRIC-P 2 0.4d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.36d0) + (MULTIPLE-VALUE-LIST (GEOMETRIC-Q 2 0.4d0)))) + diff --git a/random/gumbel1.lisp b/random/gumbel1.lisp index 61f207ac27e320d9f12e160abe165500ed3d3357..2d3c1525d762f1c4fcee8a4d769283e757a9712c 100644 --- a/random/gumbel1.lisp +++ b/random/gumbel1.lisp @@ -1,11 +1,11 @@ ;; The Gumbel type 1 random number distribution ;; Liam Healy, Sun Oct 29 2006 -;; Time-stamp: <2008-02-03 09:46:20EST gumbel1.lisp> +;; Time-stamp: <2008-02-17 13:30:24EST gumbel1.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl gumbel1 (generator a b) +(defmfun gumbel1 (generator a b) "gsl_ran_gumbel1" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = a b \exp(-(b \exp(-ax) + ax)) dx for -\infty < x < \infty.") -(defun-gsl gumbel1-pdf (x a b) +(defmfun gumbel1-pdf (x a b) "gsl_ran_gumbel1_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -23,7 +23,7 @@ for a Type-1 Gumbel distribution with parameters a and b, using the formula given for #'gumbel1.") -(defun-gsl gumbel1-P (x a b) +(defmfun gumbel1-P (x a b) "gsl_cdf_gumbel1_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -31,7 +31,7 @@ P(x) for the Type-1 Gumbel distribution with parameters a and b.") -(defun-gsl gumbel1-Q (x a b) +(defmfun gumbel1-Q (x a b) "gsl_cdf_gumbel1_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -39,7 +39,7 @@ Q(x) for the Type-1 Gumbel distribution with parameters a and b.") -(defun-gsl gumbel1-Pinv (P a b) +(defmfun gumbel1-Pinv (P a b) "gsl_cdf_gumbel1_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -47,7 +47,7 @@ P(x) for the Type-1 Gumbel distribution with parameters a and b.") -(defun-gsl gumbel1-Qinv (Q a b) +(defmfun gumbel1-Qinv (Q a b) "gsl_cdf_gumbel1_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -56,28 +56,46 @@ parameters a and b.") ;;; Examples and unit test -(lisp-unit:define-test gumbel1 - (lisp-unit:assert-equal - '("0.895459625749d+01" "0.973051899751d-01" "0.459135062331d+00" - "0.360741242243d+01" "0.313000274682d+00" "0.101657969497d+01" - "0.382920819366d+01" "0.191289739318d+01" "0.117748457895d+01" - "0.189323210797d+01" "0.198591186168d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests gumbel1 + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 - collect (gumbel1 rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.296257089650d+00" - (gumbel1-pdf 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.163707359877d+00" - (gumbel1-P 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.836292640123d+00" - (gumbel1-Q 0.1d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+00" - (gumbel1-Pinv 0.1637073598773166d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+00" - (gumbel1-Qinv 0.8362926401226833d0 1.0d0 2.0d0))) + collect (gumbel1 rng 1.0d0 2.0d0))) + (gumbel1-pdf 0.1d0 1.0d0 2.0d0) + (gumbel1-P 0.1d0 1.0d0 2.0d0) + (gumbel1-Q 0.1d0 1.0d0 2.0d0) + (gumbel1-Pinv 0.1637073598773166d0 1.0d0 2.0d0) + (gumbel1-Qinv 0.8362926401226833d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST GUMBEL1 + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 8.954596257487015d0 0.0973051899750762d0 + 0.45913506233088003d0 3.6074124224293223d0 + 0.31300027468174807d0 1.0165796949651174d0 + 3.8292081936610396d0 1.912897393181305d0 + 1.17748457894919d0 1.893232107970416d0 + 1.9859118616847695d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GUMBEL1 RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.29625708964974956d0) + (MULTIPLE-VALUE-LIST (GUMBEL1-PDF 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.1637073598773166d0) + (MULTIPLE-VALUE-LIST (GUMBEL1-P 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.8362926401226833d0) + (MULTIPLE-VALUE-LIST (GUMBEL1-Q 0.1d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.10000000000000007d0) + (MULTIPLE-VALUE-LIST + (GUMBEL1-PINV 0.1637073598773166d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.10000000000000028d0) + (MULTIPLE-VALUE-LIST + (GUMBEL1-QINV 0.8362926401226833d0 1.0d0 2.0d0)))) + diff --git a/random/gumbel2.lisp b/random/gumbel2.lisp index 23109738f1484631413666a510b2714a0187d80d..b7d3af1d95c87ba2d5d65de134f5a3977fecff12 100644 --- a/random/gumbel2.lisp +++ b/random/gumbel2.lisp @@ -1,11 +1,11 @@ ;; The Gumbel type 2 random number distribution ;; Liam Healy, Sun Oct 29 2006 -;; Time-stamp: <2008-02-03 10:10:26EST gumbel2.lisp> +;; Time-stamp: <2008-02-17 13:32:16EST gumbel2.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl gumbel2 (generator a b) +(defmfun gumbel2 (generator a b) "gsl_ran_gumbel2" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double @@ -14,7 +14,7 @@ distribution, p(x) dx = a b x^{-a-1} \exp(-b x^{-a}) dx for 0 < x < \infty.") -(defun-gsl gumbel2-pdf (x a b) +(defmfun gumbel2-pdf (x a b) "gsl_ran_gumbel2_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -22,14 +22,14 @@ for a Type-2 Gumbel distribution with parameters a and b, using the formula given in #'gumbel2.") -(defun-gsl gumbel2-P (x a b) +(defmfun gumbel2-P (x a b) "gsl_cdf_gumbel2_P" ((x :double) (a :double) (b :double)) :c-return :double ; FDL :documentation "The cumulative distribution functions P(x) for the Type-2 Gumbel distribution with parameters a and b.") -(defun-gsl gumbel2-Q (x a b) +(defmfun gumbel2-Q (x a b) "gsl_cdf_gumbel2_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -37,7 +37,7 @@ Q(x) for the Type-2 Gumbel distribution with parameters a and b.") -(defun-gsl gumbel2-Pinv (P a b) +(defmfun gumbel2-Pinv (P a b) "gsl_cdf_gumbel2_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -45,7 +45,7 @@ P(x) for the Type-2 Gumbel distribution with parameters a and b.") -(defun-gsl gumbel2-Qinv (Q a b) +(defmfun gumbel2-Qinv (Q a b) "gsl_cdf_gumbel2_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -54,29 +54,46 @@ parameters a and b.") ;;; Examples and unit test -(lisp-unit:define-test gumbel2 - (lisp-unit:assert-equal - '("0.774340085852d+04" "0.110219670168d+01" "0.158270445210d+01" - "0.368705239332d+02" "0.136752190666d+01" "0.276372579456d+01" - "0.460260800603d+02" "0.677268352507d+01" "0.324619836866d+01" - "0.664079780729d+01" "0.728568789702d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests gumbel2 + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (gumbel2 rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.536256036829d-01" - (gumbel2-pdf 5.0d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.818730753078d+00" - (gumbel2-P 10.0d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.181269246922d+00" - (gumbel2-Q 10.0d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "1.000000000000d+01" - (gumbel2-Pinv 0.8187307530779818d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+02" - (gumbel2-Qinv 0.18126924692201815d0 1.0d0 2.0d0))) + (gumbel2 rng 1.0d0 2.0d0))) + (gumbel2-pdf 5.0d0 1.0d0 2.0d0) + (gumbel2-P 10.0d0 1.0d0 2.0d0) + (gumbel2-Q 10.0d0 1.0d0 2.0d0) + (gumbel2-Pinv 0.8187307530779818d0 1.0d0 2.0d0) + (gumbel2-Qinv 0.18126924692201815d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST GUMBEL2 + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 7743.400858519516d0 1.102196701680339d0 + 1.5827044520998628d0 36.87052393317972d0 + 1.3675219066608615d0 2.7637257945633085d0 + 46.026080060263446d0 6.772683525074477d0 + 3.2461983686562204d0 6.640797807286079d0 + 7.285687897019733d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (GUMBEL2 RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.053625603682851145d0) + (MULTIPLE-VALUE-LIST (GUMBEL2-PDF 5.0d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.8187307530779818d0) + (MULTIPLE-VALUE-LIST (GUMBEL2-P 10.0d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.18126924692201815d0) + (MULTIPLE-VALUE-LIST (GUMBEL2-Q 10.0d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 9.999999999999998d0) + (MULTIPLE-VALUE-LIST + (GUMBEL2-PINV 0.8187307530779818d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 10.0d0) + (MULTIPLE-VALUE-LIST (GUMBEL2-QINV 0.18126924692201815d0 1.0d0 2.0d0)))) + diff --git a/random/hypergeometric.lisp b/random/hypergeometric.lisp index 242c48b707d1acdd9e204458dc3a66435ebac8ad..c30da6dc71008b663ae59bee5b0114148b60dbeb 100644 --- a/random/hypergeometric.lisp +++ b/random/hypergeometric.lisp @@ -1,11 +1,11 @@ ;; Hypergeometric distribution ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 10:12:46EST hypergeometric.lisp> +;; Time-stamp: <2008-02-17 15:35:14EST hypergeometric.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl hypergeometric (generator n1 n2 tt) +(defmfun hypergeometric (generator n1 n2 tt) "gsl_ran_hypergeometric" (((generator generator) :pointer) (n1 :uint) (n2 :uint)(tt :uint)) :c-return :uint @@ -23,7 +23,7 @@ ``type 1'' in t samples from the population without replacement.") -(defun-gsl hypergeometric-pdf (k n1 n2 tt) +(defmfun hypergeometric-pdf (k n1 n2 tt) "gsl_ran_hypergeometric_pdf" ((k :uint) (n1 :uint) (n2 :uint)(tt :uint)) :c-return :double :documentation ; FDL @@ -31,14 +31,14 @@ from a hypergeometric distribution with parameters n1, n2, tt, using the formula given in #'hypergeometric.") -(defun-gsl hypergeometric-P (k n1 n2 tt) +(defmfun hypergeometric-P (k n1 n2 tt) "gsl_cdf_hypergeometric_P" ((k :uint) (n1 :uint) (n2 :uint)(tt :uint)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(k) for the hypergeometric distribution with parameters n1, n2 and tt.") -(defun-gsl hypergeometric-Q (k n1 n2 tt) +(defmfun hypergeometric-Q (k n1 n2 tt) "gsl_cdf_hypergeometric_Q" ((k :uint) (n1 :uint) (n2 :uint)(tt :uint)) :c-return :double :documentation ; FDL @@ -46,19 +46,31 @@ hypergeometric distribution with parameters n1, n2, and tt.") ;;; Examples and unit test -(lisp-unit:define-test hypergeometric-randist - (lisp-unit:assert-equal - '(2 1 0 0 1 1 3 1 0 1 3) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests hypergeometric-randist + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (hypergeometric rng 3 6 3)))) - (lisp-unit:assert-first-fp-equal - "0.357142857143d+00" - (hypergeometric-pdf 0 2 6 3)) - (lisp-unit:assert-first-fp-equal - "0.892857142857d+00" - (hypergeometric-P 1 2 6 3)) - (lisp-unit:assert-first-fp-equal - "0.107142857143d+00" - (hypergeometric-Q 1 2 6 3))) + (hypergeometric rng 3 6 3))) + (hypergeometric-pdf 0 2 6 3) + (hypergeometric-P 1 2 6 3) + (hypergeometric-Q 1 2 6 3)) +|# + +(LISP-UNIT:DEFINE-TEST HYPERGEOMETRIC-RANDIST + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 2 1 0 0 1 1 3 1 0 1 3)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (HYPERGEOMETRIC RNG 3 6 3))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.35714285714285693d0) + (MULTIPLE-VALUE-LIST (HYPERGEOMETRIC-PDF 0 2 6 3))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.892857142857143d0) + (MULTIPLE-VALUE-LIST (HYPERGEOMETRIC-P 1 2 6 3))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.10714285714285704d0) + (MULTIPLE-VALUE-LIST (HYPERGEOMETRIC-Q 1 2 6 3)))) + diff --git a/random/landau.lisp b/random/landau.lisp index d15104b15e6f16c472dbaffc62ada8aed535d0b2..d14ffda01bc655896c1297cf11ae5cbaf4a4666a 100644 --- a/random/landau.lisp +++ b/random/landau.lisp @@ -1,11 +1,11 @@ ;; Landau distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 11:30:46EST landau.lisp> +;; Time-stamp: <2008-02-17 13:01:50EST landau.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl landau (generator) +(defmfun landau (generator) "gsl_ran_landau" (((generator generator) :pointer)) :c-return :double @@ -18,7 +18,7 @@ equivalent form of the integral, p(x) = (1/\pi) \int_0^\infty dt \exp(-t \log(t) - x t) \sin(\pi t).") -(defun-gsl landau-pdf (x) +(defmfun landau-pdf (x) "gsl_ran_landau_pdf" ((x :double)) :c-return :double :documentation ; FDL @@ -27,16 +27,28 @@ in #'landau.") ;;; Examples and unit test -(lisp-unit:define-test landau - (lisp-unit:assert-equal - '("0.388003742625d+04" "-0.695320031455d+00" "-0.235436464660d-01" - "0.213292096300d+02" "-0.306222470471d+00" "0.124241866694d+01" - "0.261461684796d+02" "0.433721764097d+01" "0.167995462811d+01" - "0.424757192183d+01" "0.468150620898d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests landau + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 - collect (landau rng))))) - (lisp-unit:assert-first-fp-equal - "0.173319689959d+00" - (landau-pdf 0.25d0))) + collect (landau rng))) + (landau-pdf 0.25d0)) +|# + +(LISP-UNIT:DEFINE-TEST LANDAU + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 3880.037426254597d0 -0.6953200314545297d0 + -0.02354364646600932d0 21.329209630030316d0 + -0.3062224704714883d0 1.2424186669362394d0 + 26.146168479649152d0 4.337217640968217d0 + 1.6799546281085946d0 4.2475719218268395d0 + 4.681506208977819d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LANDAU RNG))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.17331968995860203d0) + (MULTIPLE-VALUE-LIST (LANDAU-PDF 0.25d0)))) + diff --git a/random/laplace.lisp b/random/laplace.lisp index 343ddf320ce91a6f5d8956d4998db00ee609c43e..46ccfd236cb9de539edbfb6c86b5b1a90ea66c86 100644 --- a/random/laplace.lisp +++ b/random/laplace.lisp @@ -1,11 +1,11 @@ ;; Exponential distribution ;; Liam Healy, Sun Sep 17 2006 -;; Time-stamp: <2008-02-03 11:06:31EST laplace.lisp> +;; Time-stamp: <2008-02-17 12:50:28EST laplace.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl laplace (generator a) +(defmfun laplace (generator a) "gsl_ran_laplace" (((generator generator) :pointer) (a :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = {1 \over 2 a} \exp(-|x/a|) dx for -\infty < x < \infty.") -(defun-gsl laplace-pdf (x a) +(defmfun laplace-pdf (x a) "gsl_ran_laplace_pdf" ((x :double) (a :double)) :c-return :double :documentation ; FDL @@ -23,28 +23,28 @@ for a Laplace distribution with width a, using the formula given for #'laplace.") -(defun-gsl laplace-P (x a) +(defmfun laplace-P (x a) "gsl_cdf_laplace_P" ((x :double) (a :double)) :c-return :double :documentation ; FDL "The cumulative distribution function P(x) for the laplace distribution with width a.") -(defun-gsl laplace-Q (x a) +(defmfun laplace-Q (x a) "gsl_cdf_laplace_Q" ((x :double) (a :double)) :c-return :double :documentation ; FDL "The cumulative distribution function Q(x) for the laplace distribution with width a.") -(defun-gsl laplace-Pinv (P a) +(defmfun laplace-Pinv (P a) "gsl_cdf_laplace_Pinv" ((P :double) (a :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution function P(x) for the laplace distribution with width a.") -(defun-gsl laplace-Qinv (Q a) +(defmfun laplace-Qinv (Q a) "gsl_cdf_laplace_Qinv" ((Q :double) (a :double)) :c-return :double :documentation ; FDL @@ -52,29 +52,44 @@ Q(x) for the laplace distribution with width a.") ;;; Examples and unit test -(lisp-unit:define-test laplace - (lisp-unit:assert-equal - '("0.516635619858d-02" "-0.394257771749d+01" "-0.832951028160d+01" - "0.111599757046d+01" "-0.622340381488d+01" "-0.350480039842d+02" - "0.888815832003d+00" "0.716189249197d+01" "0.252463778091d+02" - "0.734165104806d+01" "0.654142651602d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests laplace + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (laplace rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.500000000000d-01" - (laplace-pdf 0.0d0 10.0d0)) - (lisp-unit:assert-first-fp-equal - "0.696734670144d+00" - (laplace-p 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.303265329856d+00" - (laplace-q 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (laplace-pinv 0.6967346701436833d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (laplace-qinv 0.3032653298563167d0 2.0d0))) + (laplace rng 10.0d0))) + (laplace-pdf 0.0d0 10.0d0) + (laplace-p 1.0d0 2.0d0) + (laplace-q 1.0d0 2.0d0) + (laplace-pinv 0.6967346701436833d0 2.0d0) + (laplace-qinv 0.3032653298563167d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST LAPLACE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.005166356198580803d0 -3.942577717493807d0 + -8.329510281601332d0 1.1159975704649974d0 + -6.2234038148786555d0 -35.04800398421181d0 + 0.8888158320028845d0 7.161892491969776d0 + 25.24637780914261d0 7.341651048064451d0 + 6.54142651602034d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LAPLACE RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.05d0) + (MULTIPLE-VALUE-LIST (LAPLACE-PDF 0.0d0 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6967346701436833d0) + (MULTIPLE-VALUE-LIST (LAPLACE-P 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.3032653298563167d0) + (MULTIPLE-VALUE-LIST (LAPLACE-Q 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0d0) + (MULTIPLE-VALUE-LIST (LAPLACE-PINV 0.6967346701436833d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0d0) + (MULTIPLE-VALUE-LIST (LAPLACE-QINV 0.3032653298563167d0 2.0d0)))) diff --git a/random/levy.lisp b/random/levy.lisp index 969887b19e578c2a6a63ad85ff77f91511a71ac8..c4ebe01711ef957fccf5058e4cb71d57673e9214 100644 --- a/random/levy.lisp +++ b/random/levy.lisp @@ -1,11 +1,11 @@ ;; Levy distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 10:44:49EST levy.lisp> +;; Time-stamp: <2008-02-17 13:03:36EST levy.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl levy (generator c alpha) +(defmfun levy (generator c alpha) "gsl_ran_levy" (((generator generator) :pointer) (c :double) (alpha :double)) :c-return :double @@ -21,7 +21,7 @@ For \alpha < 1 the tails of the distribution become extremely wide. The algorithm only works for 0 < alpha <= 2.") -(defun-gsl levy-skew (generator c alpha beta) +(defmfun levy-skew (generator c alpha beta) "gsl_ran_levy_skew" (((generator generator) :pointer) (c :double) (alpha :double) (beta :double)) :c-return :double @@ -44,24 +44,41 @@ ;;; Examples and unit test -(lisp-unit:define-test levy - (lisp-unit:assert-equal - '("0.269410983324d+01" "-0.293954386447d+00" "-0.127034013523d+01" - "0.107715386401d+01" "0.137712184069d+00" "0.941972843811d+00" - "-0.510713467479d+00" "0.164820785369d+00" "-0.148578990410d+00" - "-0.190748857444d+01" "-0.208619521400d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests levy + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (levy rng 1.0d0 2.0d0))))) - (lisp-unit:assert-equal - '("0.269410983324d+01" "-0.293954386447d+00" "-0.127034013523d+01" - "0.107715386401d+01" "0.137712184069d+00" "0.941972843811d+00" - "-0.510713467479d+00" "0.164820785369d+00" "-0.148578990410d+00" - "-0.190748857444d+01" "-0.208619521400d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) + (levy rng 1.0d0 2.0d0))) + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (levy-skew rng 1.0d0 2.0d0 1.0d0)))))) + (levy-skew rng 1.0d0 2.0d0 1.0d0)))) +|# + +(LISP-UNIT:DEFINE-TEST LEVY + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 2.6941098332360465d0 -0.29395438644676647d0 + -1.2703401352272083d0 1.0771538640113538d0 + 0.13771218406916103d0 0.9419728438107844d0 + -0.5107134674789159d0 0.1648207853689268d0 + -0.14857899041035147d0 -1.9074885744364487d0 + -2.086195213997167d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LEVY RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 2.6941098332360465d0 -0.2939543864467665d0 + -1.2703401352272083d0 1.0771538640113538d0 + 0.13771218406916097d0 0.9419728438107844d0 + -0.510713467478916d0 0.1648207853689266d0 + -0.14857899041035158d0 -1.907488574436449d0 + -2.086195213997167d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LEVY-SKEW RNG 1.0d0 2.0d0 1.0d0)))))) + diff --git a/random/logarithmic.lisp b/random/logarithmic.lisp index e034879a5a5f749bc8b1c375dd552d8fef96dcd2..59c8f947a4249bdb03f11ca12d70c50c7f847022 100644 --- a/random/logarithmic.lisp +++ b/random/logarithmic.lisp @@ -1,11 +1,11 @@ ;; Logarithmic distribution ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 11:10:27EST logarithmic.lisp> +;; Time-stamp: <2008-02-17 15:36:14EST logarithmic.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl logarithmic (generator p) +(defmfun logarithmic (generator p) "gsl_ran_logarithmic" (((generator generator) :pointer) (p :double)) :c-return :uint @@ -15,7 +15,7 @@ is p(k) = {-1 \over \log(1-p)} {\left( p^k \over k \right)} for k >= 1.") -(defun-gsl logarithmic-pdf (k p) +(defmfun logarithmic-pdf (k p) "gsl_ran_logarithmic_pdf" ((k :uint) (p :double)) :c-return :double :documentation @@ -24,13 +24,23 @@ using the formula given in #'logarithmic.") ;;; Examples and unit test -(lisp-unit:define-test logarithmic - (lisp-unit:assert-equal - '(1 3 1 4 1 1 2 1 1 5 2) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests logarithmic + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (logarithmic rng 0.9d0)))) - (lisp-unit:assert-first-fp-equal - "0.156609215118d+00" - (logarithmic-pdf 2 0.4d0))) + (logarithmic rng 0.9d0))) + (logarithmic-pdf 2 0.4d0)) +|# + +(LISP-UNIT:DEFINE-TEST LOGARITHMIC + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 1 3 1 4 1 1 2 1 1 5 2)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LOGARITHMIC RNG 0.9d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.15660921511769743d0) + (MULTIPLE-VALUE-LIST (LOGARITHMIC-PDF 2 0.4d0)))) + diff --git a/random/logistic.lisp b/random/logistic.lisp index a61b4ddb4bb5cd12745293de4adf94b5655fa239..618ba01516169b8137d45710e05f978a00b2720c 100644 --- a/random/logistic.lisp +++ b/random/logistic.lisp @@ -1,11 +1,11 @@ ;; Logistic distribution ;; Liam Healy, Sat Oct 7 2006 - 16:13 -;; Time-stamp: <2008-02-03 10:35:08EST logistic.lisp> +;; Time-stamp: <2008-02-17 13:20:11EST logistic.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl logistic (generator a) +(defmfun logistic (generator a) "gsl_ran_logistic" (((generator generator) :pointer) (a :double)) :c-return :double @@ -14,7 +14,7 @@ p(x) dx = { \exp(-x/a) \over a (1 + \exp(-x/a))^2 } dx for -\infty < x < +\infty.") -(defun-gsl logistic-pdf (x a) +(defmfun logistic-pdf (x a) "gsl_ran_logistic_pdf" ((x :double) (a :double)) :c-return :double :documentation ; FDL @@ -22,28 +22,28 @@ for a logistic distribution with scale parameter a, using the formula given in #'logistic.") -(defun-gsl logistic-P (x a) +(defmfun logistic-P (x a) "gsl_cdf_logistic_P" ((x :double) (a :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the logistic distribution with scale parameter a.") -(defun-gsl logistic-Q (x a) +(defmfun logistic-Q (x a) "gsl_cdf_logistic_Q" ((x :double) (a :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the logistic distribution with scale parameter a.") -(defun-gsl logistic-Pinv (P a) +(defmfun logistic-Pinv (P a) "gsl_cdf_logistic_Pinv" ((P :double) (a :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the logistic distribution with scale parameter a.") -(defun-gsl logistic-Qinv (Q a) +(defmfun logistic-Qinv (Q a) "gsl_cdf_logistic_Qinv" ((Q :double) (a :double)) :c-return :double :documentation ; FDL @@ -51,29 +51,47 @@ Q(x) for the logistic distribution with scale parameter a.") ;;; Examples and unit test -(lisp-unit:define-test logistic - (lisp-unit:assert-equal - '("0.826131993192d+02" "-0.163673460427d+02" "-0.931513272044d+01" - "0.288702070871d+02" "-0.119898098758d+02" "-0.601236476200d+00" - "0.311425552636d+02" "0.106846737210d+02" "0.160518409540d+01" - "0.104572419047d+02" "0.115237141063d+02") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests logistic + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (logistic rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.235003712202d+00" - (logistic-pdf 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.622459331202d+00" - (logistic-P 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.377540668798d+00" - (logistic-Q 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (logistic-Pinv 0.6224593312018546d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (logistic-Qinv 0.37754066879814546d0 1.0d0))) + (logistic rng 10.0d0))) + (logistic-pdf 0.5d0 1.0d0) + (logistic-P 0.5d0 1.0d0) + (logistic-Q 0.5d0 1.0d0) + (logistic-Pinv 0.6224593312018546d0 1.0d0) + (logistic-Qinv 0.37754066879814546d0 1.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST LOGISTIC + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 82.6131993192451d0 -16.367346042668906d0 + -9.31513272043762d0 28.87020708710654d0 + -11.989809875784625d0 -0.6012364762000397d0 + 31.142555263622d0 10.684673721048895d0 + 1.6051840954024446d0 10.457241904701199d0 + 11.523714106294097d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LOGISTIC RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.2350037122015945d0) + (MULTIPLE-VALUE-LIST (LOGISTIC-PDF 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6224593312018546d0) + (MULTIPLE-VALUE-LIST (LOGISTIC-P 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.37754066879814546d0) + (MULTIPLE-VALUE-LIST (LOGISTIC-Q 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5000000000000001d0) + (MULTIPLE-VALUE-LIST + (LOGISTIC-PINV 0.6224593312018546d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.4999999999999998d0) + (MULTIPLE-VALUE-LIST + (LOGISTIC-QINV 0.37754066879814546d0 1.0d0)))) + diff --git a/random/lognormal.lisp b/random/lognormal.lisp index a0dd11702110e58dabc5363e03ec688cb93b5b7b..e70363eeb7b73948945f515a86c0f7a5d2c344e2 100644 --- a/random/lognormal.lisp +++ b/random/lognormal.lisp @@ -1,11 +1,11 @@ ;; Lognormal distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 11:08:34EST lognormal.lisp> +;; Time-stamp: <2008-02-17 13:10:13EST lognormal.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl lognormal (generator zeta sigma) +(defmfun lognormal (generator zeta sigma) "gsl_ran_lognormal" (((generator generator) :pointer) (zeta :double) (sigma :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = {1 \over x \sqrt{2 \pi \sigma^2}} \exp(-(\ln(x) - \zeta)^2/2 \sigma^2) dx for x > 0.") -(defun-gsl lognormal-pdf (x zeta sigma) +(defmfun lognormal-pdf (x zeta sigma) "gsl_ran_lognormal_pdf" ((x :double) (zeta :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -23,14 +23,14 @@ for a lognormal distribution with parameters zeta and sigma, using the formula given in #'lognormal.") -(defun-gsl lognormal-P (x zeta sigma) +(defmfun lognormal-P (x zeta sigma) "gsl_cdf_lognormal_P" ((x :double) (zeta :double) (sigma :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the lognormal distribution with parameters zeta and sigma.") -(defun-gsl lognormal-Q (x zeta sigma) +(defmfun lognormal-Q (x zeta sigma) "gsl_cdf_lognormal_Q" ((x :double) (zeta :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -38,7 +38,7 @@ Q(x) for the lognormal distribution with parameters zeta and sigma.") -(defun-gsl lognormal-Pinv (P zeta sigma) +(defmfun lognormal-Pinv (P zeta sigma) "gsl_cdf_lognormal_Pinv" ((P :double) (zeta :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -46,7 +46,7 @@ P(x) for the lognormal distribution with parameters zeta and sigma.") -(defun-gsl lognormal-Qinv (Q zeta sigma) +(defmfun lognormal-Qinv (Q zeta sigma) "gsl_cdf_lognormal_Qinv" ((Q :double) (zeta :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -55,29 +55,47 @@ zeta and sigma.") ;;; Examples and unit test -(lisp-unit:define-test lognormal - (lisp-unit:assert-equal - '("0.238644706813d+01" "0.116876021674d+00" "0.475337457880d+01" - "0.300933937758d+02" "0.811958437576d+00" "0.316342105516d+01" - "0.914620656772d+00" "0.727307901066d+00" "0.218018485218d+01" - "0.389088566169d+01" "0.182184697889d+03") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests lognormal + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (lognormal rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.152898339657d+00" - (lognormal-pdf 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.341328827235d+00" - (lognormal-P 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.658671172765d+00" - (lognormal-Q 1.2d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+01" - (lognormal-Pinv 0.3413288272347352d0 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.120000000000d+01" - (lognormal-Qinv 0.6586711727652649d0 1.0d0 2.0d0))) + (lognormal rng 1.0d0 2.0d0))) + (lognormal-pdf 1.2d0 1.0d0 2.0d0) + (lognormal-P 1.2d0 1.0d0 2.0d0) + (lognormal-Q 1.2d0 1.0d0 2.0d0) + (lognormal-Pinv 0.3413288272347352d0 1.0d0 2.0d0) + (lognormal-Qinv 0.6586711727652649d0 1.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST LOGNORMAL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 2.386447068127768d0 0.11687602167359055d0 + 4.753374578796263d0 30.093393775755004d0 + 0.8119584375760986d0 3.163421055157545d0 + 0.9146206567715651d0 0.727307901065758d0 + 2.180184852178898d0 3.8908856616896017d0 + 182.18469788916977d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (LOGNORMAL RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.15289833965691607d0) + (MULTIPLE-VALUE-LIST + (LOGNORMAL-PDF 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.3413288272347351d0) + (MULTIPLE-VALUE-LIST (LOGNORMAL-P 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6586711727652649d0) + (MULTIPLE-VALUE-LIST (LOGNORMAL-Q 1.2d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.2000000000000004d0) + (MULTIPLE-VALUE-LIST + (LOGNORMAL-PINV 0.3413288272347352d0 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.2d0) + (MULTIPLE-VALUE-LIST + (LOGNORMAL-QINV 0.6586711727652649d0 1.0d0 2.0d0)))) diff --git a/random/multinomial.lisp b/random/multinomial.lisp index 68c5c34451506cdae28aa5eff8a9362568ae4e6d..b628f1ea5c659e4d017139d695c8045af1258b7f 100644 --- a/random/multinomial.lisp +++ b/random/multinomial.lisp @@ -1,15 +1,15 @@ ;; Multinomial distribution ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 10:28:38EST multinomial.lisp> +;; Time-stamp: <2008-02-17 18:31:31EST multinomial.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl multinomial (generator sum p n) +(defmfun multinomial (generator sum p n) "gsl_ran_multinomial" (((generator generator) :pointer) - ((dim0 p) :size) - (sum :size) + ((dim0 p) size) + (sum size) ((gsl-array p) :pointer) ;; technically, n should be a uint array, but integers work ((gsl-array n) :pointer)) @@ -21,7 +21,7 @@ P(n_1, n_2, ..., n_K) = (N!/(n_1! n_2! ... n_K!)) p_1^n_1 p_2^n_2 ... p_K^n_K where (n_1, n_2, ..., n_K) are nonnegative integers with - sum_@{k=1@}^K n_k = N, and (p_1, p_2, ..., p_K) + sum_{k=1}^K n_k = N, and (p_1, p_2, ..., p_K) is a probability distribution with \sum p_i = 1. If the array p[K] is not normalized then its entries will be treated as weights and normalized appropriately. @@ -29,7 +29,7 @@ C.S. David, \"The computer generation of multinomial random variates,\" Comp. Stat. Data Anal. 16 (1993) 205--217 for details).") -(defun-gsl multinomial-pdf (p n) +(defmfun multinomial-pdf (p n) "gsl_ran_multinomial_pdf" (((dim0 p) :uint) ((gsl-array p) :pointer) ((gsl-array n) :pointer)) :c-return :double @@ -38,7 +38,7 @@ of sampling n[K] from a multinomial distribution with parameters p[K], using the formula given for #'multinomial.") -(defun-gsl multinomial-log-pdf (p n) +(defmfun multinomial-log-pdf (p n) "gsl_ran_multinomial_lnpdf" (((dim0 p) :uint) ((gsl-array p) :pointer) ((gsl-array n) :pointer)) :c-return :double @@ -48,23 +48,45 @@ with parameters p[K], using the formula given for #'multinomial.") ;;; Examples and unit test -(lisp-unit:define-test multinomial - (lisp-unit:assert-equalp - #(5 0 1 2) - (letm ((rng (random-number-generator *mt19937* 0)) +#| +(make-tests multinomial + (letm ((rng (random-number-generator *mt19937* 0)) (p (vector-double #(0.1d0 0.2d0 0.3d0 0.4d0))) (n (vector-fixnum 4))) (multinomial rng 8 p n) - (data n))) - (lisp-unit:assert-first-fp-equal - "0.806400000000d-04" - (letm ((p (vector-double #(0.1d0 0.2d0 0.3d0 0.4d0))) + (data n)) + (letm ((p (vector-double #(0.1d0 0.2d0 0.3d0 0.4d0))) (n (vector-fixnum 4))) (setf (data n) #(5 0 1 2)) - (multinomial-pdf p N))) - (lisp-unit:assert-first-fp-equal - "-0.942551575364d+01" - (letm ((p (vector-double #(0.1d0 0.2d0 0.3d0 0.4d0))) + (multinomial-pdf p N)) + (letm ((p (vector-double #(0.1d0 0.2d0 0.3d0 0.4d0))) (n (vector-fixnum 4))) (setf (data n) #(5 0 1 2)) - (multinomial-log-pdf p n)))) + (multinomial-log-pdf p n))) +|# + +(LISP-UNIT:DEFINE-TEST MULTINOMIAL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(5 0 1 2)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0)) + (P (VECTOR-DOUBLE #(0.1d0 0.2d0 0.3d0 0.4d0))) + (N (VECTOR-FIXNUM 4))) + (MULTINOMIAL RNG 8 P N) + (DATA N)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 8.064000000000026d-5) + (MULTIPLE-VALUE-LIST + (LETM + ((P (VECTOR-DOUBLE #(0.1d0 0.2d0 0.3d0 0.4d0))) + (N (VECTOR-FIXNUM 4))) + (SETF (DATA N) #(5 0 1 2)) (MULTINOMIAL-PDF P N)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST -9.425515753641212d0) + (MULTIPLE-VALUE-LIST + (LETM + ((P (VECTOR-DOUBLE #(0.1d0 0.2d0 0.3d0 0.4d0))) + (N (VECTOR-FIXNUM 4))) + (SETF (DATA N) #(5 0 1 2)) + (MULTINOMIAL-LOG-PDF P N))))) + diff --git a/random/negative-binomial.lisp b/random/negative-binomial.lisp index 1a5b5fb0155f5826a36d27507dd6764412f4a55e..8c41d145e917a179f9ddae76e4fbe6d023caf970 100644 --- a/random/negative-binomial.lisp +++ b/random/negative-binomial.lisp @@ -1,6 +1,6 @@ ;; Negative binomial and Pascal distributions ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 11:25:48EST negative-binomial.lisp> +;; Time-stamp: <2008-02-17 13:44:16EST negative-binomial.lisp> ;; $Id: $ (in-package :gsl) @@ -9,7 +9,7 @@ ;;;; Negative binomial ;;;;**************************************************************************** -(defun-gsl negative-binomial (generator p n) +(defmfun negative-binomial (generator p n) "gsl_ran_negative_binomial" (((generator generator) :pointer) (p :double) (n :double)) :c-return :uint @@ -21,7 +21,7 @@ p(k) = {\Gamma(n + k) \over \Gamma(k+1) \Gamma(n) } p^n (1-p)^k Note that n is not required to be an integer.") -(defun-gsl negative-binomial-pdf (k p n) +(defmfun negative-binomial-pdf (k p n) "gsl_ran_negative_binomial_pdf" ((k :uint) (p :double) (n :double)) :c-return :double :documentation ; FDL @@ -29,7 +29,7 @@ from a negative binomial distribution with parameters p and n, using the formula given in #'negative-binomial.") -(defun-gsl negative-binomial-P (k p n) +(defmfun negative-binomial-P (k p n) "gsl_cdf_negative_binomial_P" ((k :uint) (p :double) (n :double)) :c-return :double :documentation ; FDL @@ -37,7 +37,7 @@ P(k) for the negative binomial distribution with parameters p and n.") -(defun-gsl negative-binomial-Q (k p n) +(defmfun negative-binomial-Q (k p n) "gsl_cdf_negative_binomial_Q" ((k :uint) (p :double) (n :double)) :c-return :double :documentation ; FDL @@ -49,7 +49,7 @@ ;;;; Pascal ;;;;**************************************************************************** -(defun-gsl pascal (generator p n) +(defmfun pascal (generator p n) "gsl_ran_pascal" (((generator generator) :pointer) (p :double) (n :uint)) :c-return :uint @@ -60,7 +60,7 @@ p(k) = {(n + k - 1)! \over k! (n - 1)! } p^n (1-p)^k k >= 0.") -(defun-gsl pascal-pdf (k p n) +(defmfun pascal-pdf (k p n) "gsl_ran_pascal_pdf" ((k :uint) (p :double) (n :uint)) :c-return :double :documentation ; FDL @@ -68,7 +68,7 @@ from a Pascal distribution with parameters p and n, using the formula given in #'pascal.") -(defun-gsl pascal-P (k p n) +(defmfun pascal-P (k p n) "gsl_cdf_pascal_P" ((k :uint) (p :double) (n :uint)) :c-return :double :documentation ; FDL @@ -76,7 +76,7 @@ P(k) for the Pascal distribution with parameters p and n.") -(defun-gsl pascal-Q (k p n) +(defmfun pascal-Q (k p n) "gsl_cdf_pascal_Q" ((k :uint) (p :double) (n :uint)) :c-return :double :documentation ; FDL @@ -88,34 +88,56 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test negative-binomial - (lisp-unit:assert-equal - '(10 7 12 23 20 24 18 12 4 22 15) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests negative-binomial + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (negative-binomial rng 0.4d0 12.0d0)))) - (lisp-unit:assert-first-fp-equal - "0.569847670899d-02" - (negative-binomial-pdf 5 0.4d0 12.0d0)) - (lisp-unit:assert-first-fp-equal - "0.105942025555d-01" - (negative-binomial-P 5 0.4d0 12.0d0)) - (lisp-unit:assert-first-fp-equal - "0.989405797444d+00" - (negative-binomial-Q 5 0.4d0 12.0d0)) - (lisp-unit:assert-equal - '(10 7 12 23 20 24 18 12 4 22 15) - (letm ((rng (random-number-generator *mt19937* 0))) + (negative-binomial rng 0.4d0 12.0d0))) + (negative-binomial-pdf 5 0.4d0 12.0d0) + (negative-binomial-P 5 0.4d0 12.0d0) + (negative-binomial-Q 5 0.4d0 12.0d0) + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (pascal rng 0.4d0 12)))) - (lisp-unit:assert-first-fp-equal - "0.569847670899d-02" - (pascal-pdf 5 0.4d0 12)) - (lisp-unit:assert-first-fp-equal - "0.105942025555d-01" - (pascal-P 5 0.4d0 12)) - (lisp-unit:assert-first-fp-equal - "0.989405797444d+00" - (pascal-Q 5 0.4d0 12))) + (pascal rng 0.4d0 12))) + (pascal-pdf 5 0.4d0 12) + (pascal-P 5 0.4d0 12) + (pascal-Q 5 0.4d0 12)) +|# + +(LISP-UNIT:DEFINE-TEST NEGATIVE-BINOMIAL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 10 7 12 23 20 24 18 12 4 22 15)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (NEGATIVE-BINOMIAL RNG 0.4d0 12.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.0056984767089869d0) + (MULTIPLE-VALUE-LIST + (NEGATIVE-BINOMIAL-PDF 5 0.4d0 12.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.010594202555514881d0) + (MULTIPLE-VALUE-LIST + (NEGATIVE-BINOMIAL-P 5 0.4d0 12.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9894057974444851d0) + (MULTIPLE-VALUE-LIST + (NEGATIVE-BINOMIAL-Q 5 0.4d0 12.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 10 7 12 23 20 24 18 12 4 22 15)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (PASCAL RNG 0.4d0 12))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.0056984767089869d0) + (MULTIPLE-VALUE-LIST (PASCAL-PDF 5 0.4d0 12))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.010594202555514881d0) + (MULTIPLE-VALUE-LIST (PASCAL-P 5 0.4d0 12))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9894057974444851d0) + (MULTIPLE-VALUE-LIST (PASCAL-Q 5 0.4d0 12)))) + diff --git a/random/pareto.lisp b/random/pareto.lisp index f269b1855d4558847a83d4d52233b5ab5f8eb082..3d279e742341038ba158e1bea5df3483dae60543 100644 --- a/random/pareto.lisp +++ b/random/pareto.lisp @@ -1,11 +1,11 @@ ;; Pareto distribution ;; Liam Healy, Sat Oct 8 2006 - 21:23 -;; Time-stamp: <2008-02-03 10:33:14EST pareto.lisp> +;; Time-stamp: <2008-02-17 13:23:00EST pareto.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl pareto (generator a b) +(defmfun pareto (generator a b) "gsl_ran_pareto" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = (a/b) / (x/b)^{a+1} dx x >= b.") -(defun-gsl pareto-pdf (x a b) +(defmfun pareto-pdf (x a b) "gsl_ran_pareto_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -23,28 +23,28 @@ for a Pareto distribution with exponent a and scale b, using the formula given in #'pareto.") -(defun-gsl pareto-P (x a b) +(defmfun pareto-P (x a b) "gsl_cdf_pareto_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the Pareto distribution with exponent a and scale b.") -(defun-gsl pareto-Q (x a b) +(defmfun pareto-Q (x a b) "gsl_cdf_pareto_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the Pareto distribution with exponent a and scale b.") -(defun-gsl pareto-Pinv (P a b) +(defmfun pareto-Pinv (P a b) "gsl_cdf_pareto_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the Pareto distribution with exponent a and scale b.") -(defun-gsl pareto-Qinv (Q a b) +(defmfun pareto-Qinv (Q a b) "gsl_cdf_pareto_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -52,29 +52,47 @@ Q(x) for the Pareto distribution with exponent a and scale b.") ;;; Examples and unit test -(lisp-unit:define-test pareto - (lisp-unit:assert-equal - '("0.200051663561d+01" "0.122767265962d+02" "0.707669496594d+01" - "0.211148407447d+01" "0.863347081110d+01" "0.412393569645d+01" - "0.208882311615d+01" "0.268706924980d+01" "0.370340428797d+01" - "0.270287443943d+01" "0.263177356639d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests pareto + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (pareto rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.511603440571d+00" - (pareto-pdf 1.5d0 1.3d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.516884983518d+00" - (pareto-P 3.5d0 1.3d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.483115016482d+00" - (pareto-Q 3.5d0 1.3d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.350000000000d+01" - (pareto-Pinv 0.5168849835182453d0 1.3d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.350000000000d+01" - (pareto-Qinv 0.4831150164817547d0 1.3d0 2.0d0))) + (pareto rng 1.0d0 2.0d0))) + (pareto-pdf 1.5d0 1.3d0 1.0d0) + (pareto-P 3.5d0 1.3d0 2.0d0) + (pareto-Q 3.5d0 1.3d0 2.0d0) + (pareto-Pinv 0.5168849835182453d0 1.3d0 2.0d0) + (pareto-Qinv 0.4831150164817547d0 1.3d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST PARETO + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 2.0005166356083666d0 12.276726596218747d0 + 7.076694965937239d0 2.111484074469764d0 + 8.633470811095883d0 4.123935696449152d0 + 2.0888231161547828d0 2.6870692498025632d0 + 3.703404287965457d0 2.7028744394290123d0 + 2.631773566385122d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (PARETO RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5116034405707658d0) + (MULTIPLE-VALUE-LIST (PARETO-PDF 1.5d0 1.3d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5168849835182453d0) + (MULTIPLE-VALUE-LIST (PARETO-P 3.5d0 1.3d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.4831150164817547d0) + (MULTIPLE-VALUE-LIST (PARETO-Q 3.5d0 1.3d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 3.5000000000000004d0) + (MULTIPLE-VALUE-LIST + (PARETO-PINV 0.5168849835182453d0 1.3d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 3.5000000000000004d0) + (MULTIPLE-VALUE-LIST + (PARETO-QINV 0.4831150164817547d0 1.3d0 2.0d0)))) + diff --git a/random/poisson.lisp b/random/poisson.lisp index e12c9fa794cee1c63861c0a5067ae9b119141661..673baae6479938a54d41a2d54ecee3438ca8d8ca 100644 --- a/random/poisson.lisp +++ b/random/poisson.lisp @@ -1,11 +1,11 @@ ;; Poisson distribution ;; Liam Healy, Sat Nov 25 2006 - 16:00 -;; Time-stamp: <2008-02-03 09:50:16EST poisson.lisp> +;; Time-stamp: <2008-02-17 13:38:14EST poisson.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl poisson (generator mu) +(defmfun poisson (generator mu) "gsl_ran_poisson" (((generator generator) :pointer) (mu :double)) :c-return :uint @@ -15,7 +15,7 @@ p(k) = {\mu^k \over k!} \exp(-\mu) k >= 0.") -(defun-gsl poisson-pdf (k mu) +(defmfun poisson-pdf (k mu) "gsl_ran_poisson_pdf" ((k :uint) (mu :double)) :c-return :double :documentation ; FDL @@ -23,14 +23,14 @@ from a Poisson distribution with mean mu using the formula given in #'poisson.") -(defun-gsl poisson-P (k mu) +(defmfun poisson-P (k mu) "gsl_cdf_poisson_P" ((k :uint) (mu :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(k) for the Poisson distribution with parameter mu.") -(defun-gsl poisson-Q (k mu) +(defmfun poisson-Q (k mu) "gsl_cdf_poisson_Q" ((k :uint) (mu :double)) :c-return :double :documentation ; FDL @@ -38,19 +38,31 @@ Q(k) for the Poisson distribution with parameter mu.") ;;; Examples and unit test -(lisp-unit:define-test poisson - (lisp-unit:assert-equal - '(15 6 9 9 5 8 11 9 11 5 10) - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests poisson + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (poisson rng 10.0d0)))) - (lisp-unit:assert-first-fp-equal - "0.112599032149d+00" - (poisson-pdf 8 10.0d0)) - (lisp-unit:assert-first-fp-equal - "0.332819678751d+00" - (poisson-P 8 10.0d0)) - (lisp-unit:assert-first-fp-equal - "0.667180321249d+00" - (poisson-Q 8 10.0d0))) + (poisson rng 10.0d0))) + (poisson-pdf 8 10.0d0) + (poisson-P 8 10.0d0) + (poisson-Q 8 10.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST POISSON + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 15 6 9 9 5 8 11 9 11 5 10)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (POISSON RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.11259903214902009d0) + (MULTIPLE-VALUE-LIST (POISSON-PDF 8 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.3328196787507177d0) + (MULTIPLE-VALUE-LIST (POISSON-P 8 10.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6671803212492823d0) + (MULTIPLE-VALUE-LIST (POISSON-Q 8 10.0d0)))) + diff --git a/random/quasi.lisp b/random/quasi.lisp index f40f05c58ec717465020a42585b04fefeff2a758..f30d8afca7516e3712ca27dda9683e88d01f317f 100644 --- a/random/quasi.lisp +++ b/random/quasi.lisp @@ -1,6 +1,6 @@ ;; Quasi-random sequences in arbitrary dimensions. ;; Liam Healy, Sun Jul 16 2006 - 15:54 -;; Time-stamp: <2008-02-03 13:22:46EST quasi.lisp> +;; Time-stamp: <2008-02-17 12:19:07EST quasi.lisp> ;; $Id: $ (in-package :gsl) @@ -27,7 +27,7 @@ :generator generator))) (if (eq generator t) (alloc instance) instance))) -(defun-gsl alloc ((generator quasi-random-number-generator)) +(defmfun alloc ((generator quasi-random-number-generator)) "gsl_qrng_alloc" (((rng-type generator) :pointer) ((qr-dimension generator) :uint)) :type :method @@ -41,7 +41,7 @@ *default-seed*. This is zero by default but can be changed either directly or by using the environment variable GSL_RNG_SEED.") -(defun-gsl free ((generator quasi-random-number-generator)) +(defmfun free ((generator quasi-random-number-generator)) "gsl_qrng_free" (((generator generator) :pointer)) :type :method :c-return :void @@ -49,7 +49,7 @@ :documentation ; FDL "Free all the memory associated with the generator.") -(defun-gsl init (generator) +(defmfun init (generator) "gsl_qrng_init" (((generator generator) :pointer)) :c-return :void :documentation ; FDL @@ -57,7 +57,7 @@ Note that quasi-random sequences do not use a seed and always produce the same set of values.") -(defun-gsl qrng-get (generator return-vector) +(defmfun qrng-get (generator return-vector) "gsl_qrng_get" (((generator generator) :pointer) ((gsl-array return-vector) :pointer)) :documentation ; FDL @@ -67,26 +67,26 @@ 0 < x_i < 1 for each x_i." :invalidate (return-vector)) -(defun-gsl rng-name ((instance quasi-random-number-generator)) +(defmfun rng-name ((instance quasi-random-number-generator)) "gsl_qrng_name" (((generator instance) :pointer)) :type :method :c-return :string) -(defun-gsl rng-state ((instance quasi-random-number-generator)) +(defmfun rng-state ((instance quasi-random-number-generator)) "gsl_qrng_state" (((generator instance) :pointer)) :c-return :pointer :type :method :export nil :index gsl-random-state) -(defun-gsl rng-size ((instance quasi-random-number-generator)) +(defmfun rng-size ((instance quasi-random-number-generator)) "gsl_qrng_size" (((generator instance) :pointer)) - :c-return :size + :c-return size :type :method :export nil :index gsl-random-state) -(defun-gsl copy +(defmfun copy ((destination quasi-random-number-generator) (source quasi-random-number-generator)) "gsl_qrng_memcpy" @@ -97,7 +97,7 @@ pre-existing generator dest, making dest into an exact copy of src. The two generators must be of the same type.") -(defun-gsl clone-generator ((instance quasi-random-number-generator)) +(defmfun clone-generator ((instance quasi-random-number-generator)) "gsl_qrng_clone" (((generator instance) :pointer)) :c-return :pointer :type :method @@ -119,17 +119,30 @@ (def-rng-type *sobol* ;; FDL "This generator uses the Sobol sequence described in Antonov, Saleev, - @cite{USSR Comput. Maths. Math. Phys.} 19, 252 (1980). It is valid up to + USSR Comput. Maths. Math. Phys. 19, 252 (1980). It is valid up to 40 dimensions." "gsl_qrng_sobol") ;;; Examples and unit test -(lisp-unit:define-test quasi-random-number-generators +#| +(make-tests quasi-random-number-generators ;; This example is given in the GSL documentation - (lisp-unit:assert-equal - '(0.5d0 0.5d0 0.75d0 0.25d0 0.25d0 0.75d0 0.375d0 0.375d0 0.875d0 0.875d0) - (letm ((gen (quasi-random-number-generator 2 *sobol*)) + (letm ((gen (quasi-random-number-generator 2 *sobol*)) (vec (vector-double 2))) (loop repeat 5 do (qrng-get gen vec) - append (coerce (data vec) 'list))))) + append (coerce (data vec) 'list)))) +|# + +(LISP-UNIT:DEFINE-TEST QUASI-RANDOM-NUMBER-GENERATORS + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.5d0 0.5d0 0.75d0 0.25d0 0.25d0 0.75d0 0.375d0 + 0.375d0 0.875d0 0.875d0)) + (MULTIPLE-VALUE-LIST + (LETM + ((GEN (QUASI-RANDOM-NUMBER-GENERATOR 2 *SOBOL*)) + (VEC (VECTOR-DOUBLE 2))) + (LOOP REPEAT 5 DO (QRNG-GET GEN VEC) APPEND + (COERCE (DATA VEC) 'LIST)))))) + diff --git a/random/rayleigh-tail.lisp b/random/rayleigh-tail.lisp index 2d6f00edac40fd54ee1ddfae654c1d83e17d3627..1245216b1e741d78bb3a963f85cae1ab78644e50 100644 --- a/random/rayleigh-tail.lisp +++ b/random/rayleigh-tail.lisp @@ -1,11 +1,11 @@ ;; Rayleigh tail distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 09:47:12EST rayleigh-tail.lisp> +;; Time-stamp: <2008-02-17 13:00:06EST rayleigh-tail.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl rayleigh-tail (generator a sigma) +(defmfun rayleigh-tail (generator a sigma) "gsl_ran_rayleigh_tail" (((generator generator) :pointer) (a :double) (sigma :double)) :c-return :double @@ -16,7 +16,7 @@ p(x) dx = {x \over \sigma^2} \exp ((a^2 - x^2) /(2 \sigma^2)) dx for x > a.") -(defun-gsl rayleigh-tail-pdf (x a sigma) +(defmfun rayleigh-tail-pdf (x a sigma) "gsl_ran_rayleigh_tail_pdf" ((x :double) (a :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -25,16 +25,28 @@ lower limit a, using the formula given in #'rayleigh-tail.") ;;; Examples and unit test -(lisp-unit:define-test rayleigh-tail - (lisp-unit:assert-equal - '("0.102550323704d+01" "0.190764679267d+02" "0.159289661023d+02" - "0.344220488991d+01" "0.171318383334d+02" "0.120719575294d+02" - "0.311299291669d+01" "0.774988930120d+01" "0.111454501381d+02" - "0.782519818732d+01" "0.747677468155d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests rayleigh-tail + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 - collect (rayleigh-tail rng 1.0d0 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.102243176249d+00" - (rayleigh-tail-pdf 0.25d0 -2.0d0 2.0d0))) + collect (rayleigh-tail rng 1.0d0 10.0d0))) + (rayleigh-tail-pdf 0.25d0 -2.0d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST RAYLEIGH-TAIL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 1.0255032370386696d0 19.0764679267351d0 + 15.928966102255199d0 3.4422048899106383d0 + 17.131838333441106d0 12.071957529361999d0 + 3.112992916690818d0 7.749889301203328d0 + 11.145450138119857d0 7.825198187316554d0 + 7.476774681552917d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (RAYLEIGH-TAIL RNG 1.0d0 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.10224317624874313d0) + (MULTIPLE-VALUE-LIST + (RAYLEIGH-TAIL-PDF 0.25d0 -2.0d0 2.0d0)))) diff --git a/random/rayleigh.lisp b/random/rayleigh.lisp index 7f66f1e3e1867cc9ca8e9e4889014c24e3ef83a5..0c0d144c65b6671b00879f0eb9adff60a85c6b93 100644 --- a/random/rayleigh.lisp +++ b/random/rayleigh.lisp @@ -1,11 +1,11 @@ ;; Rayleigh distribution ;; Liam Healy, Sat Sep 30 2006 -;; Time-stamp: <2008-02-03 11:29:48EST rayleigh.lisp> +;; Time-stamp: <2008-02-17 18:45:41EST rayleigh.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl rayleigh (generator sigma) +(defmfun rayleigh (generator sigma) "gsl_ran_rayleigh" (((generator generator) :pointer) (sigma :double)) :c-return :double @@ -15,7 +15,7 @@ p(x) dx = {x \over \sigma^2} \exp(- x^2/(2 \sigma^2)) dx for x > 0.") -(defun-gsl rayleigh-pdf (x sigma) +(defmfun rayleigh-pdf (x sigma) "gsl_ran_rayleigh_pdf" ((x :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -23,7 +23,7 @@ for a Rayleigh distribution with scale parameter sigma, using the formula given for #'rayleigh.") -(defun-gsl rayleigh-P (x sigma) +(defmfun rayleigh-P (x sigma) "gsl_cdf_rayleigh_P" ((x :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -31,7 +31,7 @@ P(x) for the Rayleigh distribution with scale parameter sigma.") -(defun-gsl rayleigh-Q (x sigma) +(defmfun rayleigh-Q (x sigma) "gsl_cdf_rayleigh_Q" ((x :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -39,7 +39,7 @@ Q(x) for the Rayleigh distribution with scale parameter sigma.") -(defun-gsl rayleigh-Pinv (P sigma) +(defmfun rayleigh-Pinv (P sigma) "gsl_cdf_rayleigh_Pinv" ((P :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -47,7 +47,7 @@ P(x)} for the Rayleigh distribution with scale parameter sigma.") -(defun-gsl rayleigh-Qinv (Q sigma) +(defmfun rayleigh-Qinv (Q sigma) "gsl_cdf_rayleigh_Qinv" ((Q :double) (sigma :double)) :c-return :double :documentation ; FDL @@ -56,29 +56,47 @@ parameter sigma.") ;;; Examples and unit test -(lisp-unit:define-test rayleigh - (lisp-unit:assert-equal - '("0.227281519655d+00" "0.190502395932d+02" "0.158975457567d+02" - "0.329374779000d+01" "0.171026280052d+02" "0.120304679290d+02" - "0.294800354467d+01" "0.768510144246d+01" "0.111004981321d+02" - "0.776103902005d+01" "0.740959915506d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests rayleigh + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (rayleigh rng 10.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.441248451292d+00" - (rayleigh-pdf 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.117503097415d+00" - (rayleigh-P 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.882496902585d+00" - (rayleigh-Q 1.0d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (rayleigh-Pinv 0.1175030974154046d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "1.000000000000d+00" - (rayleigh-Qinv 0.8824969025845955d0 2.0d0))) + (rayleigh rng 10.0d0))) + (rayleigh-pdf 0.5d0 1.0d0) + (rayleigh-P 1.0d0 2.0d0) + (rayleigh-Q 1.0d0 2.0d0) + (rayleigh-Pinv 0.1175030974154046d0 2.0d0) + (rayleigh-Qinv 0.8824969025845955d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST RAYLEIGH + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.22728151965522753d0 19.05023959323748d0 + 15.897545756713367d0 3.2937477899992147d0 + 17.102628005168157d0 12.030467929000928d0 + 2.9480035446666624d0 7.6851014424603274d0 + 11.100498132125239d0 7.76103902005281d0 + 7.409599155063027d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (RAYLEIGH RNG 10.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.4412484512922977d0) + (MULTIPLE-VALUE-LIST (RAYLEIGH-PDF 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.1175030974154046d0) + (MULTIPLE-VALUE-LIST (RAYLEIGH-P 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.8824969025845955d0) + (MULTIPLE-VALUE-LIST (RAYLEIGH-Q 1.0d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0000000000000002d0) + (MULTIPLE-VALUE-LIST + (RAYLEIGH-PINV 0.1175030974154046d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9999999999999998d0) + (MULTIPLE-VALUE-LIST + (RAYLEIGH-QINV 0.8824969025845955d0 2.0d0)))) + diff --git a/random/rng-types.lisp b/random/rng-types.lisp index 246f08846d5bd79eb3035f44ccdaa5091cfa3d4b..e000621f5cc7cfb871320daf6466e9db46487911 100644 --- a/random/rng-types.lisp +++ b/random/rng-types.lisp @@ -1,6 +1,6 @@ ;; Random number generation ;; Liam Healy, Tue Jul 11 2006 - 23:39 -;; Time-stamp: <2008-01-19 17:45:53EST rng-types.lisp> +;; Time-stamp: <2008-02-17 12:07:47EST rng-types.lisp> ;; $Id: $ ;;; Random number generator types and information functions. @@ -16,7 +16,7 @@ (name :pointer) (max :unsigned-long) (min :unsigned-long) - (size :size) + (size size) (set :pointer) (get :pointer) (get-double :pointer)) @@ -27,7 +27,7 @@ (export '(all-random-number-generators)) -(defun-gsl rng-types-setup () +(defmfun rng-types-setup () "gsl_rng_types_setup" () :c-return :pointer :export nil @@ -60,55 +60,46 @@ (substitute #\_ #\- (format nil "gsl_rng_~(~a~)" lisp-name)))))) - `(defvariable ,lisp-name ,cname ,documentation))) + `(defmpar ,lisp-name ,cname ,documentation))) (def-rng-type *default-type* "The default random number generator type, set by environment variables GSL_RNG_TYPE and GSL_RNG_SEED" "gsl_rng_default") -(defun-gsl rng-environment-setup () +(defmfun rng-environment-setup () "gsl_rng_env_setup" () :c-return :pointer - :documentation "Read the environment variables @code{GSL_RNG_TYPE} and - @code{GSL_RNG_SEED} and use their values to set the corresponding + :documentation ; FDL + "Read the environment variables GSL_RNG_TYPE and + GSL_RNG_SEED and use their values to set the corresponding library variables *default-type* and *default-seed*") ;;;;**************************************************************************** ;;;; Modern random number generators ;;;;**************************************************************************** -(def-rng-type *cmrg* +(def-rng-type *cmrg* ; FDL "Combined multiple recursive random number generator This is a combined multiple recursive generator by L'Ecuyer. Its sequence is z_n = (x_n - y_n) mod m_1 - where the two underlying generators @math{x_n} and @math{y_n} are, - x_n = (a_1 x_@{n-1@} + a_2 x_@{n-2@} + a_3 x_@{n-3@}) mod m_1 - y_n = (b_1 y_@{n-1@} + b_2 y_@{n-2@} + b_3 y_@{n-3@}) mod m_2 + where the two underlying generators x_n and y_n are, + x_n = (a_1 x_{n-1} + a_2 x_{n-2} + a_3 x_{n-3}) mod m_1 + y_n = (b_1 y_{n-1} + b_2 y_{n-2} + b_3 y_{n-3}) mod m_2 with coefficients - @math{a_1 = 0}, - @math{a_2 = 63308}, - @math{a_3 = -183326}, - @math{b_1 = 86098}, - @math{b_2 = 0}, - @math{b_3 = -539608}, + a_1 = 0, a_2 = 63308, a_3 = -183326, + b_1 = 86098, b_2 = 0, b_3 = -539608, and moduli - @math{m_1 = 2^31 - 1 = 2147483647} - and - @math{m_2 = 2145483479}. - The period of this generator is - @math{2^205} - (about - @c{$10^{61}$} - @math{10^61}). It uses - 6 words of state per generator. For more information see, - P. L'Ecuyer, ``Combined Multiple Recursive Random Number - Generators'', @cite{Operations Research}, 44, 5 (1996), 816--822.") - -(def-rng-type *gfsr4* + m_1 = 2^31 - 1 = 2147483647 and m_2 = 2145483479. + The period of this generator is 2^205 (about 10^61). It uses + 6 words of state per generator. For more information see, + P. L'Ecuyer, ``Combined Multiple Recursive Random Number + Generators'', Operations Research, 44, 5 (1996), 816--822.") + +(def-rng-type *gfsr4* ; FDL "Four-tap Generalized Feedback Shift Register - The @code{gfsr4} generator is like a lagged-fibonacci generator, and - produces each number as an @code{xor}'d sum of four previous values. + The *gfsr4* generator is like a lagged-Fibonacci generator, and + produces each number as an xor'd sum of four previous values. r_n = r_{n-A} \oplus r_{n-B} \oplus r_{n-C} \oplus r_{n-D} Ziff (ref below) notes that ``it is now widely known'' that two-tap registers (such as R250, which is described below) @@ -119,14 +110,14 @@ random as can be measured, using the author's test. This implementation uses the values suggested the example on p392 of - Ziff's article: @math{A=471}, @math{B=1586}, @math{C=6988}, @math{D=9689}. + Ziff's article: A=471, B=1586, C=6988, D=9689. If the offsets are appropriately chosen (such as the one ones in this implementation), then the sequence is said to be maximal; that means - that the period is @math{2^D - 1}, where @math{D} is the longest lag. - (It is one less than @math{2^D} because it is not permitted to have all - zeros in the @code{ra[]} array.) For this implementation with - @math{D=9689} that works out to about @math{10^2917}. + that the period is 2^D - 1, where D is the longest lag. + (It is one less than 2^D because it is not permitted to have all + zeros in the ra array.) For this implementation with + D=9689 that works out to about 10^2917. Note that the implementation of this generator using a 32-bit integer amounts to 32 parallel implementations of one-bit @@ -139,50 +130,46 @@ For more information see, Robert M. Ziff, ``Four-tap shift-register-sequence random-number - generators'', @cite{Computers in Physics}, 12(4), Jul/Aug + generators'', Computers in Physics, 12(4), Jul/Aug 1998, pp 385--392.") -(def-rng-type *mrg* +(def-rng-type *mrg* ; FDL "Multiple recursive random number generator This is a fifth-order multiple recursive generator by L'Ecuyer, Blouin and Coutre. Its sequence is - x_n = (a_1 x_@{n-1@} + a_5 x_@{n-5@}) mod m - with - @math{a_1 = 107374182}, - @math{a_2 = a_3 = a_4 = 0}, - @math{a_5 = 104480} - and - @math{m = 2^31 - 1}. - The period of this generator is about @math{10^46}. It uses 5 words + x_n = (a_1 x_{n-1} + a_5 x_{n-5}) mod m + with a_1 = 107374182, a_2 = a_3 = a_4 = 0, a_5 = 104480 and m = 2^31 - 1. + The period of this generator is about 10^46. It uses 5 words of state per generator. More information can be found in the following paper, P. L'Ecuyer, F. Blouin, and R. Coutre, ``A search for good multiple - recursive random number generators'', @cite{ACM Transactions on Modeling and - Computer Simulation} 3, 87--98 (1993).") + recursive random number generators'', ACM Transactions on Modeling and + Computer Simulation 3, 87--98 (1993).") -(def-rng-type *mt19937* +(def-rng-type *mt19937* ; FDL "The MT19937 generator of Makoto Matsumoto and Takuji Nishimura is a variant of the twisted generalized feedback shift-register algorithm, and is known as the ``Mersenne Twister'' generator. It has a Mersenne - prime period of @math{2^19937 - 1} (about @math{10^6000}) and is - equi-distributed in 623 dimensions. It has passed the @sc{diehard} + prime period of 2^19937 - 1 (about 10^6000) and is + equi-distributed in 623 dimensions. It has passed the diehard statistical tests. It uses 624 words of state per generator and is comparable in speed to the other generators. The original generator used - a default seed of 4357 and choosing @var{s} equal to zero in - @code{gsl_rng_set} reproduces this. - For more information see, + a default seed of 4357 and choosing s equal to zero in #'rng-set + reproduces this. For more information see, Makoto Matsumoto and Takuji Nishimura, ``Mersenne Twister: A 623-dimensionally equidistributed uniform pseudorandom number - generator''. @cite{ACM Transactions on Modeling and Computer - Simulation}, Vol.@: 8, No.@: 1 (Jan. 1998), Pages 3--30 - The generator @code{gsl_rng_mt19937} uses the second revision of the + generator'' ACM Transactions on Modeling and Computer + Simulation, Vol. 8, No. 1 (Jan. 1998), Pages 3--30 + This generator uses the second revision of the seeding procedure published by the two authors above in 2002. The original seeding procedures could cause spurious artifacts for some seed values. They are still available through the alternative generators") -(def-rng-type *mt19937_1999* "Previous version of mt19937.") +(def-rng-type *mt19937_1999* ; FDL + "Previous version of mt19937.") -(def-rng-type *mt19937_1998* "Previous version of mt19937.") +(def-rng-type *mt19937_1998* ; FDL + "Previous version of mt19937.") (def-rng-type *ran0*) @@ -192,42 +179,41 @@ (def-rng-type *ran3*) -(def-rng-type *ranlux* - "The @code{ranlux} generator is an implementation of the original +(def-rng-type *ranlux* ; FDL + "The ranlux generator is an implementation of the original algorithm developed by Lüscher. It uses a lagged-fibonacci-with-skipping algorithm to produce ``luxury random numbers''. It is a 24-bit generator, originally designed for single-precision IEEE floating point numbers. This implementation is based on integer arithmetic, while the second-generation versions - @sc{ranlxs} and @sc{ranlxd} described above provide floating-point + ranlxs and ranlxd described above provide floating-point implementations which will be faster on many platforms. - The period of the generator is about @c{$10^{171}$} - @math{10^171}. The algorithm has mathematically proven properties and + The period of the generator is about + 10^171. The algorithm has mathematically proven properties and it can provide truly decorrelated numbers at a known level of randomness. The default level of decorrelation recommended by Lüscher - is provided by @code{gsl_rng_ranlux}, while @code{gsl_rng_ranlux389} + is provided by this generator, while *ranlux389* gives the highest level of randomness, with all 24 bits decorrelated. Both types of generator use 24 words of state per generator. For more information see, M. Lüscher, ``A portable high-quality random number generator for - lattice field theory calculations'', @cite{Computer Physics - Communications}, 79 (1994) 100--110. + lattice field theory calculations'', Computer Physics + Communications, 79 (1994) 100--110. F. James, ``RANLUX: A Fortran implementation of the high-quality - pseudo-random number generator of Lüscher'', @cite{Computer Physics - Communications}, 79 (1994) 111--114.") + pseudo-random number generator of Lüscher'', Computer Physics + Communications, 79 (1994) 111--114.") (def-rng-type *ranlux389*) (def-rng-type *ranlxs0* - "The generator @code{ranlxs0} is a second-generation version of the - @sc{ranlux} algorithm of Lüscher, which produces ``luxury random + "This generator is a second-generation version of the + *ranlux* algorithm of Lüscher, which produces ``luxury random numbers''. This generator provides single precision output (24 bits) at - three luxury levels @code{ranlxs0}, @code{ranlxs1} and @code{ranlxs2}. + three luxury levels *ranlxs0*, *ranlxs1* and *ranlxs2*. It uses double-precision floating point arithmetic internally and can be - significantly faster than the integer version of @code{ranlux}, + significantly faster than the integer version of *ranlux*, particularly on 64-bit architectures. The period of the generator is - about @c{$10^{171}$} - @math{10^171}. The algorithm has mathematically proven properties and + about 10^171. The algorithm has mathematically proven properties and can provide truly decorrelated numbers at a known level of randomness. The higher luxury levels provide increased decorrelation between samples as an additional safety margin.") @@ -236,44 +222,38 @@ (def-rng-type *ranlxs2*) -(def-rng-type *ranlxd1* - "These generators produce double precision output (48 bits) from the - @sc{ranlxs} generator. The library provides two luxury levels - @code{ranlxd1} and @code{ranlxd2}.") +(def-rng-type *ranlxd1* ; FDL + "Produce double precision output (48 bits) from the + *ranlxs* generator. The library provides two luxury levels, + *ranlxd1* and *ranlxd2*.") -(def-rng-type *ranlxd2*) +(def-rng-type *ranlxd2* ; FDL + "Produce double precision output (48 bits) from the + *ranlxs* generator. The library provides two luxury levels, + *ranlxd1* and *ranlxd2*.") -(def-rng-type *taus* +(def-rng-type *taus* ; FDL "Tausworthe random number generator This is a maximally equidistributed combined Tausworthe generator by L'Ecuyer. The sequence is x_n = (s^1_n \oplus s^2_n \oplus s^3_n) - \eqalign{ - s^1_{n+1} &= (((s^1_n \& 4294967294)\ll 12) - \oplus (((s^1_n\ll 13) \oplus s^1_n)\gg 19)) \cr - s^2_{n+1} &= (((s^2_n \& 4294967288)\ll 4) - \oplus (((s^2_n\ll 2) \oplus s^2_n)\gg 25)) \cr - s^3_{n+1} &= (((s^3_n \& 4294967280)\ll 17) - \oplus (((s^3_n\ll 3) \oplus s^3_n)\gg 11)) - } - s1_@{n+1@} = (((s1_n&4294967294)<<12)^^(((s1_n<<13)^^s1_n)>>19)) - s2_@{n+1@} = (((s2_n&4294967288)<< 4)^^(((s2_n<< 2)^^s2_n)>>25)) - s3_@{n+1@} = (((s3_n&4294967280)<<17)^^(((s3_n<< 3)^^s3_n)>>11)) - computed modulo @math{2^32}. In the formulas above @c{$\oplus$} + s1_{n+1} = (((s1_n 4294967294)<<12)^^(((s1_n<<13)^^s1_n)>>19)) + s2_{n+1} = (((s2_n 4294967288)<< 4)^^(((s2_n<< 2)^^s2_n)>>25)) + s3_{n+1} = (((s3_n 4294967280)<<17)^^(((s3_n<< 3)^^s3_n)>>11)) + computed modulo 2^32. In the formulas above ^^} denotes ``exclusive-or''. Note that the algorithm relies on the properties of 32-bit unsigned integers and has been implemented using a bitmask - of @code{0xFFFFFFFF} to make it work on 64 bit machines. - The period of this generator is @math{2^88} (about - @c{$10^{26}$} - @math{10^26}). It uses 3 words of state per generator. For more + of 0xFFFFFFFF to make it work on 64 bit machines. + The period of this generator is 2^88 (about + 10^26). It uses 3 words of state per generator. For more information see, P. L'Ecuyer, ``Maximally Equidistributed Combined Tausworthe - Generators'', @cite{Mathematics of Computation}, 65, 213 (1996), 203--213.") + Generators'', Mathematics of Computation, 65, 213 (1996), 203--213.") -(def-rng-type *taus2* +(def-rng-type *taus2* ; FDL "The same algorithm as *taus* but with an improved seeding procedure described in the paper, P. L'Ecuyer, ``Tables of Maximally Equidistributed Combined LFSR - Generators'', @cite{Mathematics of Computation}, 68, 225 (1999), 261--269 + Generators'', Mathematics of Computation, 68, 225 (1999), 261--269 The generator *taus2* should now be used in preference to *taus*.") (def-rng-type *taus113*) @@ -282,29 +262,29 @@ ;;;; UNIX random number generators ;;;;**************************************************************************** -(def-rng-type *rand* - "The BSD @code{rand()} generator. Its sequence is - x_{n+1} = (a x_n + c) mod m with @math{a = 1103515245}, - @math{c = 12345} and @math{m = 2^31}. - The seed specifies the initial value, @math{x_1}. - The period of this generator is @math{2^31}, and it uses +(def-rng-type *rand* ; FDL + "The BSD rand() generator. Its sequence is + x_{n+1} = (a x_n + c) mod m with a = 1103515245, + c = 12345 and m = 2^31. + The seed specifies the initial value, x_1. + The period of this generator is 2^31, and it uses 1 word of storage per generator.") -(def-rng-type *rand48* - "The Unix @code{rand48} generator. Its sequence is +(def-rng-type *rand48* ; FDL + "The Unix rand48 generator. Its sequence is x_{n+1} = (a x_n + c) mod m defined on 48-bit unsigned integers with - @math{a = 25214903917}, @math{c = 11} and @math{m = 2^48}. - The seed specifies the upper 32 bits of the initial value, @math{x_1}, - with the lower 16 bits set to @code{0x330E}. The function - @code{gsl_rng_get} returns the upper 32 bits from each term of the + a = 25214903917, c = 11 and m = 2^48. + The seed specifies the upper 32 bits of the initial value, x_1, + with the lower 16 bits set to 0x330E. The function + #'get-random-number returns the upper 32 bits from each term of the sequence. This does not have a direct parallel in the original - @code{rand48} functions, but forcing the result to type @code{long int} - reproduces the output of @code{mrand48}. The function - @code{gsl_rng_uniform} uses the full 48 bits of internal state to return - the double precision number @math{x_n/m}, which is equivalent to the - function @code{drand48}. Note that some versions of the GNU C Library - contained a bug in @code{mrand48} function which caused it to produce + rand48 functions, but forcing the result to type long int + reproduces the output of mrand48. The function + #'uniform uses the full 48 bits of internal state to return + the double precision number x_n/m, which is equivalent to the + function drand48. Note that some versions of the GNU C Library + contained a bug in mrand48 function which caused it to produce different results (only the lower 16-bits of the return value were set).") (def-rng-type *random128_bsd*) @@ -330,6 +310,7 @@ ;;;; Obsolete random number generators ;;;;**************************************************************************** +;;; FDL ;;; Other random number generators ;;; The generators in this section are provided for compatibility with @@ -343,43 +324,41 @@ ;;; linear congruence relations, which are the least sophisticated type of ;;; generator. In particular, linear congruences have poor properties when ;;; used with a non-prime modulus, as several of these routines do (e.g. -;;; with a power of two modulus, -;;; @c{$2^{31}$} -;;; @math{2^31} or -;;; @c{$2^{32}$} -;;; @math{2^32}). This +;;; with a power of two modulus, 2^31 or 2^32). This ;;; leads to periodicity in the least significant bits of each number, ;;; with only the higher bits having any randomness. Thus if you want to ;;; produce a random bitstream it is best to avoid using the least ;;; significant bits. -(def-rng-type *ranf* "Obsolete, use only for compatibility.") +(def-rng-type *ranf* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *ranmar* "Obsolete, use only for compatibility.") +(def-rng-type *ranmar* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *r250* +(def-rng-type *r250* ; FDL "Obsolete, use only for compatibility. The shift-register generator of Kirkpatrick and Stoll. The sequence is based on the recurrence - x_n = x_{n-103} \oplus x_{n-250} where @c{$\oplus$} + x_n = x_{n-103} \oplus x_{n-250} where \oplus denotes ``exclusive-or'', defined on 32-bit words. - The period of this generator is about @math{2^250} and it + The period of this generator is about 2^250 and it uses 250 words of state per generator. For more information see, S. Kirkpatrick and E. Stoll, ``A very fast shift-register sequence random - number generator'', @cite{Journal of Computational Physics}, 40, 517--526 + number generator'', Journal of Computational Physics}, 40, 517--526 (1981)") -(def-rng-type *tt800* +(def-rng-type *tt800* ; FDL "Obsolete, use only for compatibility. An earlier version of the twisted generalized feedback shift-register generator, and has been superseded by the development of MT19937. However, it is still an acceptable generator in its own - right. It has a period of @math{2^800} and uses 33 words of storage + right. It has a period of 2^800 and uses 33 words of storage per generator. For more information see, Makoto Matsumoto and Yoshiharu Kurita, ``Twisted GFSR Generators - II'', @cite{ACM Transactions on Modelling and Computer Simulation}, + II'', ACM Transactions on Modelling and Computer Simulation, Vol.: 4, No.: 3, 1994, pages 254--266.") ;;; The following generators are included only for historical reasons, so @@ -387,112 +366,117 @@ ;;; them. These generators should not be used for real simulations since ;;; they have poor statistical properties by modern standards. -(def-rng-type *vax* "Obsolete, use only for compatibility.") +(def-rng-type *vax* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *transputer* "Obsolete, use only for compatibility.") +(def-rng-type *transputer* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *randu* "Obsolete, use only for compatibility.") +(def-rng-type *randu* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *minstd* +(def-rng-type *minstd* ;FDL "Obsolete, use only for compatibility. - Park and Miller's ``minimal standard'' @sc{minstd} generator, a + Park and Miller's ``minimal standard'' minstd generator, a simple linear congruence which takes care to avoid the major pitfalls of - such algorithms. Its sequence is x_@{n+1@} = (a x_n) mod m - with @math{a = 16807} and @math{m = 2^31 - 1 = 2147483647}. - The seed specifies the initial value, @math{x_1}. The period of this - generator is about @math{2^31}. + such algorithms. Its sequence is x_{n+1} = (a x_n) mod m + with a = 16807 and m = 2^31 - 1 = 2147483647. + The seed specifies the initial value, x_1. The period of this + generator is about 2^31. This generator is used in the IMSL Library (subroutine RNUN) and in MATLAB (the RAND function). It is also sometimes known by the acronym ``GGL'' (I'm not sure what that stands for). For more information see Park and Miller, ``Random Number Generators: Good ones are hard to find'', - @cite{Communications of the ACM}, October 1988, Volume 31, No 10, pages + Communications of the ACM, October 1988, Volume 31, No 10, pages 1192--1201.") -(def-rng-type *uni* "Obsolete, use only for compatibility.") +(def-rng-type *uni* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *uni32* "Obsolete, use only for compatibility.") +(def-rng-type *uni32* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *slatec* "Obsolete, use only for compatibility.") +(def-rng-type *slatec* ; FDL + "Obsolete, use only for compatibility.") -(def-rng-type *zuf* +(def-rng-type *zuf* ; FDL "Obsolete, use only for compatibility. The ZUFALL lagged Fibonacci series generator of Peterson. Its sequence is - t = u_@{n-273@} + u_@{n-607@} + t = u_{n-273} + u_{n-607} u_n = t - floor(t) The original source code is available from NETLIB. For more information see W. Petersen, ``Lagged Fibonacci Random Number Generators for the NEC - SX-3'', @cite{International Journal of High Speed Computing} (1994).") + SX-3'', International Journal of High Speed Computing (1994).") -(def-rng-type *borosh13* +(def-rng-type *borosh13* ; FDL "Obsolete, use only for compatibility. The Borosh-Niederreiter random number generator. It is taken - from Knuth's @cite{Seminumerical Algorithms}, 3rd Ed., pages + from Knuth's Seminumerical Algorithms, 3rd Ed., pages 106--108. Its sequence is x_{n+1} = (a x_n) mod m - with @math{a = 1812433253} and @math{m = 2^32}. - The seed specifies the initial value, @math{x_1}.") + with a = 1812433253 and m = 2^32. + The seed specifies the initial value, x_1.") -(def-rng-type *coveyou* +(def-rng-type *coveyou* ; FDL "Obsolete, use only for compatibility. The Coveyou random number generator, taken from Knuth's - @cite{Seminumerical Algorithms}, 3rd Ed., Section 3.2.2. Its sequence - is x_@{n+1@} = (x_n (x_n + 1)) mod m with @math{m = 2^32}. - The seed specifies the initial value, @math{x_1}.") + Seminumerical Algorithms, 3rd Ed., Section 3.2.2. Its sequence + is x_{n+1} = (x_n (x_n + 1)) mod m with m = 2^32. + The seed specifies the initial value, x_1.") -(def-rng-type *fishman18* +(def-rng-type *fishman18* ; FDL "Obsolete, use only for compatibility. The Fishman, Moore III random number generator. It is taken from - Knuth's @cite{Seminumerical Algorithms}, 3rd Ed., pages 106--108. Its - sequence is x_@{n+1@} = (a x_n) mod m with @math{a = 62089911} and - @math{m = 2^31 - 1}. The seed specifies the initial value, - @math{x_1}.") + Knuth's Seminumerical Algorithms, 3rd Ed., pages 106--108. Its + sequence is x_{n+1} = (a x_n) mod m with a = 62089911 and + m = 2^31 - 1. The seed specifies the initial value, + x_1.") -(def-rng-type *fishman20* +(def-rng-type *fishman20* ; FDL "Obsolete, use only for compatibility. The Fishman random number generator. It is taken from Knuth's - @cite{Seminumerical Algorithms}, 3rd Ed., page 108. Its sequence is - x_@{n+1@} = (a x_n) mod m with @math{a = 48271} and - @math{m = 2^31 - 1}. The seed specifies the initial value, - @math{x_1}.") + Seminumerical Algorithms, 3rd Ed., page 108. Its sequence is + x_{n+1} = (a x_n) mod m with a = 48271 and + m = 2^31 - 1. The seed specifies the initial value, + x_1.") -(def-rng-type *fishman2x* +(def-rng-type *fishman2x* ; FDL "Obsolete, use only for compatibility. The L'Ecuyer--Fishman random number generator. It is taken from - Knuth's @cite{Seminumerical Algorithms}, 3rd Ed., page 108. - Its sequence is z_@{n+1@} = (x_n - y_n) mod m with - @math{m = 2^31 - 1}. - @math{x_n} and @math{y_n} are given by the @code{fishman20} - and @code{lecuyer21} algorithms. - The seed specifies the initial value, @math{x_1}.") - -(def-rng-type *knuthran* + Knuth's Seminumerical Algorithms, 3rd Ed., page 108. + Its sequence is z_{n+1} = (x_n - y_n) mod m with + m = 2^31 - 1. + x_n and y_n are given by the fishman20 and lecuyer21 algorithms. + The seed specifies the initial value, x_1.") + +(def-rng-type *knuthran* ; FDL "Obsolete, use only for compatibility. A second-order multiple recursive generator described by Knuth - in @cite{Seminumerical Algorithms}, 3rd Ed., Section 3.6. Knuth + in Seminumerical Algorithms, 3rd Ed., Section 3.6. Knuth provides its C code.") -(def-rng-type *knuthran2* +(def-rng-type *knuthran2* ; FDL "Obsolete, use only for compatibility. A second-order multiple recursive generator described by Knuth - in @cite{Seminumerical Algorithms}, 3rd Ed., page 108. Its sequence is - x_n = (a_1 x_{n-1} + a_2 x_{n-2}) \,\hbox{mod}\, m - with @math{a_1 = 271828183}, @math{a_2 = 314159269}, and - @math{m = 2^31 - 1}.") + in Seminumerical Algorithms, 3rd Ed., page 108. Its sequence is + x_n = (a_1 x_{n-1} + a_2 x_{n-2}) mod m + with a_1 = 271828183, a_2 = 314159269, and + m = 2^31 - 1.") -(def-rng-type *lecuyer21* +(def-rng-type *lecuyer21* ; FDL "Obsolete, use only for compatibility. The L'Ecuyer random number generator, taken from Knuth's - @cite{Seminumerical Algorithms}, 3rd Ed., page 106--108. - Its sequence is x_@{n+1@} = (a x_n) mod m - with @math{a = 40692} and @math{m = 2^31 - 249}. - The seed specifies the initial value, @math{x_1}.") + Seminumerical Algorithms, 3rd Ed., page 106--108. + Its sequence is x_{n+1} = (a x_n) mod m + with a = 40692 and m = 2^31 - 249. + The seed specifies the initial value, x_1.") -(def-rng-type *waterman14* +(def-rng-type *waterman14* ; FDL "Obsolete, use only for compatibility. The Waterman random number generator. It is taken from Knuth's - @cite{Seminumerical Algorithms}, 3rd Ed., page 106--108. - Its sequence is x_@{n+1@} = (a x_n) mod m with - @math{a = 1566083941} and @math{m = 2^32}. - The seed specifies the initial value, @math{x_1}.") + Seminumerical Algorithms, 3rd Ed., page 106--108. + Its sequence is x_{n+1} = (a x_n) mod m with + a = 1566083941 and m = 2^32. + The seed specifies the initial value, x_1.") diff --git a/random/shuffling-sampling.lisp b/random/shuffling-sampling.lisp index 1ec3790593c8d16cad472fa658c0a520a1619578..86672afe94349db37c170f13e136b5fec8d49383 100644 --- a/random/shuffling-sampling.lisp +++ b/random/shuffling-sampling.lisp @@ -1,61 +1,101 @@ -;******************************************************** -; file: shuffling-sampling.lisp -; description: Shuffling and sampling -; date: Sat Dec 2 2006 - 18:40 -; author: Liam M. Healy -; modified: Sat Dec 2 2006 - 18:55 -;******************************************************** -;;; $Id: $ +;; Shuffling and sampling +;; Liam Healy, Sat Dec 2 2006 - 18:40 +;; Time-stamp: <2008-02-17 16:31:02EST shuffling-sampling.lisp> +;; $Id: $ (in-package :gsl) -;;; These are defined for sequences of memory locations and -;;; so are difficult to adapt to arbitrary CL objects. -;;; The interfaces will probably change. +;;; These are currently defined only for vectors. -(defun-gsl shuffle (generator base n size) +(defmfun shuffle (generator base) "gsl_ran_shuffle" - (((generator generator) :pointer) (base :pointer) (n :size) (size :size)) + (((generator generator) :pointer) + ((gsl-array base) :pointer) ((dim0 base) size) ((element-size base) size)) :c-return :void - :documentation - "Randomly shuffle the order of @var{n} objects, each of - size @var{size}, stored in the array @var{base}[0..@var{n}-1]. The - output of the random number generator @var{r} is used to produce the - permutation. The algorithm generates all possible @math{n!} + :documentation ; FDL + "Randomly shuffle the order of n objects, each of + size size, stored in the array base[0...n-1]. The + output of the random number generator r is used to produce the + permutation. The algorithm generates all possible n! permutations with equal probability, assuming a perfect source of random numbers.") -(defun-gsl choose-random (generator dest k src n size) +(defmfun choose-random (generator dest src) "gsl_ran_choose" (((generator generator) :pointer) - (dest :pointer) (k :size) (src :pointer) (n :size) (size :size)) + ((gsl-array dest) :pointer) ((dim0 dest) size) + ((gsl-array src) :pointer) ((dim0 src) size) ((element-size src) size)) ;; This is described in the GSL docs as returning int, but it does ;; not say what the return value means. Therefore, we ignore it. :c-return :void - :documentation - "Fill the array @var{dest}[k] with @var{k} objects taken - randomly from the @var{n} elements of the array - @var{src}[0..@var{n}-1]. The objects are each of size @var{size}. The - output of the random number generator @var{r} is used to make the + :documentation ; FDL + "Fill the array dest[k] with k objects taken + randomly from the n elements of the array + src[0...n-1]. The objects are each of size size. The + output of the random number generator r is used to make the selection. The algorithm ensures all possible samples are equally likely, assuming a perfect source of randomness. - The objects are sampled @emph{without} replacement, thus each object can - only appear once in @var{dest}[k]. It is required that @var{k} be less - than or equal to @code{n}. The objects in @var{dest} will be in the - same relative order as those in @var{src}. You will need to call - @code{gsl_ran_shuffle(r, dest, n, size)} if you want to randomize the - order.") + The objects are sampled without replacement, thus each object can + only appear once in dest[k]. It is required that k be less + than or equal to n. The objects in dest will be in the + same relative order as those in src. You will need to call + #'shuffle if you want to randomize the order.") -(defun-gsl sample (generator dest k src n size) +(defmfun sample (generator dest src) "gsl_ran_sample" (((generator generator) :pointer) - (dest :pointer) (k :size) (src :pointer) (n :size) (size :size)) + ((gsl-array dest) :pointer) ((dim0 dest) size) + ((gsl-array src) :pointer) ((dim0 src) size) ((element-size src) size)) :c-return :void :documentation - "Like #'choose-random, but samples @var{k} items - from the original array of @var{n} items @var{src} with replacement, so + "Like #'choose-random, but samples k items + from the original array of n items src with replacement, so the same object can appear more than once in the output sequence - @var{dest}. There is no requirement that @var{k} be less than @var{n} + dest. There is no requirement that k be less than n in this case.") +;;; Examples and unit test +#| +(make-tests shuffling-sampling + (letm ((rng (random-number-generator *mt19937* 0)) + (v1 (vector-fixnum #(1 2 3 4 5 6 7 8)))) + (shuffle rng v1) + (data v1)) + (letm ((rng (random-number-generator *mt19937* 0)) + (v1 (vector-fixnum #(1 2 3 4 5 6 7 8))) + (v2 (vector-fixnum 4))) + (choose-random rng v2 v1) + (data v2)) + (letm ((rng (random-number-generator *mt19937* 0)) + (v1 (vector-fixnum #(1 2 3 4 5 6 7 8))) + (v2 (vector-fixnum 10))) + (sample rng v2 v1) + (data v2))) +|# + +(LISP-UNIT:DEFINE-TEST SHUFFLING-SAMPLING + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(4 3 6 1 5 7 2 8)) + (MULTIPLE-VALUE-LIST + (LETM + ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0)) + (V1 (VECTOR-FIXNUM #(1 2 3 4 5 6 7 8)))) + (SHUFFLE RNG V1) (DATA V1)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(2 3 5 8)) + (MULTIPLE-VALUE-LIST + (LETM + ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0)) + (V1 (VECTOR-FIXNUM #(1 2 3 4 5 6 7 8))) + (V2 (VECTOR-FIXNUM 4))) + (CHOOSE-RANDOM RNG V2 V1) + (DATA V2)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(8 2 3 8 2 4 8 6 5 6)) + (MULTIPLE-VALUE-LIST + (LETM + ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0)) + (V1 (VECTOR-FIXNUM #(1 2 3 4 5 6 7 8))) + (V2 (VECTOR-FIXNUM 10))) + (SAMPLE RNG V2 V1) (DATA V2))))) diff --git a/random/spherical-vector.lisp b/random/spherical-vector.lisp index 12a54f7ef9e308eb48f1e178a3a88cb157f3e3d7..86ff548cc133e6c0bf4654784e7b4a3b945644b5 100644 --- a/random/spherical-vector.lisp +++ b/random/spherical-vector.lisp @@ -1,13 +1,13 @@ ;; Spherical Vector distribution ;; Liam Healy, Sun Oct 22 2006 -;; Time-stamp: <2008-02-03 10:38:08EST spherical-vector.lisp> +;; Time-stamp: <2008-02-17 13:25:44EST spherical-vector.lisp> ;; $Id: $ (in-package :gsl) ;;; No test for #'direction-Nd yet. -(defun-gsl direction-2d (generator) +(defmfun direction-2d (generator) "gsl_ran_dir_2d" (((generator generator) :pointer) (x :double) (y :double)) :c-return :void @@ -16,7 +16,7 @@ two dimensions. The vector is normalized such that |v|^2 = x^2 + y^2 = 1.") -(defun-gsl direction-2d-trig-method (generator) +(defmfun direction-2d-trig-method (generator) "gsl_ran_dir_2d_trig_method" (((generator generator) :pointer) (x :double) (y :double)) :c-return :void @@ -25,7 +25,7 @@ two dimensions. The vector is normalized such that |v|^2 = x^2 + y^2 = 1. Uses trigonometric functions.") -(defun-gsl direction-3d (generator) +(defmfun direction-3d (generator) "gsl_ran_dir_3d" (((generator generator) :pointer) (x :double) (y :double) (z :double)) :c-return :void @@ -38,9 +38,9 @@ projected along any axis is actually uniform (this is only true for 3 dimensions).") -(defun-gsl direction-Nd (generator x) +(defmfun direction-Nd (generator x) "gsl_ran_dir_nd" - (((generator generator) :pointer) ((dim0 x) :size) ((gsl-array x) :pointer)) + (((generator generator) :pointer) ((dim0 x) size) ((gsl-array x) :pointer)) :c-return :void :return (x) :documentation ; FDL @@ -54,33 +54,57 @@ Mathematics for the Engineer (1956).") ;;; Examples and unit test -(lisp-unit:define-test spherical-vector - (lisp-unit:assert-equal - '("-0.617745613498d+00" "-0.786377998805d+00" "0.993748310886d+00" - "0.111643605330d+00" "-0.945810428098d+00" "0.324719315872d+00" - "0.457266229462d+00" "0.889329857473d+00" "-0.463256161598d+00" - "-0.886224423462d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests spherical-vector + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 4 append - (multiple-value-list (direction-2d rng)))))) - (lisp-unit:assert-equal - '("0.999998683521d+00" "-0.162263876311d-02" "0.520301010608d+00" - "0.853982937980d+00" "-0.203512053104d+00" "0.979072440753d+00" - "0.945475322749d+00" "-0.325693742761d+00" "0.115000339166d+00" - "0.993365452385d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) + (multiple-value-list (direction-2d rng)))) + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 4 append - (multiple-value-list (direction-2d-trig-method rng)))))) - (lisp-unit:assert-equal - '("-0.912992575045d-01" "0.187821853572d+00" "0.977950610665d+00" - "-0.905118296156d+00" "-0.506837644858d-01" "-0.422127973465d+00" - "0.139937665360d+00" "0.838546262052d+00" "-0.526552576873d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) + (multiple-value-list (direction-2d-trig-method rng)))) + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 2 append - (multiple-value-list (direction-3d rng))))))) + (multiple-value-list (direction-3d rng))))) +|# + +(LISP-UNIT:DEFINE-TEST SPHERICAL-VECTOR + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST -0.617745613497854d0 -0.7863779988047479d0 + 0.993748310886084d0 0.1116436053298841d0 + -0.9458104280982743d0 0.3247193158722761d0 + 0.45726622946182216d0 0.8893298574734622d0 + -0.46325616159849964d0 -0.8862244234622655d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 4 APPEND + (MULTIPLE-VALUE-LIST + (DIRECTION-2D RNG)))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.9999986835208556d0 -0.0016226387631051197d0 + 0.5203010106077766d0 0.8539829379797504d0 + -0.2035120531038584d0 0.9790724407527016d0 + 0.9454753227485545d0 -0.3256937427607672d0 + 0.11500033916619544d0 0.9933654523848008d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 4 APPEND + (MULTIPLE-VALUE-LIST + (DIRECTION-2D-TRIG-METHOD RNG)))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST -0.09129925750445994d0 0.18782185357162273d0 + 0.977950610665004d0 -0.9051182961559773d0 + -0.050683764485791594d0 -0.4221279734645046d0 + 0.13993766535985133d0 0.8385462620524484d0 + -0.526552576872909d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 2 APPEND + (MULTIPLE-VALUE-LIST + (DIRECTION-3D RNG))))))) + diff --git a/random/tdist.lisp b/random/tdist.lisp index c4031a506d7597b0e35d9559778527e631ad4aba..481d1b60bfd6ffb53f776d092ac5cfe7d5ac2fe2 100644 --- a/random/tdist.lisp +++ b/random/tdist.lisp @@ -1,11 +1,11 @@ ;; Tdist distribution ;; Liam Healy, Sat Oct 7 2006 - 16:13 -;; Time-stamp: <2008-02-03 13:27:31EST tdist.lisp> +;; Time-stamp: <2008-02-17 13:16:23EST tdist.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl tdist (generator nu) +(defmfun tdist (generator nu) "gsl_ran_tdist" (((generator generator) :pointer) (nu :double)) :c-return :double @@ -16,7 +16,7 @@ (1 + x^2/\nu)^{-(\nu + 1)/2} dx for -\infty < x < +\infty.") -(defun-gsl tdist-pdf (x nu) +(defmfun tdist-pdf (x nu) "gsl_ran_tdist_pdf" ((x :double) (nu :double)) :c-return :double :documentation ; FDL @@ -24,28 +24,28 @@ for a t-distribution with nu degrees of freedom, using the formula given in #'tdist.") -(defun-gsl tdist-P (x nu) +(defmfun tdist-P (x nu) "gsl_cdf_tdist_P" ((x :double) (nu :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the tdist distribution with nu degrees of freedom.") -(defun-gsl tdist-Q (x nu) +(defmfun tdist-Q (x nu) "gsl_cdf_tdist_Q" ((x :double) (nu :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the tdist distribution with nu degrees of freedom.") -(defun-gsl tdist-Pinv (P nu) +(defmfun tdist-Pinv (P nu) "gsl_cdf_tdist_Pinv" ((P :double) (nu :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the tdist distribution with nu degrees of freedom.") -(defun-gsl tdist-Qinv (Q nu) +(defmfun tdist-Qinv (Q nu) "gsl_cdf_tdist_Qinv" ((Q :double) (nu :double)) :c-return :double :documentation ; FDL @@ -53,30 +53,47 @@ Q(x) for the tdist distribution with nu degrees of freedom.") ;;; Examples and unit test -(lisp-unit:define-test tdist - (lisp-unit:assert-equal - '("0.149893663745d+00" "0.679414287929d+00" "-0.161583395111d+01" - "-0.160088628258d+01" "-0.170109355058d+01" "-0.437095974981d-01" - "0.127611592766d+00" "-0.197312182555d-01" "-0.653466611720d+00" - "0.203577132452d+00" "0.177650300478d+01") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests tdist + (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)) - (lisp-unit:assert-first-fp-equal - "0.647583617650d+00" - (tdist-P 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.352416382350d+00" - (tdist-Q 0.5d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (tdist-Pinv 0.6475836176504334d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.500000000000d+00" - (tdist-Qinv 0.3524163823495667d0 1.0d0))) + (tdist rng 10.0d0))) + (tdist-pdf 0.5d0 1.0d0) + (tdist-P 0.5d0 1.0d0) + (tdist-Q 0.5d0 1.0d0) + (tdist-Pinv 0.6475836176504334d0 1.0d0) + (tdist-Qinv 0.3524163823495667d0 1.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST TDIST + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.14989366374481017d0 0.6794142879291215d0 + -1.615833951108472d0 -1.6008862825783456d0 + -1.7010935505767397d0 -0.04370959749808691d0 + 0.12761159276595174d0 -0.019731218255494867d0 + -0.6534666117199732d0 0.2035771324523077d0 + 1.77650300477611d0)) + (MULTIPLE-VALUE-LIST + (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-NUMERICAL-EQUAL + (LIST 0.2546479089470325d0) + (MULTIPLE-VALUE-LIST (TDIST-PDF 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.6475836176504332d0) + (MULTIPLE-VALUE-LIST (TDIST-P 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.35241638234956685d0) + (MULTIPLE-VALUE-LIST (TDIST-Q 0.5d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.500000000000001d0) + (MULTIPLE-VALUE-LIST + (TDIST-PINV 0.6475836176504334d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.5d0) + (MULTIPLE-VALUE-LIST (TDIST-QINV 0.3524163823495667d0 1.0d0)))) diff --git a/random/weibull.lisp b/random/weibull.lisp index c857e81907b5f7abfa642977c29c2eae6841b1f4..0c0141a6d6c7f01d66d28860e54d96770487ec92 100644 --- a/random/weibull.lisp +++ b/random/weibull.lisp @@ -1,11 +1,11 @@ ;; Weibull distribution ;; Liam Healy, Sun Oct 22 2006 -;; Time-stamp: <2008-02-03 11:15:10EST weibull.lisp> +;; Time-stamp: <2008-02-17 13:30:33EST weibull.lisp> ;; $Id: $ (in-package :gsl) -(defun-gsl weibull (generator a b) +(defmfun weibull (generator a b) "gsl_ran_weibull" (((generator generator) :pointer) (a :double) (b :double)) :c-return :double @@ -14,7 +14,7 @@ p(x) dx = {b \over a^b} x^{b-1} \exp(-(x/a)^b) dx for x >= 0.") -(defun-gsl weibull-pdf (x a b) +(defmfun weibull-pdf (x a b) "gsl_ran_weibull_pdf" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -22,28 +22,28 @@ for a Weibull distribution with scale a and exponent b, using the formula given in #'weibull.") -(defun-gsl weibull-P (x a b) +(defmfun weibull-P (x a b) "gsl_cdf_weibull_P" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions P(x) for the Weibull distribution with scale a and exponent b.") -(defun-gsl weibull-Q (x a b) +(defmfun weibull-Q (x a b) "gsl_cdf_weibull_Q" ((x :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The cumulative distribution functions Q(x) for the Weibull distribution with scale a and exponent b.") -(defun-gsl weibull-Pinv (P a b) +(defmfun weibull-Pinv (P a b) "gsl_cdf_weibull_Pinv" ((P :double) (a :double) (b :double)) :c-return :double :documentation ; FDL "The inverse cumulative distribution functions P(x) for the Weibull distribution scale a and exponent b.") -(defun-gsl weibull-Qinv (Q a b) +(defmfun weibull-Qinv (Q a b) "gsl_cdf_weibull_Qinv" ((Q :double) (a :double) (b :double)) :c-return :double :documentation ; FDL @@ -51,29 +51,45 @@ Q(x) for the Weibull distribution exponent a and scale b.") ;;; Examples and unit test -(lisp-unit:define-test weibull - (lisp-unit:assert-equal - '("0.160712303787d-01" "0.134705535996d+01" "0.112412624088d+01" - "0.232903139783d+00" "0.120933842386d+01" "0.850682545344d+00" - "0.208455329740d+00" "0.543418734407d+00" "0.784923750377d+00" - "0.548788332013d+00" "0.523937780842d+00") - (lisp-unit:fp-sequence - (letm ((rng (random-number-generator *mt19937* 0))) +#| +(make-tests weibull + (letm ((rng (random-number-generator *mt19937* 0))) (loop for i from 0 to 10 collect - (weibull rng 1.0d0 2.0d0))))) - (lisp-unit:assert-first-fp-equal - "0.242631749722d+00" - (weibull-pdf 1.5d0 1.3d0 1.0d0)) - (lisp-unit:assert-first-fp-equal - "0.999288774280d+00" - (weibull-P 3.5d0 1.3d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.711225720092d-03" - (weibull-Q 3.5d0 1.3d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.350000000000d+01" - (weibull-Pinv 0.9992887742799077d0 1.3d0 2.0d0)) - (lisp-unit:assert-first-fp-equal - "0.350000000000d+01" - (weibull-Qinv 7.112257200923508d-4 1.3d0 2.0d0))) + (weibull rng 1.0d0 2.0d0))) + (weibull-pdf 1.5d0 1.3d0 1.0d0) + (weibull-P 3.5d0 1.3d0 2.0d0) + (weibull-Q 3.5d0 1.3d0 2.0d0) + (weibull-Pinv 0.9992887742799077d0 1.3d0 2.0d0) + (weibull-Qinv 7.112257200923508d-4 1.3d0 2.0d0)) +|# + +(LISP-UNIT:DEFINE-TEST WEIBULL + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.0160712303786595d0 1.347055359960668d0 + 1.1241262408795445d0 0.2329031397826649d0 + 1.209338423856536d0 0.8506825453443836d0 + 0.20845532973957762d0 0.5434187344070215d0 + 0.7849237503774361d0 0.5487883320132739d0 + 0.5239377808419179d0)) + (MULTIPLE-VALUE-LIST + (LETM ((RNG (RANDOM-NUMBER-GENERATOR *MT19937* 0))) + (LOOP FOR I FROM 0 TO 10 COLLECT + (WEIBULL RNG 1.0d0 2.0d0))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.24263174972226745d0) + (MULTIPLE-VALUE-LIST (WEIBULL-PDF 1.5d0 1.3d0 1.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 0.9992887742799077d0) + (MULTIPLE-VALUE-LIST (WEIBULL-P 3.5d0 1.3d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 7.112257200923508d-4) + (MULTIPLE-VALUE-LIST (WEIBULL-Q 3.5d0 1.3d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 3.5000000000000164d0) + (MULTIPLE-VALUE-LIST + (WEIBULL-PINV 0.9992887742799077d0 1.3d0 2.0d0))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 3.5d0) + (MULTIPLE-VALUE-LIST (WEIBULL-QINV 7.112257200923508d-4 1.3d0 2.0d0)))) diff --git a/series-acceleration.lisp b/series-acceleration.lisp index 762d3509db1f2277f4529f59446873eeecc8409c..d3bbb88cc8b6cdb7b9095b7a0847effc83902b2a 100644 --- a/series-acceleration.lisp +++ b/series-acceleration.lisp @@ -1,6 +1,6 @@ ;; Series acceleration. ;; Liam Healy, Wed Nov 21 2007 - 18:41 -;; Time-stamp: <2008-02-03 22:22:46EST series-acceleration.lisp> +;; Time-stamp: <2008-02-17 18:04:12EST series-acceleration.lisp> ;; $Id: $ (in-package :gsl) @@ -11,9 +11,9 @@ (cffi:defcstruct levin "The definition of Levin series acceleration for GSL." - (size :size) - (position-in-array :size) - (terms-used :size) + (size size) + (position-in-array size) + (terms-used size) (sum-plain :double) (q-num :pointer) (q-den :pointer) @@ -23,9 +23,9 @@ (defgo-s (levin order) allocate-levin free-levin) -(defun-gsl allocate-levin (order) +(defmfun allocate-levin (order) "gsl_sum_levin_u_alloc" - ((order :size)) + ((order size)) :c-return :pointer :export nil :index (letm levin) @@ -33,7 +33,7 @@ "Allocate a workspace for a Levin u-transform of n terms. The size of the workspace is O(2n^2 + 3n).") -(defun-gsl free-levin (levin) +(defmfun free-levin (levin) "gsl_sum_levin_u_free" ((levin :pointer)) :c-return :void ; Error in GSL manual, should be void? @@ -42,9 +42,9 @@ :documentation ; FDL "Free a previously allocated Levin acceleration.") -(defun-gsl accelerate (array levin) +(defmfun accelerate (array levin) "gsl_sum_levin_u_accel" - (((gsl-array array) :pointer) ((dim0 array) :size) (levin :pointer) + (((gsl-array array) :pointer) ((dim0 array) size) (levin :pointer) (accelerated-sum :double) (absolute-error :double)) :documentation ; FDL "From the terms of a series in array, compute the extrapolated @@ -63,18 +63,18 @@ (defgo-s (levin-truncated order) allocate-levin-truncated free-levin-truncated) -(defun-gsl allocate-levin-truncated (order) +(defmfun allocate-levin-truncated (order) "gsl_sum_levin_utrunc_alloc" - ((order :size)) + ((order size)) :c-return :pointer :export nil :index (letm levin-truncated) :documentation ; FDL - "Allocate a workspace for a Levin @math{u}-transform of n + "Allocate a workspace for a Levin u-transform of n terms, without error estimation. The size of the workspace is O(3n).") -(defun-gsl free-levin-truncated (levin) +(defmfun free-levin-truncated (levin) "gsl_sum_levin_utrunc_free" ((levin :pointer)) :export nil @@ -82,9 +82,9 @@ :documentation ; FDL "Free a previously allocated Levin acceleration.") -(defun-gsl accelerate-truncated (array levin) +(defmfun accelerate-truncated (array levin) "gsl_sum_levin_utrunc_accel" - (((gsl-array array) :pointer) ((dim0 array) :size) (levin :pointer) + (((gsl-array array) :pointer) ((dim0 array) size) (levin :pointer) (accelerated-sum :double) (absolute-error :double)) :documentation ; FDL "From the terms of a series in array, compute the extrapolated diff --git a/simulated-annealing.lisp b/simulated-annealing.lisp index 0e4f9449e66fe9a81b82446a1b33a5277dc5652a..c487d460ec377738d9b2e4af87d5662e7f16cfd8 100644 --- a/simulated-annealing.lisp +++ b/simulated-annealing.lisp @@ -1,6 +1,6 @@ ;; Simulated Annealing ;; Liam Healy Sun Feb 11 2007 - 17:23 -;; Time-stamp: <2008-01-28 22:19:40EST simulated-annealing.lisp> +;; Time-stamp: <2008-02-17 18:29:20EST simulated-annealing.lisp> ;; $Id: $ (in-package :gsl) @@ -51,7 +51,7 @@ ,t-min) ,@body)) -(defun-gsl simulated-annealing +(defmfun simulated-annealing (generator x0-p Ef take-step distance-function print-position @@ -69,13 +69,13 @@ ;;((cffi:get-callback copy-function) :pointer) ;;((cffi:get-callback copy-constructor) :pointer) ;;((cffi:get-callback destructor) :pointer) - (element-size :size) (parameters simulated-annealing-parameters)) + (element-size size) (parameters simulated-annealing-parameters)) :c-return :void - :documentation + :documentation ; FDL "Perform a simulated annealing search through a given - space. The space is specified by providing the functions @var{Ef} and - @var{distance}. The simulated annealing steps are generated using the - random number generator @var{r} and the function @var{take_step}. + space. The space is specified by providing the functions Ef and + distance. The simulated annealing steps are generated using the + random number generator r and the function take-step. The starting configuration of the system should be given by x0-p The routine offers two modes for updating configurations, a fixed-size @@ -86,7 +86,7 @@ fixed-size mode. In the variable-size mode the functions copy-function, copy-constructor and destructor are used to create, copy and destroy configurations internally. The variable - @var{element_size} should be zero in the variable-size mode. + element-size should be zero in the variable-size mode. The parameters structure (described below) controls the run by providing the temperature schedule and other tunable parameters to the @@ -96,11 +96,11 @@ x0-p. If the annealing process has been successful this should be a good approximation to the optimal point in the space. - If the function pointer @var{print_position} is not null, a debugging - log will be printed to @code{stdout} with the following columns: + If the function pointer print-position is not null, a debugging + log will be printed to standard output with the following columns: number_of_iterations temperature x x-x0p Ef(x) - and the output of the function @var{print_position} itself. If - @var{print_position} is null then no information is printed. + and the output of the function print-position itself. If + print-position is null then no information is printed. The simulated annealing routines require several user-specified functions to define the configuration space and energy function.") diff --git a/solve-minimize-fit/linear-least-squares.lisp b/solve-minimize-fit/linear-least-squares.lisp index 7cedd5c978038c5b42d29b7a2829aeef0b7b2db1..c6f1f5ed3d71a7469f8e6c4e3f951ea8fc6d80d7 100644 --- a/solve-minimize-fit/linear-least-squares.lisp +++ b/solve-minimize-fit/linear-least-squares.lisp @@ -1,6 +1,6 @@ ;; Linear least squares, or linear regression ;; Liam Healy <2008-01-21 12:41:46EST linear-least-squares.lisp> -;; Time-stamp: <2008-02-03 15:38:26EST linear-least-squares.lisp> +;; Time-stamp: <2008-02-17 18:33:16EST linear-least-squares.lisp> ;; $Id: $ (in-package :gsl) @@ -15,11 +15,11 @@ ;;; of "cov00" etc. Last arg to gsl_fit_wmul is labelled sumsq but ;;; referred to as chisq. -(defun-gsl linear-fit (x y &optional (x-stride 1) (y-stride 1)) +(defmfun linear-fit (x y &optional (x-stride 1) (y-stride 1)) "gsl_fit_linear" - (((gsl-array x) :pointer) (x-stride :size) - ((gsl-array y) :pointer) (y-stride :size) - ((dim0 x) :size) (c0 :double) (c1 :double) + (((gsl-array x) :pointer) (x-stride size) + ((gsl-array y) :pointer) (y-stride size) + ((dim0 x) size) (c0 :double) (c1 :double) (cov00 :double) (cov01 :double) (cov11 :double) (sumsq :double)) :documentation ; FDL @@ -35,13 +35,13 @@ The sum of squares of the residuals from the best-fit line is returned as the final value.") -(defun-gsl weighted-linear-fit +(defmfun weighted-linear-fit (x weight y &optional (x-stride 1) (weight-stride 1) (y-stride 1)) "gsl_fit_wlinear" - (((gsl-array x) :pointer) (x-stride :size) - ((gsl-array weight) :pointer) (weight-stride :size) - ((gsl-array y) :pointer) (y-stride :size) - ((dim0 x) :size) (c0 :double) (c1 :double) + (((gsl-array x) :pointer) (x-stride size) + ((gsl-array weight) :pointer) (weight-stride size) + ((gsl-array y) :pointer) (y-stride size) + ((dim0 x) size) (c0 :double) (c1 :double) (cov00 :double) (cov01 :double) (cov11 :double) (chisq :double)) :documentation ; FDL @@ -59,7 +59,7 @@ of squares of the residuals from the best-fit line, \chi^2, is returned in as the last value.") -(defun-gsl linear-estimate (x c0 c1 cov00 cov01 cov11) +(defmfun linear-estimate (x c0 c1 cov00 cov01 cov11) "gsl_fit_linear_est" ((x :double) (c0 :double) (c1 :double) (cov00 :double) (cov01 :double) (cov11 :double) @@ -75,11 +75,11 @@ ;;;; Linear fitting without a constant term ;;;;**************************************************************************** -(defun-gsl multiplier-fit (x y &optional (x-stride 1) (y-stride 1)) +(defmfun multiplier-fit (x y &optional (x-stride 1) (y-stride 1)) "gsl_fit_mul" - (((gsl-array x) :pointer) (x-stride :size) - ((gsl-array y) :pointer) (y-stride :size) - ((dim0 x) :size) (c1 :double) (cov11 :double) + (((gsl-array x) :pointer) (x-stride size) + ((gsl-array y) :pointer) (y-stride size) + ((dim0 x) size) (c1 :double) (cov11 :double) (sumsq :double)) :documentation ; FDL "The best-fit linear regression coefficient c1 of the model Y = c_1 @@ -90,13 +90,13 @@ squares of the residuals from the best-fit line is returned as the last value.") -(defun-gsl weighted-multiplier-fit +(defmfun weighted-multiplier-fit (x weight y &optional (x-stride 1) (weight-stride 1) (y-stride 1)) "gsl_fit_wmul" - (((gsl-array x) :pointer) (x-stride :size) - ((gsl-array weight) :pointer) (weight-stride :size) - ((gsl-array y) :pointer) (y-stride :size) - ((dim0 x) :size) (c1 :double) (cov11 :double) + (((gsl-array x) :pointer) (x-stride size) + ((gsl-array weight) :pointer) (weight-stride size) + ((gsl-array y) :pointer) (y-stride size) + ((dim0 x) size) (c1 :double) (cov11 :double) (chisq :double)) :documentation ; FDL "Compute the best-fit linear regression coefficient @@ -111,7 +111,7 @@ squares of the residuals from the best-fit line, \chi^2, is returned as the last value.") -(defun-gsl multiplier-estimate (x c1 cov11) +(defmfun multiplier-estimate (x c1 cov11) "gsl_fit_mul_est" ((x :double) (c1 :double) (cov11 :double) (y :double) (y-error :double)) @@ -128,15 +128,15 @@ (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) +(defmfun allocate-fit-workspace (number-of-observations number-of-parameters) "gsl_multifit_linear_alloc" - ((number-of-observations :size) (number-of-parameters :size)) + ((number-of-observations size) (number-of-parameters size)) :c-return :pointer :index (letm fit-workspace) :documentation ; FDL "Allocate a workspace for fitting a linear model.") -(defun-gsl free-fit-workspace (pointer) +(defmfun free-fit-workspace (pointer) "gsl_multifit_linear_free" ((pointer :pointer)) :c-return :void @@ -144,7 +144,7 @@ :documentation ; FDL "Free the memory associate with the workspace.") -(defun-gsl linear-mfit +(defmfun linear-mfit (model observations parameters covariance tolerance workspace) "gsl_multifit_linear" (((pointer model) :pointer) ((pointer observations) :pointer) @@ -157,7 +157,7 @@ variables X. The variance-covariance matrix of the model parameters cov is estimated from the scatter of the observations about the best-fit. The sum of squares of the residuals from the - best-fit, \chi^2, is returned. + best-fit, chi^2, is returned. The best-fit is found by singular value decomposition of the matrix X using the preallocated workspace provided. The @@ -165,20 +165,22 @@ improve the accuracy of the singular values. Any components which have zero singular value (to machine precision) are discarded from the fit.") -(defun-gsl linear-mfit-svd +(defmfun linear-mfit-svd (model observations parameters covariance tolerance workspace) "gsl_multifit_linear_svd" (((pointer model) :pointer) ((pointer observations) :pointer) (tolerance :double) + (rank size) ((pointer parameters) :pointer) (covariance :pointer) (chisq :double) (workspace :pointer)) + :return ((dcref chisq) (scref rank)) :documentation ; FDL "Compute the best-fit parameters c of the model y = X c for the observations y and the matrix of predictor variables X. The variance-covariance matrix of the model parameters cov is estimated from the scatter of the observations about the best-fit. The sum of squares of the residuals from the - best-fit, \chi^2, is returned. + best-fit, chi^2, is returned. The best-fit is found by singular value decomposition of the matrix X using the preallocated workspace provided. The @@ -186,10 +188,11 @@ improve the accuracy of the singular values. Any components which have zero singular value (to machine precision) are discarded from the fit. In the this form of the function the components are discarded if the - ratio of singular values @math{s_i/s_0} falls below the user-specified - tolerance @var{tol}, and the effective rank is returned in @var{rank}.") + ratio of singular values s_i/s_0 falls below the user-specified + tolerance tolerance, and the effective rank is returned as the + second value.") -(defun-gsl weighted-linear-mfit +(defmfun weighted-linear-mfit (model weight observations parameters covariance workspace) "gsl_multifit_wlinear" (((pointer model) :pointer) @@ -204,21 +207,21 @@ and the model matrix X. The covariance matrix of the model parameters is computed with the given weights. The weighted sum of squares of the residuals from the best-fit, - \chi^2, is returned as the last value. + chi^2, is returned as the last value. The best-fit is found by singular value decomposition of the matrix model using the preallocated workspace provided. Any components which have zero singular value (to machine precision) are discarded from the fit.") -(defun-gsl weighted-linear-mfit-svd +(defmfun weighted-linear-mfit-svd (model weight observations parameters covariance tolerance workspace) "gsl_multifit_wlinear_svd" (((pointer model) :pointer) ((pointer weight) :pointer) ((pointer observations) :pointer) (tolerance :double) - (rank :size) + (rank size) ((pointer parameters) :pointer) (covariance :pointer) (chisq :double) (workspace :pointer)) :return ((dcref chisq) (scref rank)) @@ -228,7 +231,7 @@ and the model matrix X. The covariance matrix of the model parameters is computed with the given weights. The weighted sum of squares of the residuals from the best-fit, - \chi^2, is returned as the first value. + chi^2, is returned as the first value. The best-fit is found by singular value decomposition of the matrix model using the preallocated workspace provided. Any @@ -238,7 +241,7 @@ falls below the user-specified tolerance, and the effective rank is returned as the second value.") -(defun-gsl multi-linear-estimate (x coefficients covariance) +(defmfun multi-linear-estimate (x coefficients covariance) "gsl_multifit_linear_est" ((x :double) (coefficients :pointer) (covariance :pointer) (y :double) (y-error :double)) diff --git a/solve-minimize-fit/minimization-multi.lisp b/solve-minimize-fit/minimization-multi.lisp index 43b7a5d3478753335ee30e0cf7cdc7cb90f2f05e..59082a7f31efee2c4b54be6db7075444e5a2c042 100644 --- a/solve-minimize-fit/minimization-multi.lisp +++ b/solve-minimize-fit/minimization-multi.lisp @@ -1,6 +1,6 @@ ;; Multivariate minimization. ;; Liam Healy <Tue Jan 8 2008 - 21:28> -;; Time-stamp: <2008-02-03 20:01:09EST minimization-multi.lisp> +;; Time-stamp: <2008-02-17 18:39:48EST minimization-multi.lisp> ;; $Id: $ (in-package :gsl) @@ -54,9 +54,9 @@ (defgo-s (mfdfminimizer type dimension function-derivative intitial step-size tolerance) allocate-mfdfminimizer free-mfdfminimizer set-mfdfminimizer 2) -(defun-gsl allocate-mfminimizer (type dimension) +(defmfun allocate-mfminimizer (type dimension) "gsl_multimin_fminimizer_alloc" - ((type :pointer) (dimension :size)) + ((type :pointer) (dimension size)) :c-return :pointer :export nil :index (letm mfminimizer) @@ -64,9 +64,9 @@ "Allocate an instance of a minimizer of the given for an function of the given dimensions.") -(defun-gsl allocate-mfdfminimizer (type dimension) +(defmfun allocate-mfdfminimizer (type dimension) "gsl_multimin_fdfminimizer_alloc" - ((type :pointer) (dimension :size)) + ((type :pointer) (dimension size)) :c-return :pointer :export nil :index (letm mfdfminimizer) @@ -74,7 +74,7 @@ "Allocate an instance of a derivative-based minimizer of the given for an function of the given dimensions.") -(defun-gsl set-mfminimizer (minimizer function initial step-size) +(defmfun set-mfminimizer (minimizer function initial step-size) "gsl_multimin_fminimizer_set" ((minimizer :pointer) (function :pointer) ((pointer initial) :pointer) ((pointer step-size) :pointer)) @@ -87,7 +87,7 @@ step-size. The precise meaning of this parameter depends on the method used.") -(defun-gsl set-mfdfminimizer +(defmfun set-mfdfminimizer (minimizer function-derivative initial step-size tolerance) "gsl_multimin_fdfminimizer_set" ((minimizer :pointer) (function-derivative :pointer) @@ -105,7 +105,7 @@ orthogonal to the current search direction p to a relative accuracy of tolerance, where dot(p,g) < tol |p| |g|.") -(defun-gsl free-mfminimizer (minimizer) +(defmfun free-mfminimizer (minimizer) "gsl_multimin_fminimizer_free" ((minimizer :pointer)) :c-return :void @@ -114,7 +114,7 @@ :documentation ; FDL "Free all the memory associated with the minimizer.") -(defun-gsl free-mfdfminimizer (minimizer) +(defmfun free-mfdfminimizer (minimizer) "gsl_multimin_fdfminimizer_free" ((minimizer :pointer)) :c-return :void @@ -123,25 +123,25 @@ :documentation ; FDL "Free all the memory associated with the minimizer.") -(defun-gsl mfminimizer-name (minimizer) +(defmfun mfminimizer-name (minimizer) "gsl_multimin_fminimizer_name" ((minimizer :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the minimizer.") -(defun-gsl mfdfminimizer-name (minimizer) +(defmfun mfdfminimizer-name (minimizer) "gsl_multimin_fdfminimizer_name" ((minimizer :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the minimizer.") ;;;;**************************************************************************** ;;;; Iteration ;;;;**************************************************************************** -(defun-gsl iterate-mfminimizer (minimizer) +(defmfun iterate-mfminimizer (minimizer) "gsl_multimin_fminimizer_iterate" ((minimizer :pointer)) :documentation ; FDL @@ -149,7 +149,7 @@ encounters an unexpected problem then an error code will be returned.") -(defun-gsl iterate-mfdfminimizer (minimizer) +(defmfun iterate-mfdfminimizer (minimizer) "gsl_multimin_fdfminimizer_iterate" ((minimizer :pointer)) :documentation ; FDL @@ -157,7 +157,7 @@ encounters an unexpected problem then an error code will be returned.") -(defun-gsl mfminimizer-x (minimizer) +(defmfun mfminimizer-x (minimizer) "gsl_multimin_fminimizer_x" ((minimizer :pointer)) :c-return (canswer :pointer) @@ -165,7 +165,7 @@ :documentation ; FDL "The current best estimate of the location of the minimum.") -(defun-gsl mfdfminimizer-x (minimizer) +(defmfun mfdfminimizer-x (minimizer) "gsl_multimin_fdfminimizer_x" ((minimizer :pointer)) :c-return (canswer :pointer) @@ -173,28 +173,28 @@ :documentation ; FDL "The current best estimate of the location of the minimum.") -(defun-gsl mfminimizer-minimum (minimizer) +(defmfun mfminimizer-minimum (minimizer) "gsl_multimin_fminimizer_minimum" ((minimizer :pointer)) :c-return :double :documentation ; FDL "The current best estimate of the value of the minimum.") -(defun-gsl mfdfminimizer-minimum (minimizer) +(defmfun mfdfminimizer-minimum (minimizer) "gsl_multimin_fdfminimizer_minimum" ((minimizer :pointer)) :c-return :double :documentation ; FDL "The current best estimate of the value of the minimum.") -(defun-gsl mfminimizer-size (minimizer) +(defmfun mfminimizer-size (minimizer) "gsl_multimin_fminimizer_size" ((minimizer :pointer)) :c-return :double :documentation ; FDL "A minimizer-specific characteristic size for the minimizer.") -(defun-gsl mfdfminimizer-gradient (minimizer) +(defmfun mfdfminimizer-gradient (minimizer) "gsl_multimin_fdfminimizer_gradient" ((minimizer :pointer)) :c-return (canswer :pointer) @@ -202,7 +202,7 @@ :documentation ; FDL "The current best estimate of the gradient for the minimizer.") -(defun-gsl mfdfminimizer-restart (minimizer) +(defmfun mfdfminimizer-restart (minimizer) "gsl_multimin_fdfminimizer_restart" ((minimizer :pointer)) :documentation ; FDL @@ -213,7 +213,7 @@ ;;;; Stopping criteria ;;;;**************************************************************************** -(defun-gsl min-test-gradient (gradient absolute-error) +(defmfun min-test-gradient (gradient absolute-error) "gsl_multimin_test_gradient" (((pointer gradient) :pointer) (absolute-error :double)) :c-return :success-continue @@ -226,20 +226,20 @@ small variations in x. The relationship between these quantities \delta f = g \delta x.") -(defun-gsl min-test-size (size absolute-error) +(defmfun min-test-size (size absolute-error) "gsl_multimin_test_size" ((size :double) (absolute-error :double)) :c-return :success-continue :documentation ; FDL "Test the minimizer specific characteristic size (if applicable to - the used minimizer) against absolute tolerance @var{epsabs}. The test + the used minimizer) against absolute tolerance absolute-error. The test returns T if the size is smaller than tolerance, and NIL otherwise.") ;;;;**************************************************************************** ;;;; Algorithms ;;;;**************************************************************************** -(defvariable *conjugate-fletcher-reeves* +(defmpar *conjugate-fletcher-reeves* "gsl_multimin_fdfminimizer_conjugate_fr" ;; FDL "The Fletcher-Reeves conjugate gradient algorithm. The conjugate @@ -257,7 +257,7 @@ and the line minimization is then repeated for the new search direction.") -(defvariable *conjugate-polak-ribiere* +(defmpar *conjugate-polak-ribiere* "gsl_multimin_fdfminimizer_conjugate_pr" ;; FDL "The Polak-Ribiere conjugate gradient algorithm. It is similar to @@ -266,7 +266,7 @@ close enough to the minimum of the objective function that it is well approximated by a quadratic hypersurface.") -(defvariable *vector-bfgs* +(defmpar *vector-bfgs* "gsl_multimin_fdfminimizer_vector_bfgs" ;; FDL "The vector Broyden-Fletcher-Goldfarb-Shanno (BFGS) conjugate @@ -277,7 +277,7 @@ steps towards the function minimum, assuming quadratic behavior in that region.") -(defvariable *simplex-nelder-mead* +(defmpar *simplex-nelder-mead* "gsl_multimin_fminimizer_nmsimplex" ;; FDL "The Simplex algorithm of Nelder and Mead. It constructs diff --git a/solve-minimize-fit/minimization-one.lisp b/solve-minimize-fit/minimization-one.lisp index 90cd4b14e16741143a85c90ab15e9b4ce918c73b..9b4484263daefaf1675f4a28277aede9c3d34b06 100644 --- a/solve-minimize-fit/minimization-one.lisp +++ b/solve-minimize-fit/minimization-one.lisp @@ -1,6 +1,6 @@ ;; Univariate minimization ;; Liam Healy Tue Jan 8 2008 - 21:02 -;; Time-stamp: <2008-02-03 13:22:51EST minimization-one.lisp> +;; Time-stamp: <2008-02-17 18:37:39EST minimization-one.lisp> ;; $Id: $ (in-package :gsl) @@ -12,65 +12,65 @@ (defgo-s (fminimizer type function minimum lower upper) allocate-fminimizer free-fminimizer set-fminimizer) -(defun-gsl allocate-fminimizer (type) +(defmfun allocate-fminimizer (type) "gsl_min_fminimizer_alloc" ((type :pointer)) :c-return :pointer :export nil :index (letm fminimizer) - :documentation + :documentation ; FDL "Allocate an instance of a minimizer of the given type.") -(defun-gsl set-fminimizer (minimizer function minimum lower upper) +(defmfun set-fminimizer (minimizer function minimum lower upper) "gsl_min_fminimizer_set" ((minimizer :pointer) (function :pointer) (minimum :double) (lower :double) (upper :double)) :export nil :index (letm fminimizer) - :documentation + :documentation ; FDL "Set, or reset, an existing minimizer to use the function and the initial search interval [lower, upper], with a guess for the location of the minimum.") ;;; Use this in letm macro in any way? -(defun-gsl set-fminimizer-with-values +(defmfun set-fminimizer-with-values (minimizer function x-minimum x-lower x-upper f-minimum f-lower f-upper) "gsl_min_fminimizer_set_with_values" ((minimizer :pointer) (function :pointer) (x-minimum :double) (x-lower :double) (x-upper :double) (f-minimum :double) (f-lower :double) (f-upper :double)) - :documentation + :documentation ; FDL "Set, or reset, an existing minimizer to use the function and the initial search interval [lower, upper], with a guess for the location of the minimum, using supplied rather than computed values of the function.") -(defun-gsl free-fminimizer (minimizer) +(defmfun free-fminimizer (minimizer) "gsl_min_fminimizer_free" ((minimizer :pointer)) :c-return :void :export nil :index (letm fminimizer) - :documentation + :documentation ; FDL "Free all the memory associated with the minimizer.") -(defun-gsl fminimizer-name (minimizer) +(defmfun fminimizer-name (minimizer) "gsl_min_fminimizer_name" ((minimizer :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the minimizer.") ;;;;**************************************************************************** ;;;; Iteration ;;;;**************************************************************************** -(defun-gsl iterate-fminimizer (minimizer) +(defmfun iterate-fminimizer (minimizer) "gsl_min_fminimizer_iterate" ((minimizer :pointer)) :c-return :success-continue - :documentation + :documentation ; FDL "Perform a single iteration of the minimizer. The following errors may be signalled: :EBADFUNC, the iteration encountered a singular point where the function or its @@ -78,48 +78,48 @@ :FAILURE, the algorithm could not improve the current best approximation or bounding interval.") -(defun-gsl fminimizer-x-minimum (minimizer) +(defmfun fminimizer-x-minimum (minimizer) "gsl_min_fminimizer_x_minimum" ((minimizer :pointer)) :c-return :double - :documentation + :documentation ; FDL "The current estimate of the position of the minimum for the minimizer.") -(defun-gsl fminimizer-x-lower (minimizer) +(defmfun fminimizer-x-lower (minimizer) "gsl_min_fminimizer_x_lower" ((minimizer :pointer)) :c-return :double - :documentation + :documentation ; FDL "The current lower bound of the interval for the minimizer.") -(defun-gsl fminimizer-x-upper (minimizer) +(defmfun fminimizer-x-upper (minimizer) "gsl_min_fminimizer_x_upper" ((minimizer :pointer)) :c-return :double - :documentation + :documentation ; FDL "The current upper bound of the interval for the minimizer.") -(defun-gsl fminimizer-f-minimum (minimizer) +(defmfun fminimizer-f-minimum (minimizer) "gsl_min_fminimizer_f_minimum" ((minimizer :pointer)) :c-return :double - :documentation + :documentation ; FDL "The value of the function at the current estimate of the minimum for the minimizer.") -(defun-gsl fminimizer-f-lower (minimizer) +(defmfun fminimizer-f-lower (minimizer) "gsl_min_fminimizer_f_lower" ((minimizer :pointer)) :c-return :double - :documentation + :documentation ; FDL "The value of the function at the current estimate of the lower bound for the minimizer.") -(defun-gsl fminimizer-f-upper (minimizer) +(defmfun fminimizer-f-upper (minimizer) "gsl_min_fminimizer_f_upper" ((minimizer :pointer)) :c-return :double - :documentation + :documentation ; FDL "The value of the function at the current estimate of the upper bound for the minimizer.") @@ -127,12 +127,13 @@ ;;;; Stopping parameters ;;;;**************************************************************************** -(defun-gsl min-test-interval (lower upper absolute-error relative-error) +(defmfun + min-test-interval (lower upper absolute-error relative-error) "gsl_min_test_interval" ((lower :double) (upper :double) (absolute-error :double) (relative-error :double)) :c-return :success-continue ; guess that this is s-c, not s-f - :documentation + :documentation ; FDL "Test for the convergence of the interval [lower,upper] with absolute error and relative error specified. The test returns T if the following condition is achieved: @@ -153,7 +154,7 @@ ;;;; Minimization algorithms ;;;;**************************************************************************** -(defvariable *golden-section-fminimizer* "gsl_min_fminimizer_goldensection" +(defmpar *golden-section-fminimizer* "gsl_min_fminimizer_goldensection" "The golden section algorithm is the simplest method of bracketing the minimum of a function. It is the slowest algorithm provided by the library, with linear convergence. @@ -169,7 +170,7 @@ golden section as the bisection ratio can be shown to provide the fastest convergence for this type of algorithm.") -(defvariable *brent-fminimizer* "gsl_min_fminimizer_brent" +(defmpar *brent-fminimizer* "gsl_min_fminimizer_brent" "The Brent minimization algorithm combines a parabolic interpolation with the golden section algorithm. This produces a fast algorithm which is still robust. diff --git a/solve-minimize-fit/nonlinear-least-squares.lisp b/solve-minimize-fit/nonlinear-least-squares.lisp index 1915daa335b322530eeb03e2064b55ef8d58c88b..90e4385bfbfac2c6d6bc7293608a4d686ae118a4 100644 --- a/solve-minimize-fit/nonlinear-least-squares.lisp +++ b/solve-minimize-fit/nonlinear-least-squares.lisp @@ -1,6 +1,6 @@ ;; Nonlinear least squares fitting. ;; Liam Healy, 2008-02-09 12:59:16EST nonlinear-least-squares.lisp -;; Time-stamp: <2008-02-10 23:16:29EST nonlinear-least-squares.lisp> +;; Time-stamp: <2008-02-17 18:26:44EST nonlinear-least-squares.lisp> ;; $Id: $ (in-package :gsl) @@ -16,9 +16,9 @@ function initial-guess) allocate-ffit free-ffit set-ffit 3) -(defun-gsl allocate-ffit (solver-type number-of-observations number-of-parameters) +(defmfun allocate-ffit (solver-type number-of-observations number-of-parameters) "gsl_multifit_fsolver_alloc" - ((solver-type :pointer) (number-of-observations :size) (number-of-parameters :size)) + ((solver-type :pointer) (number-of-observations size) (number-of-parameters size)) :c-return :pointer :export nil :index (letm nonlinear-ffit) @@ -26,14 +26,14 @@ "Allocate an instance of a solver. The number of observations must be greater than or equal to parameters.") -(defun-gsl set-ffit (solver function initial-guess) +(defmfun set-ffit (solver function initial-guess) "gsl_multifit_fsolver_set" ((solver :pointer) (function :pointer) (initial-guess :pointer)) :documentation ; FDL "Initialize or reinitialize an existing solver to use the function and the initial guess.") -(defun-gsl free-ffit (solver) +(defmfun free-ffit (solver) "gsl_multifit_fsolver_free" ((solver :pointer)) :c-return :void @@ -42,7 +42,7 @@ :documentation ; FDL "Free all the memory associated with the solver.") -(defun-gsl name-ffit (solver) +(defmfun name-ffit (solver) "gsl_multifit_fsolver_name" ((solver :pointer)) :c-return :string @@ -57,9 +57,9 @@ functions initial-guess) allocate-fdffit free-fdffit set-fdffit 3) -(defun-gsl allocate-fdffit (solver-type number-of-observations number-of-parameters) +(defmfun allocate-fdffit (solver-type number-of-observations number-of-parameters) "gsl_multifit_fdfsolver_alloc" - ((solver-type :pointer) (number-of-observations :size) (number-of-parameters :size)) + ((solver-type :pointer) (number-of-observations size) (number-of-parameters size)) :c-return :pointer :export nil :index (letm nonlinear-fdffit) @@ -67,14 +67,14 @@ "Allocate an instance of a solver. The number of observations must be greater than or equal to parameters.") -(defun-gsl set-fdffit (solver function initial-guess) +(defmfun set-fdffit (solver function initial-guess) "gsl_multifit_fdfsolver_set" ((solver :pointer) (function :pointer) ((pointer initial-guess) :pointer)) :documentation ; FDL "Initialize or reinitialize an existing solver to use the function and the initial guess.") -(defun-gsl free-fdffit (solver) +(defmfun free-fdffit (solver) "gsl_multifit_fdfsolver_free" ((solver :pointer)) :c-return :void @@ -83,7 +83,7 @@ :documentation ; FDL "Free all the memory associated with the solver.") -(defun-gsl name-fdffit (solver) +(defmfun name-fdffit (solver) "gsl_multifit_fdfsolver_name" ((solver :pointer)) :c-return :string @@ -114,7 +114,7 @@ ;; See /usr/include/gsl/gsl_multifit_nlin.h "The definition of a function for nonlinear least squares fitting in GSL." (function :pointer) - (dimensions :size) + (dimensions size) (parameters :pointer)) (cffi:defcstruct gsl-fdffit-function @@ -124,8 +124,8 @@ (function :pointer) (df :pointer) (fdf :pointer) - (number-of-observations :size) - (number-of-parameters :size) + (number-of-observations size) + (number-of-parameters size) (parameters :pointer)) (export 'def-fitting-functions) @@ -153,21 +153,21 @@ ;;;; Iteration ;;;;**************************************************************************** -(defun-gsl iterate-ffit (solver) +(defmfun iterate-ffit (solver) "gsl_multifit_fsolver_iterate" ((solver :pointer)) :documentation ; FDL "Perform a single iteration of the solver. The solver maintains a current estimate of the best-fit parameters at all times. ") -(defun-gsl iterate-fdffit (solver) +(defmfun iterate-fdffit (solver) "gsl_multifit_fdfsolver_iterate" ((solver :pointer)) :documentation ; FDL "Perform a single iteration of the solver. The solver maintains a current estimate of the best-fit parameters at all times. ") -(defun-gsl current-parameters-ffit (solver) +(defmfun current-parameters-ffit (solver) "gsl_multifit_fsolver_position" ((solver :pointer)) :c-return (canswer :pointer) @@ -175,7 +175,7 @@ :documentation ; FDL "The current best-fit parameters.") -(defun-gsl current-parameters-fdffit (solver) +(defmfun current-parameters-fdffit (solver) "gsl_multifit_fdfsolver_position" ((solver :pointer)) :c-return (canswer :pointer) @@ -187,7 +187,7 @@ ;;;; Search stopping ;;;;**************************************************************************** -(defun-gsl fit-test-delta +(defmfun fit-test-delta (last-step current-position absolute-error relative-error) "gsl_multifit_test_delta" ((last-step :pointer) (current-position :pointer) @@ -200,7 +200,7 @@ if |last-step_i| < absolute-error + relative-error |current-position_i| for each component i of current-position and returns NIL otherwise.") -(defun-gsl fit-test-gradient (gradient absolute-error) +(defmfun fit-test-gradient (gradient absolute-error) "gsl_multifit_test_gradient" ((gradient :pointer) (absolute-error :double)) :c-return :success-continue @@ -214,7 +214,7 @@ is unimportant provided a value can be found where the gradient is small enough.") -(defun-gsl fit-gradient (jacobian function-values gradient) +(defmfun fit-gradient (jacobian function-values gradient) "gsl_multifit_gradient" ((jacobian :pointer) ((pointer function-values) :pointer) (gradient :pointer)) :documentation ; FDL @@ -226,7 +226,7 @@ ;;;; Minimization using derivatives ;;;;**************************************************************************** -(defvariable *levenberg-marquardt* "gsl_multifit_fdfsolver_lmsder" +(defmpar *levenberg-marquardt* "gsl_multifit_fdfsolver_lmsder" ;; FDL "A robust and efficient version of the Levenberg-Marquardt algorithm as implemented in the scaled lmder routine in @@ -266,9 +266,9 @@ These error codes indicate that further iterations will be unlikely to change the solution from its current value.") -(defvariable *levenberg-marquardt-unscaled* "gsl_multifit_fdfsolver_lmder" +(defmpar *levenberg-marquardt-unscaled* "gsl_multifit_fdfsolver_lmder" ;; FDL - "The unscaled version of the @sc{lmder} algorithm. The elements of the + "The unscaled version of *levenberg-marquardt*. The elements of the diagonal scaling matrix D are set to 1. This algorithm may be useful in circumstances where the scaled version of converges too slowly, or the function is already scaled appropriately.") @@ -277,7 +277,7 @@ ;;;; Covariance ;;;;**************************************************************************** -(defun-gsl ls-covariance (jacobian relative-error covariance) +(defmfun ls-covariance (jacobian relative-error covariance) "gsl_multifit_covar" ((jacobian :pointer) (relative-error :double) ((pointer covariance) :pointer)) :return (covariance) @@ -288,26 +288,25 @@ rank deficient. The covariance matrix is given by C = (J^T J)^{-1} and is computed by QR decomposition of J with column-pivoting. Any - columns of R which satisfy |R_{kk}| \leq epsrel |R_{11}| + columns of R which satisfy |R_{kk}| <= relative-error |R_{11}| are considered linearly-dependent and are excluded from the covariance matrix (the corresponding rows and columns of the covariance matrix are set to zero). If the minimisation uses the weighted least-squares function - f_i = (Y(x, t_i) - y_i) / \sigma_i then the covariance + f_i = (Y(x, t_i) - y_i) / sigma_i then the covariance matrix above gives the statistical error on the best-fit parameters - resulting from the gaussian errors \sigma_i on + resulting from the gaussian errors sigma_i on the underlying data y_i. This can be verified from the relation \delta f = J \delta c and the fact that the fluctuations in f - from the data y_i are normalised by \sigma_i and - so satisfy \langle \delta f \delta f^T \rangle = I - <\delta f \delta f^T> = I. + from the data y_i are normalised by sigma_i and + so satisfy <delta f delta f^T> = I. For an unweighted least-squares function f_i = (Y(x, t_i) - y_i) the covariance matrix above should be multiplied by the variance - of the residuals about the best-fit \sigma^2 = \sum (y_i - Y(x,t_i))^2 / (n-p) - to give the variance-covariance - matrix \sigma^2 C. This estimates the statistical error on the + of the residuals about the best-fit sigma^2 = sum (y_i - Y(x,t_i))^2 / (n-p) + to give the variance-covariance matrix sigma^2 C. + This estimates the statistical error on the best-fit parameters from the scatter of the underlying data. For more information about covariance matrices see the GSL documentation diff --git a/solve-minimize-fit/roots-multi.lisp b/solve-minimize-fit/roots-multi.lisp index 4376d8802a75efcaa39b6e3e087980e699d00baa..08b4474581651a36c60172590098ef9ae70d5328 100644 --- a/solve-minimize-fit/roots-multi.lisp +++ b/solve-minimize-fit/roots-multi.lisp @@ -1,6 +1,6 @@ ;;; Multivariate roots. ;;; Liam Healy 2008-01-12 12:49:08 -;;; Time-stamp: <2008-02-03 16:21:50EST roots-multi.lisp> +;;; Time-stamp: <2008-02-17 18:15:07EST roots-multi.lisp> ;;; $Id: $ (in-package :gsl) @@ -19,7 +19,7 @@ ;; See /usr/include/gsl/gsl_multiroots.h "The definition of a function for multiroot finding in GSL." (function :pointer) - (dimensions :size) + (dimensions size) (parameters :pointer)) (export 'def-mfunction) @@ -36,7 +36,7 @@ (function :pointer) (df :pointer) (fdf :pointer) - (dimensions :size) + (dimensions size) (parameters :pointer)) ;;;;**************************************************************************** @@ -57,9 +57,9 @@ (lambda (symb) `(set-mfdfsolver ,symb ,function-derivative ,initial)))) -(defun-gsl allocate-mfsolver (type dimension) +(defmfun allocate-mfsolver (type dimension) "gsl_multiroot_fsolver_alloc" - ((type :pointer) (dimension :size)) + ((type :pointer) (dimension size)) :c-return :pointer :export nil :index (letm mfsolver) @@ -67,9 +67,9 @@ "Allocate an instance of a solver of the type specified for a system of the specified number of dimensions.") -(defun-gsl allocate-mfdfsolver (type dimension) +(defmfun allocate-mfdfsolver (type dimension) "gsl_multiroot_fdfsolver_alloc" - ((type :pointer) (dimension :size)) + ((type :pointer) (dimension size)) :c-return :pointer :export nil :index (letm mfdfsolver) @@ -77,7 +77,7 @@ "Allocate an instance of a derivative solver of the type specified for a system of the specified number of dimensions.") -(defun-gsl set-mfsolver (solver function initial) +(defmfun set-mfsolver (solver function initial) "gsl_multiroot_fsolver_set" ((solver :pointer) (function :pointer) ((pointer initial) :pointer)) :export nil @@ -86,7 +86,7 @@ "Set or reset an existing solver to use the function and the initial guess gsl-vector.") -(defun-gsl set-mfdfsolver (solver function-derivative initial) +(defmfun set-mfdfsolver (solver function-derivative initial) "gsl_multiroot_fdfsolver_set" ((solver :pointer) (function-derivative :pointer) ((pointer initial) :pointer)) @@ -96,7 +96,7 @@ "Set or reset an existing solver to use the function and derivative (fdf) and the initial guess.") -(defun-gsl free-mfsolver (solver) +(defmfun free-mfsolver (solver) "gsl_multiroot_fsolver_free" ((solver :pointer)) :c-return :void @@ -105,7 +105,7 @@ :documentation ; FDL "Free all the memory associated with the solver.") -(defun-gsl free-mfdfsolver (solver) +(defmfun free-mfdfsolver (solver) "gsl_multiroot_fdfsolver_free" ((solver :pointer)) :c-return :void @@ -114,14 +114,14 @@ :documentation ; FDL "Free all the memory associated with the solver.") -(defun-gsl mfsolver-name (solver) +(defmfun mfsolver-name (solver) "gsl_multiroot_fsolver_name" ((solver :pointer)) :c-return :string :documentation ; FDL "The name of the solver.") -(defun-gsl mfdfsolver-name (solver) +(defmfun mfdfsolver-name (solver) "gsl_multiroot_fdfsolver_name" ((solver :pointer)) :c-return :string @@ -132,7 +132,7 @@ ;;;; Iteration ;;;;**************************************************************************** -(defun-gsl iterate-mfsolver (solver) +(defmfun iterate-mfsolver (solver) "gsl_multiroot_fsolver_iterate" ((solver :pointer)) :documentation ; FDL @@ -143,7 +143,7 @@ :EZERODIV, the derivative of the function vanished at the iteration point, preventing the algorithm from continuing without a division by zero.") -(defun-gsl iterate-mfdfsolver (solver) +(defmfun iterate-mfdfsolver (solver) "gsl_multiroot_fdfsolver_iterate" ((solver :pointer)) :documentation ; FDL @@ -154,7 +154,7 @@ :EZERODIV, the derivative of the function vanished at the iteration point, preventing the algorithm from continuing without a division by zero.") -(defun-gsl mfsolver-root (solver) +(defmfun mfsolver-root (solver) "gsl_multiroot_fsolver_root" ((solver :pointer)) :c-return (canswer :pointer) @@ -162,7 +162,7 @@ :documentation ; FDL "The current estimate of the root for the solver.") -(defun-gsl mfdfsolver-root (solver) +(defmfun mfdfsolver-root (solver) "gsl_multiroot_fdfsolver_root" ((solver :pointer)) :c-return (canswer gsl-vector-c) @@ -170,7 +170,7 @@ :documentation "The current estimate of the root for the solver.") -(defun-gsl mfsolver-f (solver) +(defmfun mfsolver-f (solver) "gsl_multiroot_fsolver_f" ((solver :pointer)) :c-return (canswer gsl-vector-c) @@ -178,7 +178,7 @@ :documentation ; FDL "The function value f(x) at the current estimate x of the root for the solver.") -(defun-gsl mfdfsolver-f (solver) +(defmfun mfdfsolver-f (solver) "gsl_multiroot_fdfsolver_f" ((solver :pointer)) :c-return (canswer gsl-vector-c) @@ -186,7 +186,7 @@ :documentation ; FDL "The function value f(x) at the current estimate x of the root for the solver.") -(defun-gsl mfsolver-dx (solver) +(defmfun mfsolver-dx (solver) "gsl_multiroot_fsolver_dx" ((solver :pointer)) :c-return (canswer gsl-vector-c) @@ -194,7 +194,7 @@ :documentation ; FDL "The last step dx taken by the solver.") -(defun-gsl mfdfsolver-dx (solver) +(defmfun mfdfsolver-dx (solver) "gsl_multiroot_fsolver_dx" ((solver :pointer)) :c-return (canswer gsl-vector-c) @@ -221,7 +221,7 @@ (defun multiroot-slot (solver slot) (cffi:foreign-slot-value solver 'gsl-multiroot-fsolver slot)) -(defun-gsl multiroot-test-delta (solver absolute-error relative-error) +(defmfun multiroot-test-delta (solver absolute-error relative-error) "gsl_multiroot_test_delta" (((multiroot-slot solver 'dx) :pointer) ((multiroot-slot solver 'x) :pointer) @@ -235,7 +235,7 @@ |dx_i| < epsabs + epsrel |x_i| for each component of x and returns NIL otherwise.") -(defun-gsl multiroot-test-residual (solver absolute-error) +(defmfun multiroot-test-residual (solver absolute-error) "gsl_multiroot_test_residual" (((multiroot-slot solver 'f) :pointer) (absolute-error :double)) :c-return :success-failure @@ -252,10 +252,10 @@ ;;;; Algorithms using derivatives ;;;;**************************************************************************** -(defvariable *powells-hybrid* "gsl_multiroot_fdfsolver_hybridsj" +(defmpar *powells-hybrid* "gsl_multiroot_fdfsolver_hybridsj" ;; FDL "This is a modified version of Powell's Hybrid method as implemented in - the hybrj algorithm in @sc{minpack}. Minpack was written by Jorge + the hybrj algorithm in minpack. Minpack was written by Jorge J. More, Burton S. Garbow and Kenneth E. Hillstrom. The Hybrid algorithm retains the fast convergence of Newton's method but will also reduce the residual when Newton's method is unreliable. @@ -298,14 +298,14 @@ re-evaluations of the Jacobian indicate that the iteration is not making any progress, preventing the algorithm from continuing.") -(defvariable *powells-hybrid-unscaled* "gsl_multiroot_fdfsolver_hybridj" +(defmpar *powells-hybrid-unscaled* "gsl_multiroot_fdfsolver_hybridj" ;; FDL "This algorithm is an unscaled version of *powells-hybrid*. The steps are controlled by a spherical trust region |x' - x| < \delta, instead of a generalized region. This can be useful if the generalized region estimated by *powells-hybrid* is inappropriate.") -(defvariable *newton-mfdfsolver* "gsl_multiroot_fdfsolver_newton" +(defmpar *newton-mfdfsolver* "gsl_multiroot_fdfsolver_newton" ;; FDL "Newton's Method is the standard root-polishing algorithm. The algorithm begins with an initial guess for the location of the solution. On each @@ -319,7 +319,7 @@ J dx = - f(x) using LU decomposition.") -(defvariable *gnewton-mfdfsolver* "gsl_multiroot_fdfsolver_gnewton" +(defmpar *gnewton-mfdfsolver* "gsl_multiroot_fdfsolver_gnewton" ;; FDL "A modified version of Newton's method which attempts to improve global convergence by requiring every step to reduce the Euclidean norm @@ -334,7 +334,7 @@ ;;;; Algorithms without derivatives ;;;;**************************************************************************** -(defvariable *hybrid-scaled* "gsl_multiroot_fsolver_hybrids" +(defmpar *hybrid-scaled* "gsl_multiroot_fsolver_hybrids" ;; FDL "This is a version of the Hybrid algorithm which replaces calls to the Jacobian function by its finite difference approximation. The finite @@ -343,12 +343,12 @@ ;; Where is this function and parameter? Only thing that shows in the ;; library is gsl_multiroot_fdjacobian. -(defvariable *hybrid-unscaled* "gsl_multiroot_fsolver_hybrid" +(defmpar *hybrid-unscaled* "gsl_multiroot_fsolver_hybrid" ;; FDL "A finite difference version of the Hybrid algorithm without internal scaling.") -(defvariable *discrete-newton* "gsl_multiroot_fsolver_dnewton" +(defmpar *discrete-newton* "gsl_multiroot_fsolver_dnewton" ;; FDL "The discrete Newton algorithm is the simplest method of solving a multidimensional system. It uses the Newton iteration @@ -365,7 +365,7 @@ iteration. The algorithm may become unstable if the finite differences are not a good approximation to the true derivatives.") -(defvariable *broyden* "gsl_multiroot_fsolver_broyden" +(defmpar *broyden* "gsl_multiroot_fsolver_broyden" ;; FDL "The Broyden algorithm is a version of the discrete Newton algorithm which attempts to avoids the expensive update of the Jacobian diff --git a/solve-minimize-fit/roots-one.lisp b/solve-minimize-fit/roots-one.lisp index 61a5199e9a42379cafecac25353080ad10c67e09..095115ace830814ad18389eeb42e25a697ebc51d 100644 --- a/solve-minimize-fit/roots-one.lisp +++ b/solve-minimize-fit/roots-one.lisp @@ -1,6 +1,6 @@ ;; One-dimensional root solver. ;; Liam Healy -;; Time-stamp: <2008-02-03 13:22:55EST roots-one.lisp> +;; Time-stamp: <2008-02-17 18:13:47EST roots-one.lisp> ;; $Id: $ (in-package :gsl) @@ -48,73 +48,73 @@ (defgo-s (fdfsolver type function-derivative root-guess) allocate-fdfsolver free-fdfsolver set-fdfsolver) -(defun-gsl allocate-fsolver (type) +(defmfun allocate-fsolver (type) "gsl_root_fsolver_alloc" ((type :pointer)) :c-return :pointer :export nil :index (letm fsolver) - :documentation + :documentation ; FDL "Allocate an instance of a solver of the given type.") -(defun-gsl allocate-fdfsolver (type) +(defmfun allocate-fdfsolver (type) "gsl_root_fdfsolver_alloc" ((type :pointer)) :c-return :pointer :export nil :index (letm fdfsolver) - :documentation + :documentation ; FDL "Allocate an instance of a derivative-based solver of the given type.") -(defun-gsl set-fsolver (solver function lower upper) +(defmfun set-fsolver (solver function lower upper) "gsl_root_fsolver_set" ((solver :pointer) (function :pointer) (lower :double) (upper :double)) :export nil :index (letm fsolver) - :documentation + :documentation ; FDL "Initialize or reinitialize an existing solver to use the function and the initial search interval [lower, upper].") -(defun-gsl set-fdfsolver (solver function-derivative root-guess) +(defmfun set-fdfsolver (solver function-derivative root-guess) "gsl_root_fdfsolver_set" ((solver :pointer) (function-derivative :pointer) (root-guess :double)) :export nil :index (letm fdfsolver) - :documentation + :documentation ; FDL "Initialize or reinitialize an existing solver.") -(defun-gsl free-fsolver (solver) +(defmfun free-fsolver (solver) "gsl_root_fsolver_free" ((solver :pointer)) :c-return :void :export nil :index (letm fsolver) - :documentation + :documentation ; FDL "Free all the memory associated with the solver.") -(defun-gsl free-fdfsolver (solver) +(defmfun free-fdfsolver (solver) "gsl_root_fdfsolver_free" ((solver :pointer)) :c-return :void :export nil :index (letm fdfsolver) - :documentation + :documentation ; FDL "Free all the memory associated with the solver.") -(defun-gsl fsolver-name (solver) +(defmfun fsolver-name (solver) "gsl_root_fsolver_name" ((solver :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the solver.") -(defun-gsl fdfsolver-name (solver) +(defmfun fdfsolver-name (solver) "gsl_root_fdfsolver_name" ((solver :pointer)) :c-return :string - :documentation + :documentation ; FDL "The name of the solver.") ;;;;**************************************************************************** @@ -122,10 +122,10 @@ ;;;;**************************************************************************** ;; It appears that this is always returning :SUCCESS (0). -(defun-gsl iterate-fsolver (solver) +(defmfun iterate-fsolver (solver) "gsl_root_fsolver_iterate" ((solver :pointer)) - :documentation + :documentation ; FDL "Perform a single iteration of the solver. The following errors may be signalled: :EBADFUNC, the iteration encountered a singular point where the function or its @@ -133,10 +133,10 @@ :EZERODIV, the derivative of the function vanished at the iteration point, preventing the algorithm from continuing without a division by zero.") -(defun-gsl iterate-fdfsolver (solver) +(defmfun iterate-fdfsolver (solver) "gsl_root_fdfsolver_iterate" ((solver :pointer)) - :documentation + :documentation ; FDL "Perform a single iteration of the solver. The following errors may be signalled: :EBADFUNC, the iteration encountered a singular point where the function or its @@ -144,67 +144,66 @@ :EZERODIV, the derivative of the function vanished at the iteration point, preventing the algorithm from continuing without a division by zero.") -(defun-gsl fsolver-root (solver) +(defmfun fsolver-root (solver) "gsl_root_fsolver_root" ((solver :pointer)) :c-return :double - :documentation + :documentation ; FDL "The current estimate of the root for the solver.") -(defun-gsl fdfsolver-root (solver) +(defmfun fdfsolver-root (solver) "gsl_root_fdfsolver_root" ((solver :pointer)) :c-return :double - :documentation + :documentation ; FDL "The current estimate of the root for the solver.") -(defun-gsl fsolver-lower (solver) +(defmfun fsolver-lower (solver) "gsl_root_fsolver_x_lower" ((solver :pointer)) :c-return :double - :documentation + :documentation ; FDL "The lower end of the current bracketing interval for the solver.") -(defun-gsl fsolver-upper (solver) +(defmfun fsolver-upper (solver) "gsl_root_fsolver_x_upper" ((solver :pointer)) :c-return :double - :documentation + :documentation ; FDL "The upper end of the current bracketing interval for the solver.") ;;;;**************************************************************************** ;;;; Search stopping conditions ;;;;**************************************************************************** -(defun-gsl root-test-interval (lower upper absolute-error relative-error) +(defmfun root-test-interval (lower upper absolute-error relative-error) "gsl_root_test_interval" ((lower :double) (upper :double) (absolute-error :double) (relative-error :double)) :c-return :success-continue ; GSL documentation not clear on this - :documentation + :documentation ; FDL "Test for the convergence of the interval [lower,upper] with absolute error absolute-error and relative error relative-error. This returns T if the following condition is achieved, |a - b| < epsabs + epsrel min(|a|,|b|) - when the interval @math{x = [a,b]} does not include the origin. If the - interval includes the origin then @math{\min(|a|,|b|)} is replaced by - zero (which is the minimum value of @math{|x|} over the interval). This + when the interval x = [a,b] does not include the origin. If the + interval includes the origin then min(|a|,|b|) is replaced by + zero (which is the minimum value of |x| over the interval). This ensures that the relative error is accurately estimated for roots close to the origin. This condition on the interval also implies that any estimate of the - root @math{r} in the interval satisfies the same condition with respect - to the true root @math{r^*}, - |r - r^*| < epsabs + epsrel r^* - assuming that the true root @math{r^*} is contained within the interval.") + root r in the interval satisfies the same condition with respect + to the true root r^*, |r - r^*| < epsabs + epsrel r^* + assuming that the true root r^* is contained within the interval.") -(defun-gsl root-test-delta (x1 x0 absolute-error relative-error) +(defmfun root-test-delta (x1 x0 absolute-error relative-error) "gsl_root_test_delta" ((x1 :double) (x0 :double) (absolute-error :double) (relative-error :double)) :c-return :success-continue - :documentation + :documentation ; FDL "Test for the convergence of the sequence ... x0, x1 with absolute error absolute-error and relative error relative-error. The test returns T if the following @@ -212,17 +211,17 @@ |x_1 - x_0| < epsabs + epsrel |x_1| and returns NIL otherwise.") -(defun-gsl root-test-residual (f absolute-error) +(defmfun root-test-residual (f absolute-error) "gsl_root_test_residual" ((f :double) (absolute-error :double)) :c-return :success-continue - :documentation + :documentation ; FDL "Tests the residual value f against the absolute error bound absolute-error. The test returns T if the following condition is achieved, |f| < epsabs and returns NIL otherwise. This criterion is suitable - for situations where the precise location of the root, @math{x}, is + for situations where the precise location of the root, x, is unimportant provided a value can be found where the residual, |f(x)|, is small enough.") @@ -230,7 +229,8 @@ ;;;; Root bracketing algorithms ;;;;**************************************************************************** -(defvariable *bisection-fsolver* "gsl_root_fsolver_bisection" +(defmpar *bisection-fsolver* "gsl_root_fsolver_bisection" + ;; FDL "The bisection algorithm is the simplest method of bracketing the roots of a function. It is the slowest algorithm provided by the library, with linear convergence. @@ -245,7 +245,8 @@ At any time the current estimate of the root is taken as the midpoint of the interval.") -(defvariable *false-position-fsolver* "gsl_root_fsolver_falsepos" +(defmpar *false-position-fsolver* "gsl_root_fsolver_falsepos" + ;; FDL "The false position algorithm is a method of finding roots based on linear interpolation. Its convergence is linear, but it is usually faster than bisection. @@ -261,7 +262,8 @@ The best estimate of the root is taken from the linear interpolation of the interval on the current iteration.") -(defvariable *brent-fsolver* "gsl_root_fsolver_brent" +(defmpar *brent-fsolver* "gsl_root_fsolver_brent" + ;; FDL "The Brent-Dekker method (referred to here as Brent's method) combines an interpolation strategy with the bisection algorithm. This produces a fast algorithm which is still robust. @@ -284,17 +286,19 @@ ;;;; Root finding algorithms using derivatives ;;;;**************************************************************************** -(defvariable *newton-fdfsolver* "gsl_root_fdfsolver_newton" +(defmpar *newton-fdfsolver* "gsl_root_fdfsolver_newton" + ;; FDL "Newton's Method is the standard root-polishing algorithm. The algorithm begins with an initial guess for the location of the root. On each - iteration, a line tangent to the function @math{f} is drawn at that - position. The point where this line crosses the @math{x}-axis becomes + iteration, a line tangent to the function f is drawn at that + position. The point where this line crosses the x-axis becomes the new guess. The iteration is defined by the following sequence, x_{i+1} = x_i - f(x_i) / f'(x_i) Newton's method converges quadratically for single roots, and linearly for multiple roots.") -(defvariable *secant-fdfsolver* "gsl_root_fdfsolver_secant" +(defmpar *secant-fdfsolver* "gsl_root_fdfsolver_secant" + ;; FDL "The secant method is a simplified version of Newton's method which does not require the computation of the derivative on every step. On its first iteration the algorithm begins with Newton's method, using @@ -318,7 +322,8 @@ 5)/2 (approximately 1.62). It converges linearly for multiple roots.") -(defvariable *steffenson-fdfsolver* "gsl_root_fdfsolver_steffenson" +(defmpar *steffenson-fdfsolver* "gsl_root_fdfsolver_steffenson" + ;; FDL "The Steffenson method provides the fastest convergence of all the routines. It combines the basic Newton algorithm with an Aitken ``delta-squared'' acceleration. If the Newton iterates are x_i diff --git a/sorting.lisp b/sorting.lisp index 6504098a4e71db3e77c8f3e8f2f146cf8fc7c0bd..ac029dfe948d1afb5bd2a18802730550052016e9 100644 --- a/sorting.lisp +++ b/sorting.lisp @@ -1,6 +1,6 @@ ;; Sorting ;; Liam Healy, Fri Apr 14 2006 - 20:20 -;; Time-stamp: <2008-02-03 19:57:52EST sorting.lisp> +;; Time-stamp: <2008-02-17 10:08:41EST sorting.lisp> ;; $Id: $ (in-package :gsl) @@ -21,9 +21,9 @@ `(cffi:defcallback ,name :int ((a :pointer) (b :pointer)) ,body)) -(defun-gsl heapsort (array count size function) +(defmfun heapsort (array count size function) "gsl_heapsort" - ((array :pointer) (count :size) (size :size) (function :pointer)) + ((array :pointer) (count size) (size size) (function :pointer)) :documentation ; FDL "Sort the count elements of the array of size specified into ascending order using the comparison @@ -34,9 +34,9 @@ the second argument." :c-return :void) -(defun-gsl heapsort-index (p array count size function) +(defmfun heapsort-index (p array count size function) "gsl_heapsort_index" - ((p :size) (array :pointer) (count :size) (size :size) (function :pointer)) + ((p size) (array :pointer) (count size) (size size) (function :pointer)) :documentation ; FDL "Indirectly sort the count elements of the array array, each of size given, into ascending order using the @@ -59,7 +59,7 @@ (:documentation ; FDL "Sort the elements of the vector into ascending numerical order.")) -(defun-gsl-vdsf sort-vector ((vector gsl-vector)) +(defmfun-vdsf sort-vector ((vector gsl-vector)) "gsl_sort_vector" (((pointer vector) gsl-vector-c)) :c-return :void) @@ -74,7 +74,7 @@ in v and the last element of p gives the index of the greatest element in v. The vector v is not changed.")) -(defun-gsl-vdsf sort-vector-index (permutation (vector gsl-vector)) +(defmfun-vdsf sort-vector-index (permutation (vector gsl-vector)) "gsl_sort_vector_index" (((pointer permutation) gsl-permutation-c) ((pointer vector) gsl-vector-c))) @@ -85,9 +85,9 @@ "Find the smallest elements of the vector v and put them into dest, which must be shorter than v.")) -(defun-gsl-vdsf sort-vector-smallest (dest (v gsl-vector)) +(defmfun-vdsf sort-vector-smallest (dest (v gsl-vector)) "gsl_sort_vector_smallest" - (((gsl-array dest) :pointer) ((dim0 dest) :size) + (((gsl-array dest) :pointer) ((dim0 dest) size) ((pointer v) gsl-vector-c)) :c-return :void :invalidate (dest)) @@ -100,10 +100,10 @@ "The indices of the smallest elements of the vector stored in the array p.")) -(defun-gsl-vdsf sort-vector-smallest-index +(defmfun-vdsf sort-vector-smallest-index ((p gsl-vector-fixnum) (v gsl-vector)) "gsl_sort_vector_smallest_index" - (((gsl-array p) :pointer) ((dim0 p) :size) + (((gsl-array p) :pointer) ((dim0 p) size) ((pointer v) gsl-vector-c)) :c-return :void :invalidate (p)) @@ -114,9 +114,9 @@ "Find the largest elements of the vector and put them into dest, which must be shorter than the vector.")) -(defun-gsl-vdsf sort-vector-largest (dest (v gsl-vector)) +(defmfun-vdsf sort-vector-largest (dest (v gsl-vector)) "gsl_sort_vector_largest" - (((gsl-array dest) :pointer) ((dim0 dest) :size) + (((gsl-array dest) :pointer) ((dim0 dest) size) ((pointer v) gsl-vector-c)) :c-return :void :invalidate (dest)) @@ -129,10 +129,10 @@ "The indices of the largest elements of the vector stored in the array p.")) -(defun-gsl-vdsf sort-vector-largest-index +(defmfun-vdsf sort-vector-largest-index ((p gsl-vector-fixnum) (v gsl-vector)) "gsl_sort_vector_largest_index" - (((gsl-array p) :pointer) ((dim0 p) :size) + (((gsl-array p) :pointer) ((dim0 p) size) ((pointer v) gsl-vector-c)) :c-return :void :invalidate (p)) @@ -141,44 +141,71 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test sorting - (lisp-unit:assert-equal - '("-0.321000000000d+01" "-0.200000000000d+01" "0.100000000000d+01" - "0.710000000000d+01" "0.128000000000d+02") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0)))) - (sort-vector vec) - (data vec)))) - (lisp-unit:assert-equalp - #(3 1 4 0 2) - (letm ((perm (permutation 5)) - (vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0)))) - (sort-vector-index perm vec) - (data perm))) - (lisp-unit:assert-equal - '("-0.321000000000d+01" "-0.200000000000d+01" "0.100000000000d+01") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) - (smallest (vector-double 3))) - (sort-vector-smallest smallest vec) - (data smallest)))) - (lisp-unit:assert-equalp - #(3 1 4) - (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) - (smallest (vector-fixnum 3))) - (sort-vector-smallest-index smallest vec) - (data smallest))) - (lisp-unit:assert-equal - '("0.128000000000d+02" "0.710000000000d+01" "0.100000000000d+01") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) - (largest (vector-double 3))) - (sort-vector-largest largest vec) - (data largest)))) - (lisp-unit:assert-equalp - #(2 0 4) - (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) - (largest (vector-fixnum 3))) - (sort-vector-largest-index largest vec) - (data largest)))) - +#| +(make-tests sorting + (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0)))) + (sort-vector vec) + (data vec)) + (letm ((perm (permutation 5)) + (vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0)))) + (sort-vector-index perm vec) + (data perm)) + (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (smallest (vector-double 3))) + (sort-vector-smallest smallest vec) + (data smallest)) + (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (smallest (vector-fixnum 3))) + (sort-vector-smallest-index smallest vec) + (data smallest)) + (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (largest (vector-double 3))) + (sort-vector-largest largest vec) + (data largest)) + (letm ((vec (vector-double #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (largest (vector-fixnum 3))) + (sort-vector-largest-index largest vec) + (data largest))) +|# + +(LISP-UNIT:DEFINE-TEST SORTING + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(-3.21d0 -2.0d0 1.0d0 7.1d0 12.8d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0)))) + (SORT-VECTOR VEC) (DATA VEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(3 1 4 0 2)) + (MULTIPLE-VALUE-LIST + (LETM ((PERM (PERMUTATION 5)) + (VEC (VECTOR-DOUBLE #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0)))) + (SORT-VECTOR-INDEX PERM VEC) + (DATA PERM)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(-3.21d0 -2.0d0 1.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (SMALLEST (VECTOR-DOUBLE 3))) + (SORT-VECTOR-SMALLEST SMALLEST VEC) + (DATA SMALLEST)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(3 1 4)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (SMALLEST (VECTOR-FIXNUM 3))) + (SORT-VECTOR-SMALLEST-INDEX + SMALLEST VEC) + (DATA SMALLEST)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(12.8d0 7.1d0 1.0d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (LARGEST (VECTOR-DOUBLE 3))) + (SORT-VECTOR-LARGEST LARGEST VEC) (DATA LARGEST)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST #(2 0 4)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(7.1d0 -2.0d0 12.8d0 -3.21d0 1.0d0))) + (LARGEST (VECTOR-FIXNUM 3))) + (SORT-VECTOR-LARGEST-INDEX LARGEST VEC) + (DATA LARGEST))))) diff --git a/special-functions/coulomb.lisp b/special-functions/coulomb.lisp index 10f0f69f227639d22a8d34fd2f65f7a2eed0cde9..9a772276f62acdb8caef409ecccea621d1c5af61 100644 --- a/special-functions/coulomb.lisp +++ b/special-functions/coulomb.lisp @@ -1,6 +1,6 @@ ;; Coulumb functions ;; Liam Healy, Sat Mar 18 2006 - 23:23 -;; Time-stamp: <2008-02-16 19:57:49EST coulomb.lisp> +;; Time-stamp: <2008-02-17 18:33:52EST coulomb.lisp> ;; $Id: $ (in-package :gsl) @@ -9,13 +9,13 @@ ;;;; Normalized Hydrogenic Bound States ;;;;**************************************************************************** -(defun-gsl hydrogenicR-1 (x r) +(defmfun hydrogenicR-1 (x r) "gsl_sf_hydrogenicR_1_e" ((x :double) (r :double) (ret sf-result)) :documentation ; FDL "The lowest-order normalized hydrogenic bound state radial wavefunction R_1 := 2Z \sqrt{Z} \exp(-Z r).") -(defun-gsl hydrogenicR (n l x r) +(defmfun hydrogenicR (n l x r) "gsl_sf_hydrogenicR_e" ((n :int) (l :int) (x :double) (r :double) (ret sf-result)) :documentation ; FDL @@ -31,7 +31,7 @@ ;;; Comments are direct from GSL and aren't lispized yet. -(defun-gsl coulomb-wave-FG (eta x L-F k) +(defmfun coulomb-wave-FG (eta x L-F k) "gsl_sf_coulomb_wave_FG_e" ((eta :double) (x :double) (L-F :double) (k :int) (F sf-result) (Fp sf-result) (G sf-result) (Gp sf-result) @@ -51,7 +51,7 @@ :EOVRFLW is signalled and scaling exponents are stored in the modifiable parameters exp-F, exp-G.") -(defun-gsl coulomb-wave-F-array (L-min eta x fc-array) +(defmfun coulomb-wave-F-array (L-min eta x fc-array) "gsl_sf_coulomb_wave_F_array" ((L-min :double) ((1- (dim0 fc-array)) :int) (eta :double) (x :double) ((gsl-array fc-array) :pointer) (F-exponent :double)) @@ -62,7 +62,7 @@ L = Lmin ... Lmin + kmax, storing the results in fc-array. In the case of overflow the exponent is stored in the second value returned.") -(defun-gsl coulomb-wave-FG-array (L-min eta x fc-array gc-array) +(defmfun coulomb-wave-FG-array (L-min eta x fc-array gc-array) "gsl_sf_coulomb_wave_FG_array" ((L-min :double) ((1- (dim0 fc-array)) :int) (eta :double) (x :double) ((gsl-array fc-array) :pointer) ((gsl-array gc-array) :pointer) @@ -74,7 +74,7 @@ results in fc_array and gc_array. In the case of overflow the exponents are stored in F_exponent and G_exponent.") -(defun-gsl coulomb-wave-FGp-array (L-min eta x fc-array fcp-array gc-array gcp-array) +(defmfun coulomb-wave-FGp-array (L-min eta x fc-array fcp-array gc-array gcp-array) "gsl_sf_coulomb_wave_FGp_array" ((L-min :double) ((1- (dim0 fc-array)) :int) (eta :double) (x :double) ((gsl-array fc-array) :pointer) ((gsl-array fcp-array) :pointer) @@ -91,7 +91,7 @@ In the case of overflow the exponents are stored in F_exponent and G_exponent.") -(defun-gsl coulomb-wave-sphF-array (L-min eta x fc-array) +(defmfun coulomb-wave-sphF-array (L-min eta x fc-array) "gsl_sf_coulomb_wave_sphF_array" ((L-min :double) ((1- (dim0 fc-array)) :int) (eta :double) (x :double) ((gsl-array fc-array) :pointer) (F-exponent :double)) @@ -108,13 +108,13 @@ ;;;; Coulomb Wave Function Normalization Constant ;;;;**************************************************************************** -(defun-gsl coulomb-CL (L eta) +(defmfun coulomb-CL (L eta) "gsl_sf_coulomb_CL_e" ((L :double) (eta :double) (ret sf-result)) :documentation ; FDL "The Coulomb wave function normalization constant C_L(\eta) for L > -1.") -(defun-gsl coulomb-CL-array (L-min eta cl) +(defmfun coulomb-CL-array (L-min eta cl) "gsl_sf_coulomb_CL_array" ((L-min :double) ((1- (dim0 cl)) :int) (eta :double) ((gsl-array cl) :pointer)) diff --git a/special-functions/hypergeometric.lisp b/special-functions/hypergeometric.lisp index 554625bed229f8071e523eb6157309c38c4548c7..ceedef4c9b23c3650c020ab27780acbeee4f7d60 100644 --- a/special-functions/hypergeometric.lisp +++ b/special-functions/hypergeometric.lisp @@ -1,6 +1,6 @@ ;; Hypergeometric function ;; Liam Healy, Fri Apr 28 2006 - 23:00 -;; Time-stamp: <2008-02-16 22:11:13EST hypergeometric.lisp> +;; Time-stamp: <2008-02-17 18:30:53EST hypergeometric.lisp> ;; $Id: $ (in-package :gsl) @@ -43,7 +43,7 @@ (defmfun hypergeometric-U ((a float) (b float) x) "gsl_sf_hyperg_U_e" ((a :double) (b :double) (x :double) (ret sf-result)) :type :method - :documentation "The confluent hypergeometric function @math{U(a,b,x)}.") + :documentation "The confluent hypergeometric function U(a,b,x).") (defgeneric hypergeometric-U-e10 (m n x) (:documentation ; FDL diff --git a/special-functions/trigonometry.lisp b/special-functions/trigonometry.lisp index 4c15d31992d4241f73e7a1e3c86fe1249a3c88d2..0bb131ce1b5469ee7784e8ea127589f666a695eb 100644 --- a/special-functions/trigonometry.lisp +++ b/special-functions/trigonometry.lisp @@ -1,6 +1,6 @@ ;; Trigonometry ;; Liam Healy, Thu May 4 2006 - 22:58 -;; Time-stamp: <2008-02-16 22:59:12EST trigonometry.lisp> +;; Time-stamp: <2008-02-17 18:30:19EST trigonometry.lisp> ;; $Id: $ (in-package :gsl) @@ -10,10 +10,10 @@ ;;;;**************************************************************************** (defgeneric gsl-sin (x) - (:documentation "The sine function @math{\sin(x)}.")) + (:documentation "The sine function sin(x).")) (defgeneric gsl-cos (x) - (:documentation "The cosine function @math{\sin(x)}.")) + (:documentation "The cosine function cos(x).")) (defmfun gsl-sin ((x float)) "gsl_sf_sin_e" ((x :double) (ret sf-result)) diff --git a/statistics/absolute-deviation.lisp b/statistics/absolute-deviation.lisp index e7f83140befaf2a138bb6b82bcfec0a29e59ccd0..78ed5cc5804b64d6169aa078cb02822fdb2f4db9 100644 --- a/statistics/absolute-deviation.lisp +++ b/statistics/absolute-deviation.lisp @@ -1,6 +1,6 @@ ;; Absolute deviation ;; Liam Healy, Sun Dec 31 2006 - 13:19 -;; Time-stamp: <2008-02-03 23:16:42EST absolute-deviation.lisp> +;; Time-stamp: <2008-02-17 16:39:38EST absolute-deviation.lisp> ;; $Id: $ (in-package :gsl) @@ -8,9 +8,9 @@ ;;; To do: stride other than 1 when that information is availble from ;;; the vector. -(defun-gsl absolute-deviation-nom (data) +(defmfun absolute-deviation-nom (data) "gsl_stats_absdev" - (((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + (((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index absolute-deviation :export nil @@ -23,10 +23,10 @@ width of a distribution than the variance. This function computes the mean of data via a call to #'mean.") -(defun-gsl absolute-deviation-m (data mean) +(defmfun absolute-deviation-m (data mean) "gsl_stats_absdev_m" (((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double)) + ((dim0 data) size) (mean :double)) :c-return :double :index absolute-deviation :export nil @@ -51,19 +51,19 @@ width of a distribution than the variance. This function computes the mean of data via a call to #'mean.") -(defun-gsl weighted-absolute-deviation-nom (data weights) +(defmfun weighted-absolute-deviation-nom (data weights) "gsl_stats_wabsdev" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + ((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index weighted-absolute-deviation :export nil) -(defun-gsl weighted-absolute-deviation-m (data weights mean) +(defmfun weighted-absolute-deviation-m (data weights mean) "gsl_stats_wabsdev_m" (((gsl-array weights) :pointer) (1 :int) ((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double)) + ((dim0 data) size) (mean :double)) :c-return :double :index weighted-absolute-deviation :export nil) @@ -76,14 +76,27 @@ mean, defined as absdev = (\sum w_i |x_i - \Hat\mu|) / (\sum w_i).") -(lisp-unit:define-test absolute-deviation - (lisp-unit:assert-equal - '("0.618000000000d+01" "0.664777777778d+01" "0.618000000000d+01") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0))) +;;; Examples and unit test + +#| +(make-tests absolute-deviation + (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0))) (weights (vector-double #(3.0d0 1.0d0 2.0d0)))) (let ((mean (mean vec))) (list (absolute-deviation vec) (weighted-absolute-deviation vec weights) - (absolute-deviation vec mean))))))) + (absolute-deviation vec mean))))) +|# + +(LISP-UNIT:DEFINE-TEST ABSOLUTE-DEVIATION + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST (LIST 6.18d0 6.647777777777779d0 6.18d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0))) + (WEIGHTS (VECTOR-DOUBLE #(3.0d0 1.0d0 2.0d0)))) + (LET ((MEAN (MEAN VEC))) + (LIST (ABSOLUTE-DEVIATION VEC) + (WEIGHTED-ABSOLUTE-DEVIATION VEC WEIGHTS) + (ABSOLUTE-DEVIATION VEC MEAN))))))) + diff --git a/statistics/autocorrelation.lisp b/statistics/autocorrelation.lisp index 7fec0b8943951a92e8393d156491828f85f6cea4..d648cb2c79f3dfdfbb3e17cead70f93448b5ecc2 100644 --- a/statistics/autocorrelation.lisp +++ b/statistics/autocorrelation.lisp @@ -1,6 +1,6 @@ ;; Autocorrelation ;; Liam Healy, Sun Dec 31 2006 - 13:19 -;; Time-stamp: <2008-02-03 23:18:13EST autocorrelation.lisp> +;; Time-stamp: <2008-02-17 18:29:36EST autocorrelation.lisp> ;; $Id: $ (in-package :gsl) @@ -8,17 +8,17 @@ ;;; To do: stride other than 1 when that information is availble from ;;; the vector. -(defun-gsl autocorrelation-nom (data) +(defmfun autocorrelation-nom (data) "gsl_stats_lag1_autocorrelation" - (((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + (((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index autocorrelation :export nil) -(defun-gsl autocorrelation-m (data mean) +(defmfun autocorrelation-m (data mean) "gsl_stats_lag1_autocorrelation_m" (((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double)) + ((dim0 data) size) (mean :double)) :c-return :double :index autocorrelation :export nil) @@ -27,17 +27,28 @@ (defun-optionals autocorrelation (data &optional mean) -nom -m ;; FDL - "The lag-1 autocorrelation of the dataset @var{data}. + "The lag-1 autocorrelation of the dataset data. a_1 = {\sum_{i = 1}^{n} (x_{i} - \Hat\mu) (x_{i-1} - \Hat\mu) \over \sum_{i = 1}^{n} (x_{i} - \Hat\mu) (x_{i} - \Hat\mu)}.") -(lisp-unit:define-test autocorrelation - (lisp-unit:assert-equal - '("-0.464636683425d-01" "-0.464636683425d-01") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) +;;; Examples and unit test + +#| +(make-tests autocorrelation + (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) (let ((mean (mean vec))) (list (autocorrelation vec) - (autocorrelation vec mean))))))) + (autocorrelation vec mean))))) +|# + +(LISP-UNIT:DEFINE-TEST AUTOCORRELATION + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST -0.04646366834251103d0 -0.04646366834251103d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0)))) + (LET ((MEAN (MEAN VEC))) + (LIST (AUTOCORRELATION VEC) + (AUTOCORRELATION VEC MEAN))))))) diff --git a/statistics/covariance.lisp b/statistics/covariance.lisp index ae0f37a8a3e9a911c28d939c0e75bc586e650555..7613db3d085621d1e004d8b9d8d5703236ded937 100644 --- a/statistics/covariance.lisp +++ b/statistics/covariance.lisp @@ -1,6 +1,6 @@ ;; Covariance ;; Liam Healy, Sun Dec 31 2006 - 13:19 -;; Time-stamp: <2008-02-03 23:19:46EST covariance.lisp> +;; Time-stamp: <2008-02-17 16:48:17EST covariance.lisp> ;; $Id: $ (in-package :gsl) @@ -8,18 +8,18 @@ ;;; To do: stride other than 1 when that information is availble from ;;; the vector. -(defun-gsl covariance-nom (data1 data2) +(defmfun covariance-nom (data1 data2) "gsl_stats_covariance" (((gsl-array data1) :pointer) (1 :int) - ((gsl-array data2) :pointer) (1 :int) ((dim0 data2) :size)) + ((gsl-array data2) :pointer) (1 :int) ((dim0 data2) size)) :c-return :double :index covariance :export nil) -(defun-gsl covariance-m (data1 data2 mean1 mean2) +(defmfun covariance-m (data1 data2 mean1 mean2) "gsl_stats_covariance_m" (((gsl-array data1) :pointer) (1 :int) - ((gsl-array data2) :pointer) (1 :int) ((dim0 data2) :size) + ((gsl-array data2) :pointer) (1 :int) ((dim0 data2) size) (mean1 :double) (mean2 :double)) :c-return :double :index covariance @@ -29,19 +29,33 @@ (defun-optionals covariance (data1 data2 &optional mean1 mean2) -nom -m ;; FDL - "The covariance of the datasets @var{data1} and - @var{data2} which must both be of the same length @var{n}. + "The covariance of the datasets data1 and data2 which must + be of the same length, covar = {1 \over (n - 1)} \sum_{i = 1}^{n} (x_{i} - \Hat x) (y_{i} - \Hat y).") -(lisp-unit:define-test covariance - (lisp-unit:assert-equal - '("-0.293000000000d+00" "-0.293000000000d+00") - (lisp-unit:fp-sequence - (letm ((vec1 (vector-double #(-3.21d0 1.0d0 12.8d0))) +;;; Examples and unit test + +#| +(make-tests covariance + (letm ((vec1 (vector-double #(-3.21d0 1.0d0 12.8d0))) (vec2 (vector-double #(1.15d0 -1.0d0 0.5d0)))) (let ((mean1 (mean vec1)) (mean2 (mean vec2))) (list (covariance vec1 vec2) - (covariance vec1 vec2 mean1 mean2))))))) + (covariance vec1 vec2 mean1 mean2))))) +|# + +(LISP-UNIT:DEFINE-TEST COVARIANCE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST -0.2929999999999998d0 -0.2929999999999998d0)) + (MULTIPLE-VALUE-LIST + (LETM + ((VEC1 (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0))) + (VEC2 (VECTOR-DOUBLE #(1.15d0 -1.0d0 0.5d0)))) + (LET ((MEAN1 (MEAN VEC1)) (MEAN2 (MEAN VEC2))) + (LIST (COVARIANCE VEC1 VEC2) + (COVARIANCE VEC1 VEC2 MEAN1 MEAN2))))))) + diff --git a/statistics/higher-moments.lisp b/statistics/higher-moments.lisp index 4e881b80acbc1944183b982cc769a6fa931ba448..4e94c4f9bfb17e12b9adbb07c2aa9024c126d263 100644 --- a/statistics/higher-moments.lisp +++ b/statistics/higher-moments.lisp @@ -1,15 +1,15 @@ ;; Skewness and kurtosis. ;; Liam Healy, Sun Dec 31 2006 - 14:20 -;; Time-stamp: <2008-02-03 23:14:05EST higher-moments.lisp> +;; Time-stamp: <2008-02-17 16:42:59EST higher-moments.lisp> ;; $Id: $ (in-package :gsl) ;;; To do: stride other than 1 when that information is availble from ;;; the vector. -(defun-gsl skewness-nomsd (data) +(defmfun skewness-nomsd (data) "gsl_stats_skew" - (((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + (((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index skewness :export nil @@ -19,10 +19,10 @@ where x_i are the elements of the dataset data. The skewness measures the asymmetry of the tails of a distribution.") -(defun-gsl skewness-msd (data mean standard-deviation) +(defmfun skewness-msd (data mean standard-deviation) "gsl_stats_skew_m_sd" (((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double) (standard-deviation :double)) + ((dim0 data) size) (mean :double) (standard-deviation :double)) :c-return :double :index skewness :export nil @@ -43,17 +43,17 @@ where x_i are the elements of the dataset data. The skewness measures the asymmetry of the tails of a distribution.") -(defun-gsl kurtosis-nomsd (data) +(defmfun kurtosis-nomsd (data) "gsl_stats_kurtosis" - (((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + (((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index kurtosis :export nil) -(defun-gsl kurtosis-msd (data mean standard-deviation) +(defmfun kurtosis-msd (data mean standard-deviation) "gsl_stats_kurtosis_m_sd" (((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double) (standard-deviation :double)) + ((dim0 data) size) (mean :double) (standard-deviation :double)) :c-return :double :index kurtosis :export nil) @@ -69,18 +69,18 @@ relative to its width. The kurtosis is normalized to zero for a gaussian distribution.") -(defun-gsl weighted-skewness-nomsd (data weights) +(defmfun weighted-skewness-nomsd (data weights) "gsl_stats_wskew" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + ((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index weighted-skewness :export nil) -(defun-gsl weighted-skewness-msd (data weights mean standard-deviation) +(defmfun weighted-skewness-msd (data weights mean standard-deviation) "gsl_stats_wskew_m_sd" (((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double) (standard-deviation :double)) + ((dim0 data) size) (mean :double) (standard-deviation :double)) :c-return :double :index weighted-skewness :export nil) @@ -93,17 +93,17 @@ "The weighted skewness of the dataset. skew = (\sum w_i ((x_i - xbar)/\sigma)^3) / (\sum w_i).") -(defun-gsl weighted-kurtosis-nomsd (data weights) +(defmfun weighted-kurtosis-nomsd (data weights) "gsl_stats_wkurtosis" - (((gsl-array data) :pointer) (1 :int) ((dim0 data) :size)) + (((gsl-array data) :pointer) (1 :int) ((dim0 data) size)) :c-return :double :index weighted-kurtosis :export nil) -(defun-gsl weighted-kurtosis-msd (data weights mean standard-deviation) +(defmfun weighted-kurtosis-msd (data weights mean standard-deviation) "gsl_stats_wkurtosis_m_sd" (((gsl-array data) :pointer) (1 :int) - ((dim0 data) :size) (mean :double) (standard-deviation :double)) + ((dim0 data) size) (mean :double) (standard-deviation :double)) :c-return :double :index weighted-kurtosis :export nil) @@ -116,16 +116,29 @@ "The weighted kurtosis of the dataset. kurtosis = ((\sum w_i ((x_i - xbar)/sigma)^4) / (\sum w_i)) - 3.") -(lisp-unit:define-test higher-moments - (lisp-unit:assert-equal - '("0.276511898399d+00" "0.276511898399d+00" - "-0.233333333333d+01" "-0.233333333333d+01") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) +;;; Examples and unit test + +#| +(make-tests higher-moments + (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) (let* ((mean (mean vec)) (sd (standard-deviation vec mean))) (list (skewness vec) (skewness vec mean sd) (kurtosis vec) - (kurtosis vec mean sd))))))) + (kurtosis vec mean sd))))) +|# + +(LISP-UNIT:DEFINE-TEST HIGHER-MOMENTS + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 0.2765118983985497d0 0.2765118983985497d0 + -2.333333333333333d0 -2.333333333333333d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0)))) + (LET* ((MEAN (MEAN VEC)) + (SD (STANDARD-DEVIATION VEC MEAN))) + (LIST (SKEWNESS VEC) (SKEWNESS VEC MEAN SD) + (KURTOSIS VEC) + (KURTOSIS VEC MEAN SD))))))) diff --git a/statistics/mean-variance.lisp b/statistics/mean-variance.lisp index 16e7a6ad760d888dd06b1b54ed8e8ccf4192dc83..52cc7694a6422b889e0a7074275ee2df9c292450 100644 --- a/statistics/mean-variance.lisp +++ b/statistics/mean-variance.lisp @@ -1,6 +1,6 @@ ;; Mean, standard deviation, and variance ;; Liam Healy, Sat Dec 2 2006 - 22:15 -;; Time-stamp: <2008-02-03 23:10:32EST mean-variance.lisp> +;; Time-stamp: <2008-02-17 16:35:48EST mean-variance.lisp> ;; $Id: $ (in-package :gsl) @@ -8,9 +8,9 @@ ;;; To do: stride other than 1 when that information is availble from ;;; the vector. -(defmacro defun-gsl-stats (&rest args) - "A defun-gsl for stats of double, single, and fixnum." - (defun-gsl-all +(defmacro defmfun-stats (&rest args) + "A defmfun for stats of double, single, and fixnum." + (defmfun-all ;;'(double single fixnum long) '(double single fixnum) ;;'(:double :float :int :long-double) @@ -19,9 +19,9 @@ 'gsl-vector args)) -(defmacro defun-gsl-stats-ds (&rest args) - "A defun-gsl for stats of double and single." - (defun-gsl-all +(defmacro defmfun-stats-ds (&rest args) + "A defmfun for stats of double and single." + (defmfun-all '(double single) '(:double :float) "stats" @@ -38,9 +38,9 @@ The arithmetic mean, or sample mean, is denoted by \Hat\mu and defined as \Hat\mu = (1/N) \sum x_i. Returns a double-float.")) -(defun-gsl-stats mean ((vector gsl-vector)) +(defmfun-stats mean ((vector gsl-vector)) "gsl_stats_mean" - (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size)) + (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size)) :c-return :double) (defgeneric weighted-mean (gsl-vector weights) @@ -49,10 +49,10 @@ The weighted mean is defined as \Hat\mu = (\sum w_i x_i) / (\sum w_i).")) -(defun-gsl-stats-ds weighted-mean ((vector gsl-vector) weights) +(defmfun-stats-ds weighted-mean ((vector gsl-vector) weights) "gsl_stats_wmean" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size)) + ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size)) :c-return :double) ;;;;**************************************************************************** @@ -74,9 +74,9 @@ you have already computed the mean then you can pass it directly to #'variance-m.")) -(defun-gsl-stats variance-nom ((vector gsl-vector)) +(defmfun-stats variance-nom ((vector gsl-vector)) "gsl_stats_variance" - (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size)) + (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size)) :index variance :export nil :c-return :double) @@ -86,10 +86,10 @@ "Compute the variance with the mean known to avoid its recomputation.")) -(defun-gsl-stats variance-m ((vector gsl-vector) mean) +(defmfun-stats variance-m ((vector gsl-vector) mean) "gsl_stats_variance_m" (((gsl-array vector) :pointer) (1 :int) - ((dim0 vector) :size) (mean :double)) + ((dim0 vector) size) (mean :double)) :index variance :export nil :c-return :double) @@ -115,10 +115,10 @@ (:documentation ; FDL "Compute the weighted variance with the mean unknown.")) -(defun-gsl-stats-ds weighted-variance-nom ((vector gsl-vector) weights) +(defmfun-stats-ds weighted-variance-nom ((vector gsl-vector) weights) "gsl_stats_wvariance" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size)) + ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size)) :index weighted-variance :export nil :c-return :double) @@ -128,11 +128,11 @@ "Compute the weighted variance with the mean known to avoid its recomputation.")) -(defun-gsl-stats-ds weighted-variance-m ((vector gsl-vector) weights mean) +(defmfun-stats-ds weighted-variance-m ((vector gsl-vector) weights mean) "gsl_stats_wvariance_m" (((gsl-array weights) :pointer) (1 :int) ((gsl-array vector) :pointer) (1 :int) - ((dim0 vector) :size) (mean :double)) + ((dim0 vector) size) (mean :double)) :index variance :export nil :c-return :double) @@ -156,9 +156,9 @@ (:documentation ; FDL "The standard deviation, square root of the variance.")) -(defun-gsl-stats standard-deviation-nom ((vector gsl-vector)) +(defmfun-stats standard-deviation-nom ((vector gsl-vector)) "gsl_stats_sd" - (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size)) + (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size)) :index standard-deviation :export nil :c-return :double) @@ -168,10 +168,10 @@ "The standard deviation with the mean known to avoid its recomputation.")) -(defun-gsl-stats standard-deviation-m ((vector gsl-vector) mean) +(defmfun-stats standard-deviation-m ((vector gsl-vector) mean) "gsl_stats_sd_m" (((gsl-array vector) :pointer) (1 :int) - ((dim0 vector) :size) (mean :double)) + ((dim0 vector) size) (mean :double)) :c-return :double) (export 'standard-deviation) @@ -186,23 +186,23 @@ (defgeneric weighted-standard-deviation-nom (gsl-vector weights)) -(defun-gsl-stats-ds weighted-standard-deviation-nom +(defmfun-stats-ds weighted-standard-deviation-nom ((vector gsl-vector) weights) "gsl_stats_wsd" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size)) + ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size)) :index weighted-standard-deviation :export nil :c-return :double) (defgeneric weighted-standard-deviation-m (gsl-vector weights mean)) -(defun-gsl-stats-ds weighted-standard-deviation-m +(defmfun-stats-ds weighted-standard-deviation-m ((vector gsl-vector) weights mean) "gsl_stats_wsd_m" (((gsl-array weights) :pointer) (1 :int) ((gsl-array vector) :pointer) (1 :int) - ((dim0 vector) :size) (mean :double)) + ((dim0 vector) size) (mean :double)) :c-return :double) (export 'weighted-standard-deviation) @@ -224,9 +224,9 @@ \Hat\mu is replaced by the known population mean \mu, \Hat\sigma^2 = (1/N) \sum (x_i - \mu)^2.")) -(defun-gsl-stats variance-with-fixed-mean ((vector gsl-vector) mean) +(defmfun-stats variance-with-fixed-mean ((vector gsl-vector) mean) "gsl_stats_variance_with_fixed_mean" - (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size) + (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size) (mean :double)) :c-return :double) @@ -236,10 +236,10 @@ mean. The result is the square root of the corresponding variance function.")) -(defun-gsl-stats standard-deviation-with-fixed-mean +(defmfun-stats standard-deviation-with-fixed-mean ((vector gsl-vector) mean) "gsl_stats_sd_with_fixed_mean" - (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size) + (((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size) (mean :double)) :c-return :double) @@ -256,11 +256,11 @@ population mean \mu, \Hat\sigma^2 = (\sum w_i (x_i - \mu)^2) / (\sum w_i).")) -(defun-gsl-stats-ds weighted-variance-with-fixed-mean +(defmfun-stats-ds weighted-variance-with-fixed-mean ((vector gsl-vector) weights mean) "gsl_stats_wvariance_with_fixed_mean" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size) + ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size) (mean :double)) :c-return :double) @@ -270,11 +270,11 @@ "The square root of the corresponding variance function #'weighted-variance-with-fixed-mean.")) -(defun-gsl-stats-ds weighted-standard-deviation-with-fixed-mean +(defmfun-stats-ds weighted-standard-deviation-with-fixed-mean ((vector gsl-vector) weights mean) "gsl_stats_wsd_with_fixed_mean" (((gsl-array weights) :pointer) (1 :int) - ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) :size) + ((gsl-array vector) :pointer) (1 :int) ((dim0 vector) size) (mean :double)) :c-return :double) @@ -282,14 +282,9 @@ ;;;; Examples and unit test ;;;;**************************************************************************** -(lisp-unit:define-test mean-variance - (lisp-unit:assert-equal - '("0.353000000000d+01" "0.282833333333d+01" "0.688807000000d+02" - "0.688807000000d+02" "0.849805863636d+02" "0.849805863636d+02" - "0.829943974013d+01" "0.829943974013d+01" "0.461413666667d+02" - "0.679274367739d+01") - (lisp-unit:fp-sequence - (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0))) +#| +(make-tests mean-variance + (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0))) (weights (vector-double #(3.0d0 1.0d0 2.0d0)))) (let ((mean (mean vec)) (wmean (weighted-mean vec weights))) @@ -302,13 +297,8 @@ (standard-deviation vec) (standard-deviation vec mean) (variance-with-fixed-mean vec 4.0d0) - (standard-deviation-with-fixed-mean vec 4.0d0)))))) - (lisp-unit:assert-equal - '("0.333333333333d+01" "0.253333333333d+02" "0.253333333333d+02" - "0.503322295685d+01" "0.503322295685d+01" "0.173333333333d+02" - "0.416333199893d+01") - (lisp-unit:fp-sequence - (letm ((vec (vector-fixnum #(8 4 -2)))) + (standard-deviation-with-fixed-mean vec 4.0d0)))) + (letm ((vec (vector-fixnum #(8 4 -2)))) (let ((mean (mean vec))) (list mean @@ -317,8 +307,43 @@ (standard-deviation vec) (standard-deviation vec mean) (variance-with-fixed-mean vec 4.0d0) - (standard-deviation-with-fixed-mean vec 4.0d0))))))) - - - - + (standard-deviation-with-fixed-mean vec 4.0d0))))) +|# + +(LISP-UNIT:DEFINE-TEST MEAN-VARIANCE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 3.5300000000000002d0 2.8283333333333336d0 + 68.88069999999999d0 68.88069999999999d0 + 84.98058636363639d0 84.98058636363639d0 + 8.29943974012704d0 8.29943974012704d0 + 46.14136666666667d0 6.792743677385941d0)) + (MULTIPLE-VALUE-LIST + (LETM + ((VEC (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0))) + (WEIGHTS (VECTOR-DOUBLE #(3.0d0 1.0d0 2.0d0)))) + (LET ((MEAN (MEAN VEC)) + (WMEAN (WEIGHTED-MEAN VEC WEIGHTS))) + (LIST MEAN WMEAN (VARIANCE VEC) (VARIANCE VEC MEAN) + (WEIGHTED-VARIANCE VEC WEIGHTS) + (WEIGHTED-VARIANCE VEC WEIGHTS WMEAN) + (STANDARD-DEVIATION VEC) + (STANDARD-DEVIATION VEC MEAN) + (VARIANCE-WITH-FIXED-MEAN VEC 4.0d0) + (STANDARD-DEVIATION-WITH-FIXED-MEAN VEC + 4.0d0)))))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST + (LIST 3.3333333333333335d0 25.333333333333336d0 + 25.333333333333336d0 5.033222956847167d0 + 5.033222956847167d0 17.333333333333332d0 + 4.163331998932265d0)) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-FIXNUM #(8 4 -2)))) + (LET ((MEAN (MEAN VEC))) + (LIST MEAN (VARIANCE VEC) (VARIANCE VEC MEAN) + (STANDARD-DEVIATION VEC) + (STANDARD-DEVIATION VEC MEAN) + (VARIANCE-WITH-FIXED-MEAN VEC 4.0d0) + (STANDARD-DEVIATION-WITH-FIXED-MEAN VEC + 4.0d0))))))) diff --git a/statistics/median-percentile.lisp b/statistics/median-percentile.lisp index 7eae9186c17f819f8ef50615cebf30fc69909fdd..fcbc48af2d182576f7ae31bff60f4f1a364f283a 100644 --- a/statistics/median-percentile.lisp +++ b/statistics/median-percentile.lisp @@ -1,6 +1,6 @@ ;; Median and percentile ;; Liam Healy, Sun Dec 31 2006 - 13:19 -;; Time-stamp: <2008-02-03 23:22:42EST median-percentile.lisp> +;; Time-stamp: <2008-02-17 16:50:24EST median-percentile.lisp> ;; $Id: $ (in-package :gsl) @@ -8,9 +8,9 @@ ;;; To do: stride other than 1 when that information is availble from ;;; the vector. -(defun-gsl median (sorted-data) +(defmfun median (sorted-data) "gsl_stats_median_from_sorted_data" - (((gsl-array sorted-data) :pointer) (1 :int) ((dim0 sorted-data) :size)) + (((gsl-array sorted-data) :pointer) (1 :int) ((dim0 sorted-data) size)) :c-return :double :documentation ; FDL "The median value of sorted-data. The elements of the array @@ -24,9 +24,9 @@ computing the median involves interpolation this function always returns a floating-point number, even for integer data types.") -(defun-gsl quantile (sorted-data fraction) +(defmfun quantile (sorted-data fraction) "gsl_stats_quantile_from_sorted_data" - (((gsl-array sorted-data) :pointer) (1 :int) ((dim0 sorted-data) :size) + (((gsl-array sorted-data) :pointer) (1 :int) ((dim0 sorted-data) size) (fraction :double)) :c-return :double :documentation ; FDL @@ -46,12 +46,25 @@ interpolation this function always returns a floating-point number, even for integer data types.") -(lisp-unit:define-test median-percentile - (lisp-unit:assert-first-fp-equal - "0.100000000000d+01" - (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) - (median vec))) - (lisp-unit:assert-first-fp-equal - "0.185000000000d+01" - (letm ((vec (vector-double #(-18.0d0 -12.0d0 -3.21d0 0.5d0 1.0d0 2.7d0 12.8d0)))) - (quantile vec 0.75d0)))) +;;; Examples and unit test + +#| +(make-tests median-percentile + (letm ((vec (vector-double #(-3.21d0 1.0d0 12.8d0)))) + (median vec)) + (letm ((vec (vector-double #(-18.0d0 -12.0d0 -3.21d0 0.5d0 1.0d0 2.7d0 12.8d0)))) + (quantile vec 0.75d0))) +|# + +(LISP-UNIT:DEFINE-TEST MEDIAN-PERCENTILE + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.0d0) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(-3.21d0 1.0d0 12.8d0)))) + (MEDIAN VEC)))) + (LISP-UNIT::ASSERT-NUMERICAL-EQUAL + (LIST 1.85d0) + (MULTIPLE-VALUE-LIST + (LETM ((VEC (VECTOR-DOUBLE #(-18.0d0 -12.0d0 -3.21d0 0.5d0 1.0d0 2.7d0 12.8d0)))) + (QUANTILE VEC 0.75d0))))) + diff --git a/wavelet.lisp b/wavelet.lisp index 9a82e641bc21e90e66cc3879ae4b9deea89d9bc9..8369f9d509c21a1178c35d03a6fa0efe62697d3b 100644 --- a/wavelet.lisp +++ b/wavelet.lisp @@ -1,6 +1,6 @@ ;; Wavelet transforms. ;; Liam Healy, Mon Nov 26 2007 - 20:43 -;; Time-stamp: <2008-02-05 22:40:07EST wavelet.lisp> +;; Time-stamp: <2008-02-17 18:37:40EST wavelet.lisp> ;; $Id: $ (in-package :gsl) @@ -22,9 +22,9 @@ (defgo-s (wavelet type member) allocate-wavelet free-wavelet nil 2) -(defun-gsl allocate-wavelet (type member) +(defmfun allocate-wavelet (type member) "gsl_wavelet_alloc" - ((type :pointer) (member :size)) + ((type :pointer) (member size)) :c-return :pointer :export nil :index (letm wavelet) @@ -34,7 +34,7 @@ wavelet family. An error of :ENOMEM indicates either lack of memory or an unsupported member requested.") -(defun-gsl free-wavelet (wavelet) +(defmfun free-wavelet (wavelet) "gsl_wavelet_free" ((wavelet :pointer)) :c-return :void @@ -43,41 +43,41 @@ :documentation ; FDL "Free the wavelet object.") -(defvariable *daubechies-wavelet* "gsl_wavelet_daubechies" +(defmpar *daubechies-wavelet* "gsl_wavelet_daubechies" ;; FDL "The Daubechies wavelet family of maximum phase with member/2 vanishing moments. The implemented wavelets are member=4, 6,..., 20, with member even.") -(defvariable *daubechies-wavelet-centered* "gsl_wavelet_daubechies_centered" +(defmpar *daubechies-wavelet-centered* "gsl_wavelet_daubechies_centered" ;; FDL "The Daubechies wavelet family of maximum phase with member/2 vanishing moments. The implemented wavelets are member=4, 6,..., 20, with member even.") -(defvariable *haar-wavelet* "gsl_wavelet_haar" +(defmpar *haar-wavelet* "gsl_wavelet_haar" ;; FDL "The Haar wavelet. The only valid choice for member for the Haar wavelet is member=2.") -(defvariable *haar-wavelet-centered* "gsl_wavelet_haar_centered" +(defmpar *haar-wavelet-centered* "gsl_wavelet_haar_centered" ;; FDL "The Haar wavelet. The only valid choice for member for the Haar wavelet is member=2.") -(defvariable *bspline-wavelet* "gsl_wavelet_bspline" +(defmpar *bspline-wavelet* "gsl_wavelet_bspline" ;; FDL "The biorthogonal B-spline wavelet family of order (i,j). The implemented values of member = 100*i + j are 103, 105, 202, 204, 206, 208, 301, 303, 305 307, 309.") -(defvariable *bspline-wavelet-centered* "gsl_wavelet_bspline_centered" +(defmpar *bspline-wavelet-centered* "gsl_wavelet_bspline_centered" ;; FDL "The biorthogonal B-spline wavelet family of order (i,j). The implemented values of member = 100*i + j are 103, 105, 202, 204, 206, 208, 301, 303, 305 307, 309.") -(defun-gsl wavelet-name (wavelet) +(defmfun wavelet-name (wavelet) "gsl_wavelet_name" ((wavelet :pointer)) :c-return :string @@ -86,9 +86,9 @@ (defgo-s (wavelet-workspace size) allocate-wavelet-workspace free-wavelet-workspace) -(defun-gsl allocate-wavelet-workspace (size) +(defmfun allocate-wavelet-workspace (size) "gsl_wavelet_workspace_alloc" - ((size :size)) + ((size size)) :c-return :pointer :export nil :index (letm wavelet-workspace) @@ -100,7 +100,7 @@ size, since the transform operates on individual rows and columns.") -(defun-gsl free-wavelet-workspace (workspace) +(defmfun free-wavelet-workspace (workspace) "gsl_wavelet_workspace_free" ((workspace :pointer)) :c-return :void @@ -113,10 +113,10 @@ ;;;; Wavelet transforms 1D ;;;;**************************************************************************** -(defun-gsl wavelet-transform (wavelet data stride direction workspace) +(defmfun wavelet-transform (wavelet data stride direction workspace) "gsl_wavelet_transform" ((wavelet :pointer) ((gsl-array data) :pointer) - (stride :size) ((dim0 data) :size) ((forward-backward direction) :int) + (stride size) ((dim0 data) size) ((forward-backward direction) :int) (workspace :pointer)) :documentation ; FDL "Compute in-place forward and inverse discrete wavelet @@ -139,10 +139,10 @@ The backward transform inverts these coefficients to obtain the original data.") -(defun-gsl wavelet-transform-forward (wavelet data stride workspace) +(defmfun wavelet-transform-forward (wavelet data stride workspace) "gsl_wavelet_transform_forward" ((wavelet :pointer) ((gsl-array data) :pointer) - (stride :size) ((dim0 data) :size) (workspace :pointer)) + (stride size) ((dim0 data) size) (workspace :pointer)) :documentation ; FDL "Compute in-place forward and inverse discrete wavelet transforms on the array data. The length of the transform @@ -161,10 +161,10 @@ The backward transform inverts these coefficients to obtain the original data.") -(defun-gsl wavelet-transform-inverse (wavelet data stride workspace) +(defmfun wavelet-transform-inverse (wavelet data stride workspace) "gsl_wavelet_transform_inverse" ((wavelet :pointer) ((gsl-array data) :pointer) - (stride :size) ((dim0 data) :size) (workspace :pointer)) + (stride size) ((dim0 data) size) (workspace :pointer)) :documentation ; FDL "Compute in-place inverse discrete wavelet transforms on the array data. The length of the transform @@ -187,16 +187,16 @@ ;;;; Wavelet transforms 2D ;;;;**************************************************************************** -(defun-gsl wavelet-2d-transform (wavelet data tda direction workspace) +(defmfun wavelet-2d-transform (wavelet data tda direction workspace) "gsl_wavelet2d_transform" ((wavelet :pointer) ((gsl-array data) :pointer) - (tda :size) ((dim0 data) :size) ((dim1 data) :size) + (tda size) ((dim0 data) size) ((dim1 data) size) ((forward-backward direction) :int) (workspace :pointer)) :documentation ; FDL "Compute in-place forward and inverse discrete wavelet transforms in standard and non-standard forms on the array data stored in row-major form with dimensions - and physical row length @var{tda}. The dimensions must + and physical row length tda. The dimensions must be equal (square matrix) and are restricted to powers of two. For the transform version of the function the argument direction can be either :forward or :backward. A @@ -207,88 +207,84 @@ with dimension a power of 2, or if insufficient workspace is provided.") -(defun-gsl wavelet-2d-transform-forward (wavelet data tda workspace) +(defmfun wavelet-2d-transform-forward (wavelet data tda workspace) "gsl_wavelet2d_transform_forward" ((wavelet :pointer) ((gsl-array data) :pointer) - (tda :size) ((dim0 data) :size) ((dim1 data) :size) + (tda size) ((dim0 data) size) ((dim1 data) size) (workspace :pointer)) - :documentation + :documentation ; FDL "Compute two-dimensional in-place forward and inverse discrete wavelet transforms in standard and non-standard forms on the - array @var{data} stored in row-major form with dimensions @var{size1} - and @var{size2} and physical row length @var{tda}. The dimensions must - be equal (square matrix) and are restricted to powers of two. For the - @code{transform} version of the function the argument @var{dir} can be - either @code{forward} (@math{+1}) or @code{backward} (@math{-1}). A - workspace @var{work} of the appropriate size must be provided. On exit, - the appropriate elements of the array @var{data} are replaced by their + array data stored in row-major form with dimensions size1 + and size2 and physical row length tda. The dimensions must + be equal (square matrix) and are restricted to powers of two. A + workspace of the appropriate size must be provided. On exit, + the appropriate elements of the array data are replaced by their two-dimensional wavelet transform. An error :EINVAL is signalled if the matrix is not square with dimension a power of 2, or if insufficient workspace is provided.") -(defun-gsl wavelet-2d-transform-inverse (wavelet data tda workspace) +(defmfun wavelet-2d-transform-inverse (wavelet data tda workspace) "gsl_wavelet2d_transform_inverse" ((wavelet :pointer) ((gsl-array data) :pointer) - (tda :size) ((dim0 data) :size) ((dim1 data) :size) + (tda size) ((dim0 data) size) ((dim1 data) size) (workspace :pointer)) :documentation ; FDL "Compute two-dimensional in-place forward and inverse discrete wavelet transforms in standard and non-standard forms on the array data stored in row-major form with dimensions size1 and size2 and physical row length tda. The dimensions must be equal (square matrix) - and are restricted to powers of two. For the transform version of the - function the argument direction can be either :forward or :backward. - A workspace of the appropriate size must be provided. On exit, the - appropriate elements of the array data are replaced by their - two-dimensional wavelet transform. An error :EINVAL is signalled if - the matrix is not square with dimension a power of 2, or if - insufficient workspace is provided.") - -(defun-gsl wavelet-2d-transform-matrix (wavelet data direction workspace) + and are restricted to powers of two. A workspace of the appropriate + size must be provided. On exit, the appropriate elements of the array + data are replaced by their two-dimensional wavelet transform. An + error :EINVAL is signalled if the matrix is not square with dimension + a power of 2, or if insufficient workspace is provided.") + +(defmfun wavelet-2d-transform-matrix (wavelet data direction workspace) "gsl_wavelet2d_transform_matrix" ((wavelet :pointer) ((gsl-array data) :pointer) ((forward-backward direction) :int) (workspace :pointer)) :documentation ; FDL "Compute the two-dimensional in-place wavelet transform on a matrix.") -(defun-gsl wavelet-2d-transform-matrix-forward (wavelet data workspace) +(defmfun wavelet-2d-transform-matrix-forward (wavelet data workspace) "gsl_wavelet2d_transform_matrix_forward" ((wavelet :pointer) ((gsl-array data) :pointer) (workspace :pointer)) :documentation ; FDL "Compute the two-dimensional in-place wavelet transform on a matrix.") -(defun-gsl wavelet-2d-transform-matrix-inverse (wavelet data workspace) +(defmfun wavelet-2d-transform-matrix-inverse (wavelet data workspace) "gsl_wavelet2d_transform_matrix_inverse" ((wavelet :pointer) ((gsl-array data) :pointer) (workspace :pointer)) :documentation ; FDL "Compute the two-dimensional in-place wavelet transform on a matrix.") -(defun-gsl wavelet-2d-nonstandard-transform (wavelet data tda direction workspace) +(defmfun wavelet-2d-nonstandard-transform (wavelet data tda direction workspace) "gsl_wavelet2d_nstransform" ((wavelet :pointer) ((gsl-array data) :pointer) - (tda :size) ((dim0 data) :size) ((dim1 data) :size) (direction :int) + (tda size) ((dim0 data) size) ((dim1 data) size) (direction :int) (workspace :pointer)) :documentation ; FDL "Compute the two-dimensional wavelet transform in non-standard form.") -(defun-gsl wavelet-2d-nonstandard-transform-forward (wavelet data tda workspace) +(defmfun wavelet-2d-nonstandard-transform-forward (wavelet data tda workspace) "gsl_wavelet2d_nstransform_forward" ((wavelet :pointer) ((gsl-array data) :pointer) - (tda :size) ((dim0 data) :size) ((dim1 data) :size) + (tda size) ((dim0 data) size) ((dim1 data) size) (workspace :pointer)) :documentation ; FDL "Compute the two-dimensional wavelet transform in non-standard form.") -(defun-gsl wavelet-2d-nonstandard-transform-inverse (wavelet data tda workspace) +(defmfun wavelet-2d-nonstandard-transform-inverse (wavelet data tda workspace) "gsl_wavelet2d_nstransform_inverse" ((wavelet :pointer) ((gsl-array data) :pointer) - (tda :size) ((dim0 data) :size) ((dim1 data) :size) + (tda size) ((dim0 data) size) ((dim1 data) size) (workspace :pointer)) :documentation ; FDL "Compute the two-dimensional wavelet transform in non-standard form.") -(defun-gsl wavelet-2d-nonstandard-transform-matrix (wavelet data direction workspace) +(defmfun wavelet-2d-nonstandard-transform-matrix (wavelet data direction workspace) "gsl_wavelet2d_nstransform_matrix" ((wavelet :pointer) ((gsl-array data) :pointer) (direction :int) (workspace :pointer)) @@ -296,14 +292,14 @@ "Compute the non-standard form of the two-dimensional in-place wavelet transform on a matrix.") -(defun-gsl wavelet-2d-nonstandard-transform-matrix-forward (wavelet data workspace) +(defmfun wavelet-2d-nonstandard-transform-matrix-forward (wavelet data workspace) "gsl_wavelet2d_nstransform_matrix_forward" ((wavelet :pointer) ((gsl-array data) :pointer) (workspace :pointer)) :documentation ; FDL "Compute the non-standard form of the two-dimensional in-place wavelet transform on a matrix.") -(defun-gsl wavelet-2d-nonstandard-transform-matrix-inverse (wavelet data workspace) +(defmfun wavelet-2d-nonstandard-transform-matrix-inverse (wavelet data workspace) "gsl_wavelet2d_nstransform_matrix_inverse" ((wavelet :pointer) ((gsl-array data) :pointer) (workspace :pointer)) :documentation ; FDL