Commit f8adee82 authored by Liam Healy's avatar Liam Healy

#'array-default makes both vectors and matrices; pool numbers with correct type

For testing, both vectors and matrices can be made with
#'array-default, replacing #'vector-default.  The numbers in
*double-float-pool* in are now double floats (with d0), and the
#'make-list-from-pool coerces to the right type.  In both.lisp,
#'set-value and #'get-value are for vectors only, not both, because
matrices require an extra index argument.  Since these functions are
for debugging only as the comment says, I'm writing equivalent matrix
functions, and I'm not doing tests for them.
parent 8f43fe94
;; Tests of array functions
;; Liam Healy 2008-10-20 22:41:48EDT array-tests.lisp
;; Time-stamp: <2008-11-02 13:18:30EST array-tests.lisp>
;; Time-stamp: <2008-11-02 18:07:27EST array-tests.lisp>
;; $Id: $
;;; Generate each file with #'write-test-to-file, e.g.
;;; (write-test-to-file 'matrix-set-zero "../test/")
(in-package :gsl)
;;; Some of these don't work for complex because:
;;; Cannot pass complex scalars to and from GSL functions (structs passed by value).
(generate-all-array-tests
set-all-m+ :no-complex
(letm ((v1 (vector-default 3 t))
(v2 (vector-default 3)))
(set-all v1 (scalar-default 2))
vector-set-all-m+ :no-complex
(letm ((v1 (array-default 3 t))
(v2 (array-default 3)))
(set-all v1 (scalar-default))
(cl-array (m+ v1 v2))))
(generate-all-array-tests
set-zero t
(letm ((v1 (vector-default 3)))
matrix-set-all-m+ :no-complex
(letm ((m1 (array-default '(3 3) t))
(m2 (array-default '(3 3))))
(set-all m1 (scalar-default))
(cl-array (m+ m1 m2))))
(generate-all-array-tests
vector-set-zero t
(letm ((v1 (array-default 3)))
(set-zero v1)
(cl-array v1)))
(generate-all-array-tests
array-copy t
(letm ((v1 (vector-default 3))
(v2 (vector-default 3 t)))
matrix-set-zero t
(letm ((m1 (array-default '(3 3))))
(set-zero m1)
(cl-array m1)))
(generate-all-array-tests
vector-copy t
(letm ((v1 (array-default 3))
(v2 (array-default 3 t)))
(copy v2 v1)
(cl-array v2)))
(generate-all-array-tests
array-swap t
(letm ((v1 (vector-default 3))
(v2 (vector-default 3)))
matrix-copy t
(letm ((m1 (array-default '(3 3)))
(m2 (array-default '(3 3) t)))
(copy m2 m1)
(cl-array m2)))
(generate-all-array-tests
vector-swap t
(letm ((v1 (array-default 3))
(v2 (array-default 3)))
(swap v2 v1)
(concatenate 'vector (cl-array v1) (cl-array v2))))
(list (cl-array v1) (cl-array v2))))
(generate-all-array-tests
matrix-swap t
(letm ((m1 (array-default '(3 3)))
(m2 (array-default '(3 3))))
(swap m2 m1)
(list (cl-array m1) (cl-array m2))))
;; Functions for both vectors and matrices.
;; Liam Healy 2008-04-26 20:48:44EDT both.lisp
;; Time-stamp: <2008-08-28 21:41:15EDT both.lisp>
;; Time-stamp: <2008-11-02 18:00:49EST both.lisp>
;; $Id$
(in-package :gsl)
......@@ -76,7 +76,8 @@
;;; These functions are here as debugging tools only; they do not insure
;;; coherency between the C and CL sides and therefore should not be
;;; used in production.
(defmfun set-value ((object both) index value)
;;; For matrix functions, there should be another index argument
(defmfun set-value ((object vector) index value)
("gsl_" :category :type "_set")
(((mpointer object) :pointer) (index sizet) (value :element-c-type))
:definition :generic
......@@ -87,7 +88,7 @@
:documentation
"Set single element to the value. For debugging only; do not use.")
(defmfun get-value ((object both) index)
(defmfun get-value ((object vector) index)
("gsl_" :category :type "_get")
(((mpointer object) :pointer) (index sizet))
:definition :generic
......
;; Data using ffa
;; Liam Healy 2008-04-06 21:23:41EDT data-ffa.lisp
;; Time-stamp: <2008-11-02 12:50:17EST data.lisp>
;; Time-stamp: <2008-11-02 17:38:20EST data.lisp>
;; $Id$
(in-package :gsl)
......@@ -164,7 +164,8 @@
(typep (if matrixp (caar cont) (first cont)) 'real))))
(when complex-with-real-init
(assert
(evenp (length cont)) (cont)
(evenp (length (if matrixp (first cont) cont)))
(cont)
"Complex arrays require initial contents of even length."))
(make-array*
(if matrixp
......
;; Make tests and examples
;; Liam Healy 2008-09-07 21:00:48EDT generate-tests.lisp
;; Time-stamp: <2008-11-02 10:56:53EST generate-tests.lisp>
;; Time-stamp: <2008-11-02 17:50:39EST generate-tests.lisp>
;; $Id: $
(in-package :gsl)
......@@ -108,11 +108,12 @@
;;; (loop repeat 50 collect (coerce (- (/ (random 10000) 100) 50) 'double-float))
(defparameter *double-float-pool*
'(-37.61 -48.84 -48.86 29.32 2.43 10.83 20.93 -15.27 11.26 -9.16 38.5 25.53
-25.72 -13.99 -10.95 -0.71 36.53 -24.44 -21.79 -17.01 11.59 -37.64 -20.97
-44.42 42.09 -46.72 13.32 -37.18 25.98 -21.06 40.78 21.35 43.15 9.23
31.73 33.38 -48.95 -42.69 22.95 -47.97 37.37 3.01 -3.53 -38.5 -12.8 42.14
-6.44 29.57 -34.1 -11.98)
'(-34.5d0 8.24d0 3.29d0 -8.93d0 34.12d0 -6.15d0 49.27d0 -13.49d0 32.5d0
42.73d0 -17.24d0 43.31d0 -16.12d0 -8.25d0 21.44d0 -49.08d0 -39.66d0
-49.46d0 19.68d0 -5.55d0 -8.82d0 25.37d0 -30.58d0 31.67d0 29.36d0
-33.24d0 -27.03d0 -41.67d0 42.0d0 -20.81d0 37.93d0 -30.02d0 11.41d0
22.0d0 33.43d0 42.97d0 -36.7d0 -9.69d0 10.18d0 -47.96d0 37.42d0 -42.55d0
40.77d0 18.19d0 -43.66d0 -9.3d0 -29.79d0 -38.88d0 -45.6d0 -31.91d0)
"A sequence of random double floats ranging between -100.0d0 and +100.0d0.")
;;; (loop repeat 50 collect (random 256))
......@@ -141,34 +142,53 @@
"Make a list for :initial-contents of the specified element type and
length using the pool data for the type and starting at the
specified point in the pool."
(subseq
(cond ((subtypep type 'unsigned-byte) *unsigned-byte-pool*)
((subtypep type 'signed-byte) *signed-byte-pool*)
((subtypep type 'float) *double-float-pool*)
((subtypep type 'complex) *double-float-pool*))
starting
(+ starting (if (subtypep type 'complex) (* 2 length) length))))
(mapcar
(lambda (num) (coerce num (component-float-type type)))
(subseq
(cond ((subtypep type 'unsigned-byte) *unsigned-byte-pool*)
((subtypep type 'signed-byte) *signed-byte-pool*)
((subtypep type 'float) *double-float-pool*)
((subtypep type 'complex) *double-float-pool*))
starting
(+ starting (if (subtypep type 'complex) (* 2 length) length)))))
;;;;****************************************************************************
;;;; Generate forms for all array types
;;;;****************************************************************************
(defun vector-default (spec &optional no-init sync-on-exit)
(defun array-default (spec &optional no-init sync-on-exit)
"Make an array of the current type and intialize from the pool."
(declare (special default-element-type starting-element))
(let ((matrixp (listp spec)))
`(,(data-class-name (if matrixp 'matrix 'vector) default-element-type)
,(if no-init
`',spec ; no initial values, just dimension
(cons ; macro to make initial-contents
'a
(if matrixp
(loop repeat (first spec)
collect
(make-list-from-pool
default-element-type (second spec) starting-element)
do
(incf starting-element (second spec)))
(prog1
(make-list-from-pool
default-element-type spec starting-element)
(incf starting-element spec)))))
,sync-on-exit)))
(defun scalar-default ()
"Make a scalar of the current type from the pool."
(declare (special default-element-type starting-element))
(prog1
`(,(data-class-name 'vector default-element-type)
,(if no-init
spec ; no initial values, just dimension
(cons ; macro to make initial-contents
'a
(make-list-from-pool default-element-type spec starting-element)))
,sync-on-exit)
(incf starting-element spec)))
(defun scalar-default (spec)
(declare (special default-element-type))
(coerce spec default-element-type))
(if (subtypep default-element-type 'complex)
(apply #'complex
(make-list-from-pool default-element-type 1 starting-element))
(first
(make-list-from-pool default-element-type 1 starting-element)))
(incf starting-element)))
(defun stupid-code-walk-eval-some (form eval-list)
"Walk the form and if the first symbol of the list is a member of
......@@ -189,7 +209,7 @@
(collect
(stupid-code-walk-eval-some
test
'(vector-default scalar-default)))))
'(array-default vector-default scalar-default)))))
(defmacro generate-all-array-tests (name element-types test)
`(save-test ,name ,@(generate-all-array-tests-body element-types test)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment