tuples-test.lisp

   1
   2 (defpackage :cl-tuples-test
   3   (:use :cl-tuples :cl)
   4   (:export "test-cl-tuples"))
   5
   6 (in-package :cl-tuples-test)
   7
   8 (eval-when (:compile-toplevel :load-toplevel :execute)
   9   (pushnew :cl-tuples-debug *features*))
  10
  11 (file-enable-tuples-syntax)
  12
  13 (defvar *test-name* nil)
  14
  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)))
  22
  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))))
  27
  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)))
  34
  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)
  39
  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))))))
  48
  49 (defmacro always-pass (&body body)
  50   `(prog1
  51            t
  52          ,@body))
  53
  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)))
  57
  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)
  66
  67 (defparameter *quad* (new-quad))
  68
  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))))))
  87
  88
  89
  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)
 100
 101 (defparameter *quads* (make-quad-array 3 :initial-element 0 :adjustable t :fill-pointer 2))
 102
 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])))))
 129
 130
 131 (cl-tuples::def-with-tuple quad)
 132 (cl-tuples::def-with-tuple* quad)
 133 (cl-tuples::def-with-tuple-aref quad)
 134
 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))))))
 145
 146 ;; generalised reference ?
 147
 148 (cl-tuples::def-tuple-setf*  quad)
 149 (cl-tuples::def-tuple-array-setf*  quad)
 150 (cl-tuples::def-tuple-array-setf quad)
 151
 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])))))
 162
 163 (test-tuple-primitives)
 164 (test-tuple-arrays)
 165 (test-tuple-macros)
 166 (test-tuple-setf)
 167
 168 (def-tuple-type pair
 169         :tuple-element-type (unsigned-byte 8)
 170         :initial-element 0
 171         :elements (first second))
 172
 173 (defparameter *test-pair*
 174   (make-pair 1 2))
 175
 176 (defparameter *pair-array*
 177   (make-pair-array 2 :initial-element 0 :adjustable t :fill-pointer 1))
 178
 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 ])))
 185
 186 (test-tuple-type)
 187
 188
 189 ;; test the vectors
 190
 191
 192 (defparameter *v2d* (make-vector2d* #[ vector2d* 1.0 2.0 ]))
 193 ;; ;; basic vector math
 194 (defparameter *vector0* (make-vector3d* #[ vector3d* 0.0 0.0 0.0 ] ))
 195 (defparameter *vector1* (make-vector3d* #[ vector3d* 1.0 1.0 1.0 ] ))
 196 (defparameter *vectorx* (make-vector3d* #[ vector3d* 1.0 0.0 0.0 ] ))
 197 (defparameter *vectory* (make-vector3d* #[ vector3d* 0.0 1.0 0.0 ] ))
 198 (defparameter *vectorz* (make-vector3d* #[ vector3d* 0.0 0.0 1.0 ] ))
 199 (defparameter *test-vector* (new-vector3d))
 200
 201 (defun === (x y &optional (epsilon 0.00001))
 202   (< (abs (- x y)) epsilon))
 203
 204 (deftest test-vectors ()
 205   (check
 206         (equalp (multiple-value-list
 207                          (cl-tuples::vector2d-scale* (vector2d* *v2d*) 0.5)) '( 0.5 1.0  ))
 208   (=== 0.0 (vector3d-length* (vector3d* *vector0*)))
 209   (=== (sqrt 3.0) (vector3d-length* (vector3d* *vector1*)))
 210   (equalp
 211    (multiple-value-list
 212         (vector3d-normal* (vector3d* *vector1*))) '(0.57735026 0.57735026 0.57735026))
 213   (equalp
 214    (multiple-value-list
 215         (vector3d-cross* (vector3d* *vectorx*) (vector3d* *vectory*))) '(0.0 0.0 1.0))
 216   (===
 217    (vector3d-dot* (vector3d* *vectorx*) (vector3d-normal* (vector3d* *vector1*)))
 218    0.57735026))
 219   (===
 220    (vector3d-length* (vector3d* *vector1*))
 221    (sqrt 3)))
 222
 223
 224 (test-vectors)
 225
 226
 227
 228
 229
 230
 231
 232 ;; ;; test identity mult
 233
 234 ;; (defparameter *test-matrix* (make-matrix44 (cl-tuples::make-test-matrix44)))
 235 ;; (defparameter *identity-matrix* (make-matrix44 (identity-matrix44)))
 236
 237 ;; (defparameter *vertex0* (make-vertex3d (vector3d-vertex3d (vector3d  *vector0*))))
 238 ;; (defparameter *vertex1* (make-vertex3d (vector3d-vertex3d (vector3d  *vector1*))))
 239 ;; (defparameter *vertexx* (make-vertex3d #{1.0 0.0 0.0 1.0}))
 240 ;; (defparameter *vertexy* (make-vertex3d #{0.0 1.0 0.0 1.0}))
 241 ;; (defparameter *vertexz* (make-vertex3d #{0.0 0.0 1.0 0.0}))
 242
 243 ;; (with-test *result*
 244 ;;   (equalp *test-vector* #(1.0 1.0 1.0))
 245 ;;   (setf *test-vector* (make-vector3d (delta-vector3d  (vertex3d  *vertex0*)  (vertex3d *vertex1*)))))
 246
 247 ;; (with-test *result*
 248 ;;   (= *result* 1.7320508)
 249 ;;   (setf *result*
 250 ;;              (vertex3d-distance (vertex3d  *vertex0*) (vertex3d  *vertex1*))))
 251
 252
 253 ;; (defun torad (x) (coerce  (* x (/ PI 180.0)) 'single-float))
 254
 255 ;; ;; basic matrix math
 256 ;; (defparameter *rotatex* (make-matrix44 (rotatex-matrix44 (torad 90))))
 257 ;; (defparameter *rotatey* (make-matrix44 (rotatey-matrix44 (torad 90))))
 258 ;; (defparameter *rotatez* (make-matrix44 (rotatez-matrix44 (torad 90))))
 259
 260 ;; (defparameter *vertexx0* (make-vertex3d  (transform-vertex3d
 261 ;;                                                                                (matrix44  *rotatex*)
 262 ;;                                                                                (vertex3d  *vertexx*))))
 263
 264 ;; (defparameter *vertexx1* (make-vertex3d
 265 ;;                                                (transform-vertex3d
 266 ;;                                                 (matrix44  *rotatey*)
 267 ;;                                                 (vertex3d  *vertexx0*))))
 268
 269 ;; (defparameter *vertexx2* (make-vertex3d
 270 ;;                                                (transform-vertex3d
 271 ;;                                                 (matrix44  *rotatez*)
 272 ;;                                                 (vertex3d  *vertexx1*))))
 273
 274 ;; (defparameter *concat-transform*
 275 ;;   (make-matrix44 (matrix44-product
 276 ;;                                (matrix44 *rotatex*)
 277 ;;                                (matrix44-product (matrix44  *rotatey*) (matrix44 *rotatez*)))))
 278
 279 ;; (defparameter *vertexx3* (make-vertex3d
 280 ;;                                                (transform-vertex3d
 281 ;;                                                 (matrix44 *concat-transform*)
 282 ;;                                                 (vertex3d *vertexx0*))))
 283
 284
 285 ;; (defparameter *vector-array* (make-vector3d-array 2 :adjustable t :fill-pointer 1))
 286
 287 ;; (setf (vector3d-aref *vector-array* 0) (vector3d *vectorx*))
 288
 289 ;; ;; to do - should return size
 290 ;; (vector3d-vector-push  (vector3d  *vectory*) *vector-array*)
 291
 292 ;; ;; to do - doesnt extend array properly
 293 ;; (vector3d-vector-push-extend (vector3d *vectorz*) *vector-array*)
 294
 295 ;; ;; ;; iterate across array, apply transforms
 296 ;; (loop
 297 ;;    for i from 0 below (vector3d-array-dimensions *vector-array*)
 298 ;;    do
 299 ;;       (setf (vector3d-aref *vector-array* i)
 300 ;;                 (cl-tuples::transform-vector3d
 301 ;;                      (matrix44 *concat-transform*)
 302 ;;                      (vector3d-aref *vector-array* i))))
 303
 304
 305
 306 ;; ;; quick test case for clos wrapper
 307
 308 ;; (def-tuple-class camera
 309 ;;      (:tuples
 310 ;;       ((up :type cl-tuples::vector3d)
 311 ;;        (forward :type vector3d)
 312 ;;        (location :type vertex3d)
 313 ;;        (vertices :type vertex3d :array 5))
 314 ;;       :slots
 315 ;;       ((focal-length :type single-float :accessor focal-length-of)
 316 ;;        (id :allocation :class :reader id-of))))
 317
 318 ;; ;;*test stanza*
 319 ;; (defparameter *test-camera* (make-instance 'camera))
 320 ;; (setf (up-of *test-camera*) #{ 0.0 0.0 0.0 })
 321 ;; (up-of *test-camera*)
 322 ;; (setf (up-of *test-camera*) #{ 1.0 2.0 3.0 })
 323 ;; (setf (vertices-of *test-camera* 3) #{ 2.0 3.0 -2.5 1.0 })
 324 ;; (vertices-of *test-camera* 3)
 325 ;; (vertices-of *test-camera* 4)
 326 ;; (vertices-of *test-camera* 1)
 327
 328 ;; (defparameter *test-shape* (make-vector3d-array 4))
 329
 330 ;; (setf (vector3d-aref *test-shape* 0) (vector3d* 3.14 0.0 3.14))
 331 ;; (setf (vector3d-aref *test-shape* 1) (vector3d* 3.14 0.0 -3.14))
 332 ;; (setf (vector3d-aref *test-shape* 2) (vector3d* -3.14 0.0 -3.14))
 333 ;; (setf (vector3d-aref *test-shape* 3) (vector3d* -3.14 0.0 3.14))
 334
 335
 336 ;; (defparameter *test-quaternion* (make-quaternion
 337 ;;                                                               (angle-axis-quaternion
 338 ;;                                                                (angle-axis* 0.0 1.0 0.0 (/ 3.14 2.0)))))
 339
 340
 341 ;; (defparameter *test-matrix*
 342 ;;   (make-matrix33
 343 ;;    (quaternion-matrix33 (quaternion *test-quaternion*))))
 344
 345
 346 ;; (loop
 347 ;;    for index from 0 below (vector3d-array-dimensions *test-shape*)
 348 ;;    do
 349 ;;       (setf (vector3d-aref *test-shape* index)
 350 ;;                 (quaternion-transform-vector3d
 351 ;;                      (vector3d-aref *test-shape* index)
 352 ;;                      (quaternion *test-quaternion*))))
 353
 354 ;; (loop
 355 ;;    for index from 0 below (vector3d-array-dimensions *test-shape*)
 356 ;;    do
 357 ;;       (setf (vector3d-aref *test-shape* index)
 358 ;;                 (transform-vector3d
 359 ;;                      (matrix44-matrix33 (matrix44 *rotatey*))
 360 ;;                      (vector3d-aref *test-shape* index))))