Merge branch 'fare-master'
[cl-tuples.git] / tuples-test.lisp
blob37efa0be4e72a076c441e23c7da1ad7bb17fc353
2 (defpackage :cl-tuples-test
3 (:use :cl-tuples :cl)
4 (:export "test-cl-tuples"))
6 (in-package :cl-tuples-test)
8 (eval-when (:compile-toplevel :load-toplevel :execute)
9 (pushnew :cl-tuples-debug *features*))
11 (file-enable-tuples-syntax)
13 (defvar *test-name* nil)
15 (defmacro deftest (name parameters &body body)
16 "Define a test function. Within a test function we can call
17 other test functions or use 'check' to run individual test
18 cases."
19 `(defun ,name ,parameters
20 (let ((*test-name* (append *test-name* (list ',name))))
21 ,@body)))
23 (defmacro check (&body forms)
24 "Run each expression in 'forms' as a test case."
25 `(combine-results
26 ,@(loop for f in forms collect `(report-result ,f ',f))))
28 (defmacro combine-results (&body forms)
29 "Combine the results (as booleans) of evaluating 'forms' in order."
30 (cl-tuples::with-gensyms (result)
31 `(let ((,result t))
32 ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
33 ,result)))
35 (defun report-result (result form)
36 "Report the results of a single test case. Called by 'check'."
37 (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
38 result)
40 (defmacro with-test (test-sym test &rest forms)
41 (cl-tuples::with-gensyms (result)
42 `(progn
43 ,@forms
44 (let
45 ((,result ,test))
46 (assert ,result)
47 (setf ,test-sym (and ,test-sym ,result))))))
49 (defmacro always-pass (&body body)
50 `(prog1
52 ,@body))
54 (eval-when (:compile-toplevel :load-toplevel)
55 (unless (find-symbol "QUAD" (FIND-PACKAGE "TUPLE-TYPES")))
56 (cl-tuples::make-tuple-symbol 'quad 'fixnum 0 '(a b c d)))
58 (cl-tuples::def-tuple quad)
59 (cl-tuples::def-tuple-struct quad)
60 (cl-tuples::def-tuple-maker quad)
61 (cl-tuples::def-tuple-setter quad)
62 (cl-tuples::def-tuple-getter quad)
63 (cl-tuples::def-tuple-set quad)
64 (cl-tuples::def-new-tuple quad)
65 (cl-tuples::def-tuple-maker* quad)
67 (defparameter *quad* (new-quad))
69 (deftest test-tuple-primitives ()
70 (check
71 (equalp (multiple-value-list (quad-values* 8 4 3 1)) '(8 4 3 1)))
72 (always-pass
73 (let ((my-quad (make-quad 3 7 5 9)))
74 (check
75 (equalp (multiple-value-list (quad* my-quad)) '(3 7 5 9))
76 (equalp my-quad #(3 7 5 9))
77 (set-quad my-quad 5 1 2 3))
78 (equalp my-quad #(5 1 2 3))
79 (quad-setter* my-quad #{9 10 7 6})
80 (equalp my-quad #(9 10 7 6)))
81 (let ((fresh-quad (new-quad))
82 (another-quad (make-quad 5 6 10 11)))
83 (check
84 (equalp fresh-quad #(0 0 0 0))
85 (equalp another-quad #(5 6 10 11))
86 (equalp (make-quad* #{ 5 2 9 12 }) #(5 2 9 12))))))
90 (cl-tuples::def-tuple-array-maker quad)
91 (cl-tuples::def-tuple-aref* quad)
92 (cl-tuples::def-tuple-aref quad)
93 (cl-tuples::def-tuple-aref-setter* quad)
94 (cl-tuples::def-tuple-aref-setter quad)
95 (cl-tuples::def-tuple-array-dimensions quad)
96 (cl-tuples::def-tuple-vector-push quad)
97 (cl-tuples::def-tuple-vector-push-extend quad)
98 (cl-tuples::def-tuple-vector-push* quad)
99 (cl-tuples::def-tuple-vector-push-extend* quad)
101 (defparameter *quads* (make-quad-array 3 :initial-element 0 :adjustable t :fill-pointer 2))
103 (deftest test-tuple-arrays ()
104 (check
105 (equalp (multiple-value-list (quad-aref-setter* *quads* 1 #[ quad* 4 5 6 19 ])) '( 4 5 6 19))
106 (equalp (multiple-value-list (quad-aref* *quads* 1)) '(4 5 6 19))
107 (equalp (quad-aref *quads* 1) #[ quad 4 5 6 19])
108 (equalp (quad-aref-setter *quads* 1 #(2 4 3 9)) #[ quad 2 4 3 9 ]))
109 (equalp (multiple-value-list (quad-aref* *quads* 1)) '(2 4 3 9))
110 (= (quad-array-dimensions *quads*) 2)
111 (always-pass
112 (let
113 ;; array extension
114 ((new-quads (make-quad-array 4 :initial-element 0 :adjustable t :fill-pointer 2)))
115 (check
116 (= (quad-vector-push #[ quad 8 9 22 34 ] new-quads) 3)
117 (equalp (quad-aref new-quads 2) #[ quad 8 9 22 34 ])
118 (= (quad-vector-push-extend #[ quad 27 28 29 34 ] new-quads) 4)
119 (equalp (quad-aref new-quads 3) #[ quad 27 28 29 34 ]))))
120 (always-pass
121 (let
122 ;; array extension
123 ((new-quads (make-quad-array 4 :initial-element 0 :adjustable t :fill-pointer 2)))
124 (check
125 (= (quad-vector-push* #[ quad* 8 9 22 34 ] new-quads) 3)
126 (equalp (quad-aref new-quads 2) #[ quad 8 9 22 34] )
127 (= (quad-vector-push-extend* #[ quad* 27 28 29 34 ] new-quads) 4)
128 (equalp (quad-aref new-quads 3) #[ quad 27 28 29 34])))))
131 (cl-tuples::def-with-tuple quad)
132 (cl-tuples::def-with-tuple* quad)
133 (cl-tuples::def-with-tuple-aref quad)
135 (deftest test-tuple-macros ()
136 (always-pass
137 (let ((my-quad (make-quad 9 10 7 6)))
138 (with-quad my-quad (e1 e2 e3 e4)
139 (check (equalp (list e1 e2 e3 e4) '(9 10 7 6)))))
140 (let ((my-quad (make-quad 3 1 4 5)))
141 (with-quad* (quad* my-quad) (e1 e2 e3 e4)
142 (check (equalp (list e1 e2 e3 e4) '(3 1 4 5)))))
143 (with-quad-aref (*quads* 1 (el1 el2 el3 el4))
144 (check (equalp (vector el1 el2 el3 el4) (quad-aref *quads* 1))))))
146 ;; generalised reference ?
148 (cl-tuples::def-tuple-setf* quad)
149 (cl-tuples::def-tuple-array-setf* quad)
150 (cl-tuples::def-tuple-array-setf quad)
152 (deftest test-tuple-setf ()
153 (always-pass
154 (let ((test-quad (new-quad))
155 (test-quads (make-quad-array 9)))
156 (check
157 (equalp (multiple-value-list (setf (quad* test-quad) #[ quad* -1 -2 -3 -4])) '( -1 -2 -3 -4))
158 (equalp test-quad #(-1 -2 -3 -4))
159 (equalp (multiple-value-list (setf (quad-aref* test-quads 1) #[ quad* -4 -3 -2 -1])) '(-4 -3 -2 -1))
160 (equalp (setf (quad-aref test-quads 2) #( -10 -11 -12 -13)) #[ quad -10 -11 -12 -13])
161 (equalp (quad-aref test-quads 2) #[ quad -10 -11 -12 -13])))))
163 (test-tuple-primitives)
164 (test-tuple-arrays)
165 (test-tuple-macros)
166 (test-tuple-setf)
168 (def-tuple-type pair
169 :tuple-element-type (unsigned-byte 8)
170 :initial-element 0
171 :elements (first second))
173 (defparameter *test-pair*
174 (make-pair 1 2))
176 (defparameter *pair-array*
177 (make-pair-array 2 :initial-element 0 :adjustable t :fill-pointer 1))
179 (deftest test-tuple-type ()
180 (check
181 (equalp *test-pair* #[ pair 1 2 ])
182 (equalp (multiple-value-list (pair* *test-pair*)) '( 1 2 ))
183 (equalp (multiple-value-list (setf (pair* *test-pair*) #[ pair* 3 7])) '(3 7))
184 (equalp *test-pair* #[ pair 3 7 ])))
186 (test-tuple-type)
188 ;; test the vectors
190 (defparameter *v2d* (make-vector2d* #[ vector2d* 1.0f0 2.0f0 ]))
191 ;; ;; basic vector math
192 (defparameter *vector0* (make-vector3d* #[ vector3d* 0.0f0 0.0f0 0.0f0 ] ))
193 (defparameter *vector1* (make-vector3d* #[ vector3d* 1.0f0 1.0f0 1.0f0 ] ))
194 (defparameter *vectorx* (make-vector3d* #[ vector3d* 1.0f0 0.0f0 0.0f0 ] ))
195 (defparameter *vectory* (make-vector3d* #[ vector3d* 0.0f0 1.0f0 0.0f0 ] ))
196 (defparameter *vectorz* (make-vector3d* #[ vector3d* 0.0f0 0.0f0 1.0f0 ] ))
197 (defparameter *test-vector* (new-vector3d))
199 (defun === (x y &optional (epsilon 1f-5))
200 "Approx == for a pair or pair of lists of numbers"
201 (flet ((compare (x y)
202 (< (abs (- x y)) epsilon)))
203 (cond
204 ((and (numberp x) (numberp y))
205 (compare x y))
206 ((and (listp x) (listp y))
207 (every #'identity (mapcar #'compare x y))))))
210 (deftest test-vectors ()
211 (check
212 (equalp (multiple-value-list (cl-tuples::vector2d-scale* (vector2d* *v2d*) 0.5f0))
213 '( 0.5f0 1.0f0 ))
214 (=== 0.0f0 (vector3d-length* (vector3d* *vector0*)))
215 (=== (sqrt 3.0f0) (vector3d-length* (vector3d* *vector1*)))
216 (equalp (multiple-value-list (vector3d-normal* (vector3d* *vector1*)))
217 '(0.57735026f0 0.57735026f0 0.57735026f0))
218 (equalp (multiple-value-list (vector3d-cross* (vector3d* *vectorx*) (vector3d* *vectory*)))
219 '(0.0f0 0.0f0 1.0f0))
220 (=== (vector3d-dot* (vector3d* *vectorx*) (vector3d-normal* (vector3d* *vector1*)))
221 0.57735026f0)
222 (=== (vector3d-length* (vector3d* *vector1*))
223 (sqrt 3))))
226 (test-vectors)
229 (deftest test-matrices ()
230 (flet ((torad (x) (coerce (* x (/ FAST-PI 180f0)) 'fast-float)))
231 (let* ((rotatexccw (make-matrix44* (rotatex-matrix44* (torad 90f0))))
232 (rotatexcw (make-matrix44* (rotatex-matrix44* (torad -90f0))))
233 (vector0 (make-vector3d 0.0f0 0.0f0 0.0f0))
234 (vector1 (make-vector3d 1.0f0 1.0f0 1.0f0))
235 (vertex0 (make-vertex3d* (vector3d-vertex3d* (vector3d* vector0))))
236 (vertex1 (make-vertex3d* (vector3d-vertex3d* (vector3d* vector1)))))
237 (check
238 (equalp
239 (multiple-value-list
240 (vector3d-difference*
241 (vector3d-values* 0.0f0 0.0f0 0.0f0) (vector3d-values* 1.0f0 1.0f0 1.0f0)))
242 '(-1.0f0 -1.0f0 -1.0f0))
243 (=== (vertex3d-distance* (vertex3d* vertex0) (vertex3d* vertex1))
244 1.7320508f0)
245 (=== (let ((result (multiple-value-list
246 (transform-vertex3d*
247 (matrix44* rotatexccw)
248 (transform-vertex3d*
249 (matrix44* rotatexcw)
250 (vertex3d-values* 0.0f0 0.0f0 1.0f0 1.0f0))))))
251 (format t "~A~%" result)
252 result)
253 '(0.0f0 0.0f0 1.0f0 1.0f0))))))
255 ;; (flet ((torad (x) (coerce (* x (/ FAST-PI 180f0)) 'fast-float)))
256 ;; (let* ((rotatexccw (make-matrix44* (rotatex-matrix44* (torad 90f0))))
257 ;; (rotatexcw (make-matrix44* (rotatex-matrix44* (torad -90f0)))))
258 ;; (result (multiple-value-list
259 ;; (transform-vertex3d*
260 ;; (rotatex-matrix44* (matrix44* rotatexccw))
261 ;; (transform-vertex3d*
262 ;; (matrix44* rotatexcw)
263 ;; (vertex3d-values* 0.0f0 0.0f0 1.0f0 1.0f0))))))
264 ;; (format t "~A~%" result)
265 ;; result))
267 ;; ;; check expander functions and with functions
268 ;; (flet ((torad (x) (coerce (* x (/ FAST-PI 180f0)) 'fast-float)))
269 ;; (rotatex-matrix44* (the fast-float (torad 90f0))))
271 (test-matrices)
273 (defun test-cl-tuples ()
274 ;; going to have to rewrite the tests to stop depending on top-level vars..
277 ;; ;; test identity mult
279 ;; (defparameter *test-matrix* (make-matrix44 (cl-tuples::make-test-matrix44)))
280 ;; (defparameter *identity-matrix* (make-matrix44 (identity-matrix44)))
282 ;; (defparameter *vertex0* (make-vertex3d (vector3d-vertex3d (vector3d *vector0*))))
283 ;; (defparameter *vertex1* (make-vertex3d (vector3d-vertex3d (vector3d *vector1*))))
284 ;; (defparameter *vertexx* (make-vertex3d #{1.0f0 0.0f0 0.0f0 1.0f0}))
285 ;; (defparameter *vertexy* (make-vertex3d #{0.0f0 1.0f0 0.0f0 1.0f0}))
286 ;; (defparameter *vertexz* (make-vertex3d #{0.0f0 0.0f0 1.0f0 0.0f0}))
288 ;; (with-test *result*
289 ;; (equalp *test-vector* #(1.0f0 1.0f0 1.0f0))
290 ;; (setf *test-vector* (make-vector3d (delta-vector3d (vertex3d *vertex0*) (vertex3d *vertex1*)))))
292 ;; (with-test *result*
293 ;; (= *result* 1.7320508f0)
294 ;; (setf *result*
295 ;; (vertex3d-distance (vertex3d *vertex0*) (vertex3d *vertex1*))))
298 ;; (defun torad (x) (coerce (* x (/ PI 180f0)) 'single-float))
300 ;; ;; basic matrix math
301 ;; (defparameter *rotatex* (make-matrix44 (rotatex-matrix44 (torad 90))))
302 ;; (defparameter *rotatey* (make-matrix44 (rotatey-matrix44 (torad 90))))
303 ;; (defparameter *rotatez* (make-matrix44 (rotatez-matrix44 (torad 90))))
305 ;; (defparameter *vertexx0* (make-vertex3d (transform-vertex3d
306 ;; (matrix44 *rotatex*)
307 ;; (vertex3d *vertexx*))))
309 ;; (defparameter *vertexx1* (make-vertex3d
310 ;; (transform-vertex3d
311 ;; (matrix44 *rotatey*)
312 ;; (vertex3d *vertexx0*))))
314 ;; (defparameter *vertexx2* (make-vertex3d
315 ;; (transform-vertex3d
316 ;; (matrix44 *rotatez*)
317 ;; (vertex3d *vertexx1*))))
319 ;; (defparameter *concat-transform*
320 ;; (make-matrix44 (matrix44-product
321 ;; (matrix44 *rotatex*)
322 ;; (matrix44-product (matrix44 *rotatey*) (matrix44 *rotatez*)))))
324 ;; (defparameter *vertexx3* (make-vertex3d
325 ;; (transform-vertex3d
326 ;; (matrix44 *concat-transform*)
327 ;; (vertex3d *vertexx0*))))
330 ;; (defparameter *vector-array* (make-vector3d-array 2 :adjustable t :fill-pointer 1))
332 ;; (setf (vector3d-aref *vector-array* 0) (vector3d *vectorx*))
334 ;; ;; to do - should return size
335 ;; (vector3d-vector-push (vector3d *vectory*) *vector-array*)
337 ;; ;; to do - doesnt extend array properly
338 ;; (vector3d-vector-push-extend (vector3d *vectorz*) *vector-array*)
340 ;; ;; ;; iterate across array, apply transforms
341 ;; (loop
342 ;; for i from 0 below (vector3d-array-dimensions *vector-array*)
343 ;; do
344 ;; (setf (vector3d-aref *vector-array* i)
345 ;; (cl-tuples::transform-vector3d
346 ;; (matrix44 *concat-transform*)
347 ;; (vector3d-aref *vector-array* i))))
351 ;; ;; quick test case for clos wrapper
353 ;; (def-tuple-class camera
354 ;; (:tuples
355 ;; ((up :type cl-tuples::vector3d)
356 ;; (forward :type vector3d)
357 ;; (location :type vertex3d)
358 ;; (vertices :type vertex3d :array 5))
359 ;; :slots
360 ;; ((focal-length :type single-float :accessor focal-length-of)
361 ;; (id :allocation :class :reader id-of))))
363 ;; ;;*test stanza*
364 ;; (defparameter *test-camera* (make-instance 'camera))
365 ;; (setf (up-of *test-camera*) #{ 0.0f0 0.0f0 0.0f0 })
366 ;; (up-of *test-camera*)
367 ;; (setf (up-of *test-camera*) #{ 1.0f0 2.0f0 3.0f0 })
368 ;; (setf (vertices-of *test-camera* 3) #{ 2.0f0 3.0f0 -2.5f0 1.0f0 })
369 ;; (vertices-of *test-camera* 3)
370 ;; (vertices-of *test-camera* 4)
371 ;; (vertices-of *test-camera* 1)
373 ;; (defparameter *test-shape* (make-vector3d-array 4))
375 ;; (setf (vector3d-aref *test-shape* 0) (vector3d* 3.14f0 0.0f0 3.14f0))
376 ;; (setf (vector3d-aref *test-shape* 1) (vector3d* 3.14f0 0.0f0 -3.14f0))
377 ;; (setf (vector3d-aref *test-shape* 2) (vector3d* -3.14f0 0.0f0 -3.14f0))
378 ;; (setf (vector3d-aref *test-shape* 3) (vector3d* -3.14f0 0.0f0 3.14f0))
381 ;; (defparameter *test-quaternion* (make-quaternion
382 ;; (angle-axis-quaternion
383 ;; (angle-axis* 0.0f0 1.0f0 0.0f0 (/ 3.14f0 2.0f0)))))
386 ;; (defparameter *test-matrix*
387 ;; (make-matrix33
388 ;; (quaternion-matrix33 (quaternion *test-quaternion*))))
391 ;; (loop
392 ;; for index from 0 below (vector3d-array-dimensions *test-shape*)
393 ;; do
394 ;; (setf (vector3d-aref *test-shape* index)
395 ;; (quaternion-transform-vector3d
396 ;; (vector3d-aref *test-shape* index)
397 ;; (quaternion *test-quaternion*))))
399 ;; (loop
400 ;; for index from 0 below (vector3d-array-dimensions *test-shape*)
401 ;; do
402 ;; (setf (vector3d-aref *test-shape* index)
403 ;; (transform-vector3d
404 ;; (matrix44-matrix33 (matrix44 *rotatey*))
405 ;; (vector3d-aref *test-shape* index))))