Commit b40b3238 authored by liam's avatar liam
Browse files

Eliminate the last of with-data; minor bug fixes.


git-svn-id: svn+ssh://pop/opt/space/mathematics/gsl/trunk@3284 a3d8a0fb-c1db-0310-ace7-a616afeb9e30
parent 3467a214
;******************************************************** ;; Combinations
; file: combination.lisp ;; Liam Healy, Sun Mar 26 2006 - 11:51
; description: Combinations ;; Time-stamp: <2008-02-04 19:25:57EST combination.lisp>
; date: Sun Mar 26 2006 - 11:51 ;; $Id: $
; author: Liam M. Healy
; modified: Mon Jun 5 2006 - 11:19
;********************************************************
;;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -34,7 +30,8 @@ ...@@ -34,7 +30,8 @@
(((pointer combination) :pointer) ((first indices) :size)) (((pointer combination) :pointer) ((first indices) :size))
:type :method :type :method
:c-return :size :c-return :size
:documentation "The ith element of the combination.") :documentation ; FDL
"The ith element of the combination.")
(defmethod data ((object gsl-combination) &optional sequence) (defmethod data ((object gsl-combination) &optional sequence)
(let ((seq (or sequence (let ((seq (or sequence
...@@ -53,18 +50,18 @@ ...@@ -53,18 +50,18 @@
(((pointer combination) gsl-combination-c)) (((pointer combination) gsl-combination-c))
:c-return :void :c-return :void
:invalidate (combination) :invalidate (combination)
:documentation :documentation ; FDL
"Initialize the combination @var{c} to the lexicographically "Initialize the combination c to the lexicographically
first combination, i.e. @math{(0,1,2,@dots{},k-1)}.") first combination, i.e. (0,1,2,...,k-1).")
(defun-gsl init-last (combination) (defun-gsl init-last (combination)
"gsl_combination_init_last" "gsl_combination_init_last"
(((pointer combination) gsl-combination-c)) (((pointer combination) gsl-combination-c))
:c-return :void :c-return :void
:invalidate (combination) :invalidate (combination)
:documentation :documentation ; FDL
"Initialize the combination @var{c} to the lexicographically "Initialize the combination c to the lexicographically
last combination, i.e. @math{(n-k,n-k+1,@dots{},n-1)}.") last combination, i.e. (n-k,n-k+1,...,n-1).")
(defun-gsl copy (destination source) (defun-gsl copy (destination source)
"gsl_combination_memcpy" "gsl_combination_memcpy"
...@@ -72,9 +69,9 @@ ...@@ -72,9 +69,9 @@
((pointer source) gsl-combination-c)) ((pointer source) gsl-combination-c))
:type :method :type :method
:invalidate (destination) :invalidate (destination)
:documentation :documentation ; FDL
"Copy the elements of the combination @var{src} into the "Copy the elements of the combination source into the
combination @var{dest}. The two combinations must have the same size.") combination destination. The two combinations must have the same size.")
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Combination properties ;;;; Combination properties
...@@ -84,15 +81,15 @@ ...@@ -84,15 +81,15 @@
"gsl_combination_n" "gsl_combination_n"
(((pointer c) gsl-combination-c)) (((pointer c) gsl-combination-c))
:c-return :size :c-return :size
:documentation :documentation ; FDL
"The range (@math{n}) of the combination @var{c}.") "The range (n) of the combination c.")
(defun-gsl combination-size (c) (defun-gsl combination-size (c)
"gsl_combination_k" "gsl_combination_k"
(((pointer c) gsl-combination-c)) (((pointer c) gsl-combination-c))
:c-return :size :c-return :size
:documentation :documentation ; FDL
"The number of elements (@math{k}) in the combination @var{c}.") "The number of elements (k) in the combination c.")
#| #|
;;; Unnecessary, gsl-array serves this function. ;;; Unnecessary, gsl-array serves this function.
...@@ -100,8 +97,8 @@ ...@@ -100,8 +97,8 @@
"gsl_combination_data" "gsl_combination_data"
(((pointer c) gsl-combination-c)) (((pointer c) gsl-combination-c))
:c-return :pointer :c-return :pointer
:documentation :documentation ; FDL
"A pointer to the array of elements in the combination @var{p}.") "A pointer to the array of elements in the combination.")
|# |#
(defun-gsl data-valid ((combination gsl-combination)) (defun-gsl data-valid ((combination gsl-combination))
...@@ -109,9 +106,9 @@ ...@@ -109,9 +106,9 @@
(((pointer combination) :pointer)) (((pointer combination) :pointer))
:type :method :type :method
:c-return :boolean :c-return :boolean
:documentation :documentation ; FDL
"Check that the combination @var{c} is valid. The @var{k} "Check that the combination is valid. The k
elements should lie in the range 0 to @math{@var{n}-1}, with each elements should lie in the range 0 to n-1, with each
value occurring once at most and in increasing order.") value occurring once at most and in increasing order.")
;;;;**************************************************************************** ;;;;****************************************************************************
...@@ -122,11 +119,11 @@ ...@@ -122,11 +119,11 @@
"gsl_combination_next" (((pointer c) gsl-combination-c)) "gsl_combination_next" (((pointer c) gsl-combination-c))
:c-return :success-failure :c-return :success-failure
:invalidate (c) :invalidate (c)
:documentation :documentation ; FDL
"Advance the combination @var{c} to the next combination "Advance the combination c to the next combination
in lexicographic order and return T and c. If no further in lexicographic order and return T and c. If no further
combinations are available it return NIL and c with combinations are available it return NIL and c with
@var{c} unmodified. Starting with the first combination and c unmodified. Starting with the first combination and
repeatedly applying this function will iterate through all possible repeatedly applying this function will iterate through all possible
combinations of a given order.") combinations of a given order.")
...@@ -135,42 +132,43 @@ ...@@ -135,42 +132,43 @@
(((pointer c) gsl-combination-c)) (((pointer c) gsl-combination-c))
:c-return :success-failure :c-return :success-failure
:invalidate (c) :invalidate (c)
:documentation :documentation ; FDL
"Step backwards from the combination @var{c} to the "Step backwards from the combination c to the
previous combination in lexicographic order, returning previous combination in lexicographic order, returning
T and c. If no previous combination is available it returns T and c. If no previous combination is available it returns
NIL and c with @var{c} unmodified.") NIL and c with c unmodified.")
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Examples and unit test ;;;; Examples and unit test
;;;;**************************************************************************** ;;;;****************************************************************************
(defparameter *comb-1* (make-data 'combination t 4 2))
(lisp-unit:define-test combination (lisp-unit:define-test combination
(lisp-unit:assert-eql ; combination-range (lisp-unit:assert-eql ; combination-range
4 4
(combination-range *comb-1*)) (letm ((comb (combination 4 2 t)))
(combination-range comb)))
(lisp-unit:assert-eql ; combination-size (lisp-unit:assert-eql ; combination-size
2 2
(combination-size *comb-1*)) (letm ((comb (combination 4 2 t)))
(combination-size comb)))
(lisp-unit:assert-equal ; init-first, combination-next (lisp-unit:assert-equal ; init-first, combination-next
'((0 1) (0 2) (0 3) (1 2) (1 3) (2 3)) '((0 1) (0 2) (0 3) (1 2) (1 3) (2 3))
(progn (letm ((comb (combination 4 2 t)))
(init-first *comb-1*) (init-first comb)
(loop collect (data *comb-1*) (loop collect (data comb)
while (combination-next *comb-1*)))) while (combination-next comb))))
(lisp-unit:assert-equal ; init-last, combination-previous (lisp-unit:assert-equal ; init-last, combination-previous
'((2 3) (1 3) (1 2) (0 3) (0 2) (0 1)) '((2 3) (1 3) (1 2) (0 3) (0 2) (0 1))
(progn (letm ((comb (combination 4 2 t)))
(init-last *comb-1*) (init-last comb)
(loop collect (data *comb-1*) (loop collect (data comb)
while (combination-previous *comb-1*)))) while (combination-previous comb))))
(lisp-unit:assert-equal ; with-data, combination-next (lisp-unit:assert-equal ; combination-next
'(NIL (0) (1) (2) (3) (0 1) (0 2) (0 3) (1 2) (1 3) (2 3) '(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)) (0 1 2) (0 1 3) (0 2 3) (1 2 3) (0 1 2 3))
(loop for i from 0 to 4 (loop for i from 0 to 4
append append
(with-data (comb combination (4 i) t) (letm ((comb (combination 4 i t)))
(init-first comb)
(loop collect (data comb) (loop collect (data comb)
while (combination-next comb)))))) while (combination-next comb))))))
;; Using GSL storage. ;; Using GSL storage.
;; Liam Healy, Sun Mar 26 2006 - 16:32 ;; Liam Healy, Sun Mar 26 2006 - 16:32
;; Time-stamp: <2008-02-03 23:34:26EST data.lisp> ;; Time-stamp: <2008-02-05 22:32:15EST data.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -155,10 +155,11 @@ ...@@ -155,10 +155,11 @@
collect `((nth ,i (storage-size object)) :size))) collect `((nth ,i (storage-size object)) :size)))
(object-name (make-symbol-from-strings *gsl-prefix* cl-symbol))) (object-name (make-symbol-from-strings *gsl-prefix* cl-symbol)))
`(progn `(progn
(data-go ,cl-symbol ,(eq superclass 'gsl-matrix))
(defclass ,object-name (,superclass) (defclass ,object-name (,superclass)
((cl-base-type :initform ',cl-base-type :reader cl-base-type ((cl-base-type :initform ',cl-base-type :reader cl-base-type
:allocation :class))) :allocation :class)))
(data-go ,cl-symbol
,(or (member superclass '(gsl-matrix)) (member object-name '(gsl-combination))))
(defun-gsl alloc ((object ,object-name)) (defun-gsl alloc ((object ,object-name))
,(gsl-name "alloc") ,cargs ,(gsl-name "alloc") ,cargs
:type :method :type :method
...@@ -234,7 +235,7 @@ ...@@ -234,7 +235,7 @@
;;;; Making data objects and initializing storage ;;;; Making data objects and initializing storage
;;;;**************************************************************************** ;;;;****************************************************************************
(export '(make-data with-data)) (export '(make-data))
(defgeneric alloc (object) (defgeneric alloc (object)
(:documentation "Allocate GSL data; used internally.")) (:documentation "Allocate GSL data; used internally."))
...@@ -258,39 +259,6 @@ ...@@ -258,39 +259,6 @@
(if zero (calloc obj) (alloc obj)) (if zero (calloc obj) (alloc obj))
obj)) obj))
(defmacro with-data ((symbol type size &optional zero) &body body)
"Allocate GSL data, bind to pointer,
and then deallocated it when done. If zero is T, zero the
contents when allocating."
`(let ((,symbol
(make-data ',type ,zero ,@(if (listp size) size (list size)))))
(unwind-protect
(progn ,@body)
(free ,symbol))))
#|
(defun make-data (type zero size)
"Make the GSL data object, including the allocation of space.
The user is responsible for calling #'free to free the foreign
memory when done."
(let ((obj
(make-instance
(make-symbol-from-strings *gsl-prefix* type)
:storage-size (if (listp size) size (list size)))))
(if zero (calloc obj) (alloc obj))
obj))
(defmacro with-data ((symbol type size &optional zero) &body body)
"Allocate GSL data, bind to pointer,
and then deallocated it when done. If zero is T, zero the
contents when allocating."
`(let ((,symbol
(make-data ',type ,zero ,size)))
(unwind-protect
(progn ,@body)
(free ,symbol))))
|#
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Getting values into CL ;;;; Getting values into CL
;;;;**************************************************************************** ;;;;****************************************************************************
......
;; Matrices ;; Matrices
;; Liam Healy, Sun Mar 26 2006 - 11:51 ;; Liam Healy, Sun Mar 26 2006 - 11:51
;; Time-stamp: <2008-02-02 23:44:57EST matrix.lisp> ;; Time-stamp: <2008-02-05 22:38:36EST matrix.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -73,7 +73,8 @@ ...@@ -73,7 +73,8 @@
((first indices) :size) ((first indices) :size)
((second indices) :size)) ((second indices) :size))
:c-return :c-base-type :c-return :c-base-type
:documentation "The (i,j)-th element of the matrix.") ;FDL :documentation ; FDL
"The (i,j)-th element of the matrix.")
(defun-gsl mref (pointer index0 index1) (defun-gsl mref (pointer index0 index1)
"gsl_matrix_get" "gsl_matrix_get"
...@@ -153,9 +154,9 @@ ...@@ -153,9 +154,9 @@
"gsl_matrix_set_identity" (((pointer matrix) gsl-matrix-c)) "gsl_matrix_set_identity" (((pointer matrix) gsl-matrix-c))
:c-return :void :c-return :void
:documentation ; FDL :documentation ; FDL
"Set the elements of the matrix @var{m} to the "Set the elements of the matrix m to the
corresponding elements of the identity matrix, @math{m(i,j) = corresponding elements of the identity matrix, m(i,j) =
\delta(i,j)}, i.e. a unit diagonal with all off-diagonal elements zero. \delta(i,j), i.e. a unit diagonal with all off-diagonal elements zero.
This applies to both square and rectangular matrices.") This applies to both square and rectangular matrices.")
;;;;**************************************************************************** ;;;;****************************************************************************
...@@ -574,124 +575,99 @@ ...@@ -574,124 +575,99 @@
;;;; Examples and unit test ;;;; Examples and unit test
;;;;**************************************************************************** ;;;;****************************************************************************
(defparameter *intmat-1* (make-data 'matrix-fixnum nil 2 2))
(defparameter *intmat-2* (make-data 'matrix-fixnum nil 2 2))
(defparameter *intmatvec* (make-data 'vector-fixnum nil 2))
(lisp-unit:define-test matrix-fixnum (lisp-unit:define-test matrix-fixnum
(lisp-unit:assert-eql ;(setf gsl-aref), gsl-aref (lisp-unit:assert-eql ;(setf gsl-aref), gsl-aref
77 77
(progn (letm ((intmat (matrix-fixnum 2 2)))
(setf (gsl-aref *intmat-1* 0 1) 77) (setf (gsl-aref intmat 0 1) 77)
(gsl-aref *intmat-1* 0 1))) (gsl-aref intmat 0 1)))
(lisp-unit:assert-equalp ;(setf data) (lisp-unit:assert-equalp ;(setf data)
#2A((4 6) (8 2)) #2A((4 6) (8 2))
(progn (setf (data *intmat-1*) #2A((4 6) (8 2))) (data *intmat-1*))) (letm ((intmat (matrix-fixnum 2 2)))
(setf (data intmat) #2A((4 6) (8 2)))
(data intmat)))
(lisp-unit:assert-equalp ;set-zero (lisp-unit:assert-equalp ;set-zero
#2A((0 0) (0 0)) #2A((0 0) (0 0))
(progn (set-zero *intmat-1*) (data *intmat-1*))) (letm ((intmat (matrix-fixnum 2 2)))
(set-zero intmat)
(data intmat)))
(lisp-unit:assert-equalp ;set-all (lisp-unit:assert-equalp ;set-all
#2A((44 44)(44 44)) #2A((44 44)(44 44))
(progn (set-all *intmat-1* 44) (data *intmat-1*))) (letm ((intmat (matrix-fixnum 2 2)))
(lisp-unit:assert-equalp ;set-basis (set-all intmat 44)
(data intmat)))
(lisp-unit:assert-equalp ;set-identity
#2A((1 0)(0 1)) #2A((1 0)(0 1))
(progn (set-identity *intmat-1*) (data *intmat-1*))) (letm ((intmat (matrix-fixnum 2 2)))
(set-identity intmat)
(data intmat)))
(lisp-unit:assert-equalp ;row (lisp-unit:assert-equalp ;row
#(4 6) #(4 6)
(progn (letm ((intmat (matrix-fixnum #2A((4 6) (8 2))))
(setf (data *intmat-1*) #2A((4 6) (8 2))) (vect (vector-fixnum 2)))
(row *intmatvec* *intmat-1* 0) (row vect intmat 0)
(data *intmatvec*))) (data vect)))
(lisp-unit:assert-equalp ;column (lisp-unit:assert-equalp ;column
#(6 2) #(6 2)
(progn (letm ((intmat (matrix-fixnum #2A((4 6) (8 2))))
(setf (data *intmat-1*) #2A((4 6) (8 2))) (vect (vector-fixnum 2)))
(column *intmatvec* *intmat-1* 1) (column vect intmat 1)
(data *intmatvec*))) (data vect)))
(lisp-unit:assert-eql ;gsl-min (lisp-unit:assert-eql ;gsl-min
-12 -12
(progn (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3)))))
(setf (data *intmat-1*) #2A((-1 -12) (8 3))) (gsl-min intmat)))
(gsl-min *intmat-1*)))
(lisp-unit:assert-eql ;gsl-max (lisp-unit:assert-eql ;gsl-max
8 8
(progn (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3)))))
(setf (data *intmat-1*) #2A((-1 -12) (8 3))) (gsl-max intmat)))
(gsl-max *intmat-1*)))
(lisp-unit:assert-equal ;gsl-minmax (lisp-unit:assert-equal ;gsl-minmax
'(-12 8) '(-12 8)
(progn (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3)))))
(setf (data *intmat-1*) #2A((-1 -12) (8 3))) (multiple-value-list (gsl-minmax intmat))))
(multiple-value-list (gsl-minmax *intmat-1*))))
(lisp-unit:assert-equal ;gsl-min-index (lisp-unit:assert-equal ;gsl-min-index
'(0 1) '(0 1)
(progn (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3)))))
(setf (data *intmat-1*) #2A((-1 -12) (8 3))) (gsl-min-index intmat)))
(gsl-min-index *intmat-1*)))
(lisp-unit:assert-equal ;gsl-max-index (lisp-unit:assert-equal ;gsl-max-index
'(1 0) '(1 0)
(progn (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3)))))
(setf (data *intmat-1*) #2A((-1 -12) (8 3))) (gsl-max-index intmat)))
(gsl-max-index *intmat-1*)))
(lisp-unit:assert-equal ;gsl-minmax-index (lisp-unit:assert-equal ;gsl-minmax-index
'((0 1) (1 0)) '((0 1) (1 0))
(progn (letm ((intmat (matrix-fixnum #2A((-1 -12) (8 3)))))
(setf (data *intmat-1*) #2A((-1 -12) (8 3))) (multiple-value-list (gsl-minmax-index intmat))))
(multiple-value-list (gsl-minmax-index *intmat-1*))))
(lisp-unit:assert-equalp ;copy (lisp-unit:assert-equalp ;copy
#2A((1 2)(3 4)) #2A((1 2)(3 4))
(progn (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))
(setf (data *intmat-1*) #2A((1 2)(3 4))) (intmat2 (matrix-fixnum 2 2)))
(copy *intmat-2* *intmat-1*) (data *intmat-2*))) (copy intmat2 intmat1)
(data intmat2)))
(lisp-unit:assert-equalp ;swap (lisp-unit:assert-equalp ;swap
#2A((5 6) (7 8)) #2A((5 6) (7 8))
(progn (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4))))
(setf (data *intmat-1*) #2A((1 2) (3 4)) (intmat2 (matrix-fixnum #2A((5 6) (7 8)))))
(data *intmat-2*) #2A((5 6) (7 8))) (swap intmat1 intmat2)
(swap *intmat-1* *intmat-2*) (data intmat1)))
(data *intmat-1*)))
(lisp-unit:assert-equalp ;swap-rows (lisp-unit:assert-equalp ;swap-rows
#2A((3 4) (1 2)) #2A((3 4) (1 2))
(progn (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))))
(setf (data *intmat-1*) #2A((1 2) (3 4))) (swap-rows intmat1 0 1)
(swap-rows *intmat-1* 0 1) (data intmat1)))
(data *intmat-1*)))
(lisp-unit:assert-equalp ;swap-columns (lisp-unit:assert-equalp ;swap-columns
#2A((2 1) (4 3)) #2A((2 1) (4 3))
(progn (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))))
(setf (data *intmat-1*) #2A((1 2) (3 4))) (swap-columns intmat1 0 1)
(swap-columns *intmat-1* 0 1) (data intmat1)))
(data *intmat-1*)))
(lisp-unit:assert-equalp ;swap-rowcol (lisp-unit:assert-equalp ;swap-rowcol
#2A((2 4) (3 1)) #2A((2 4) (3 1))
(progn (letm ((intmat1 (matrix-fixnum #2A((1 2)(3 4)))))
(setf (data *intmat-1*) #2A((1 2) (3 4))) (swap-rowcol intmat1 0 1)
(swap-rowcol *intmat-1* 0 1) (data intmat1))))
(data *intmat-1*))))
;;;;****************************************************************************
;;;; Examples
;;;;****************************************************************************
#|
(with-data (mat matrix (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)))))
(loop for i from 0 below 10
do
(loop for j from 0 below 3 do (print (gsl-aref mat i j)))))
(with-data (mat matrix (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))
#2A((0.23d0 1.23d0 2.23d0) (lisp-unit:define-test matrix-double
(lisp-unit:assert-equalp
#2A((0.23d0 1.23d0 2.23d0)
(100.23d0 101.23d0 102.23d0) (100.23d0 101.23d0 102.23d0)
(200.23d0 201.23d0 202.23d0) (200.23d0 201.23d0 202.23d0)
(300.23d0 301.23d0 302.23d0) (300.23d0 301.23d0 302.23d0)
...@@ -701,18 +677,20 @@ ...@@ -701,18 +677,20 @@
(700.23d0 701.23d0 702.23d0) (700.23d0 701.23d0 702.23d0)
(800.23d0 801.23d0 802.23d0) (800.23d0 801.23d0 802.23d0)
(900.23d0 901.23d0 902.23d0)) (900.23d0 901.23d0 902.23d0))
(letm ((mat (matrix-double 10 3)))
(with-data (mat matrix (2 2)) (loop for i from 0 below 10
(setf (data mat) #2A((1.0d0 2.0d0) (3.0d0 4.0d0))) do
(with-data (ans matrix (2 2)) (loop for j from 0 below 3
(matrix-copy ans mat) do (setf (gsl-aref mat i j) (+ 0.23d0 j (* 100 i)))))
(data ans))) (data mat)))
;;; #2A((1.0d0 2.0d0) (3.0d0 4.0d0)) (lisp-unit:assert-equalp
#2A((1.0d0 2.0d0) (3.0d0 4.0d0))
(with-data (mat matrix (2 2)) (letm ((mat (matrix-double #2A((1.0d0 2.0d0) (3.0d0 4.0d0))))
(setf (data mat) #2A((1.0d0 2.0d0) (3.0d0 4.0d0))) (ans (matrix-double 2 2)))
(matrix* mat mat) (copy ans mat)
(data mat))) (data ans))
;;; #2A((1.0d0 4.0d0) (9.0d0 16.0d0)) (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)))))
This diff is collapsed.
;; Definition of GSLL system ;; Definition of GSLL system