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 (defvar *test-name* nil)
  12
  13 (defmacro deftest (name parameters &body body)
  14   "Define a test function. Within a test function we can call
  15    other test functions or use 'check' to run individual test
  16    cases."
  17   `(defun ,name ,parameters
  18          (let ((*test-name* (append *test-name* (list ',name))))
  19            ,@body)))
  20
  21 (defmacro check (&body forms)
  22   "Run each expression in 'forms' as a test case."
  23   `(combine-results
  24          ,@(loop for f in forms collect `(report-result ,f ',f))))
  25
  26 (defmacro combine-results (&body forms)
  27   "Combine the results (as booleans) of evaluating 'forms' in order."
  28   (cl-tuples::with-gensyms (result)
  29     `(let ((,result t))
  30            ,@(loop for f in forms collect `(unless ,f (setf ,result nil)))
  31            ,result)))
  32
  33 (defun report-result (result form)
  34   "Report the results of a single test case. Called by 'check'."
  35   (format t "~:[FAIL~;pass~] ... ~a: ~a~%" result *test-name* form)
  36   result)
  37
  38 (defmacro with-test (test-sym test &rest forms)
  39   (cl-tuples::with-gensyms (result)
  40         `(progn
  41            ,@forms
  42            (let
  43                    ((,result ,test))
  44                  (assert ,result)
  45                  (setf ,test-sym (and ,test-sym ,result))))))
  46
  47 (defmacro always-pass (&body body)
  48   `(prog1
  49            t
  50          ,@body))
  51
  52 (eval-when (:compile-toplevel :load-toplevel)
  53   (unless (find-symbol "QUAD" (FIND-PACKAGE "TUPLE-TYPES")))
  54   (cl-tuples::make-tuple-symbol 'quad 'fixnum 0 '(a b  c d)))
  55
  56 (cl-tuples::def-tuple quad)
  57 (cl-tuples::def-tuple-struct quad)
  58 (cl-tuples::def-tuple-maker  quad)
  59 (cl-tuples::def-tuple-setter quad)
  60 (cl-tuples::def-tuple-getter quad)
  61 (cl-tuples::def-tuple-set quad)
  62 (cl-tuples::def-new-tuple quad)
  63 (cl-tuples::def-tuple-maker* quad)
  64
  65 (defparameter *quad* (new-quad))
  66
  67 (deftest test-tuple-primitives ()
  68   (check
  69         (equalp (multiple-value-list (quad-values* 8 4 3 1)) '(8 4 3 1)))
  70   (always-pass
  71         (let ((my-quad (make-quad 3 7 5 9)))
  72           (check
  73                 (equalp (multiple-value-list (quad* my-quad)) '(3 7 5 9))
  74                 (equalp my-quad #(3 7 5 9))
  75                 (set-quad my-quad 5 1 2 3))
  76           (equalp my-quad #(5 1 2 3))
  77           (quad-setter* my-quad #{9 10 7 6})
  78           (equalp my-quad #(9 10 7 6)))
  79         (let ((fresh-quad (new-quad))
  80                   (another-quad (make-quad 5 6 10 11)))
  81           (check
  82                 (equalp fresh-quad #(0 0 0 0))
  83                 (equalp another-quad  #(5 6 10 11))
  84                 (equalp (make-quad* #{ 5 2 9 12 }) #(5 2 9 12))))))
  85
  86
  87
  88 (cl-tuples::def-tuple-array-maker quad)
  89 (cl-tuples::def-tuple-aref* quad)
  90 (cl-tuples::def-tuple-aref  quad)
  91 (cl-tuples::def-tuple-aref-setter* quad)
  92 (cl-tuples::def-tuple-aref-setter quad)
  93 (cl-tuples::def-tuple-array-dimensions quad)
  94 (cl-tuples::def-tuple-vector-push quad)
  95 (cl-tuples::def-tuple-vector-push-extend quad)
  96 (cl-tuples::def-tuple-vector-push* quad)
  97 (cl-tuples::def-tuple-vector-push-extend* quad)
  98
  99 (defparameter *quads* (make-quad-array 3 :initial-element 0 :adjustable t :fill-pointer 2))
 100
 101 (deftest test-tuple-arrays ()
 102   (check
 103         (equalp (multiple-value-list (quad-aref-setter* *quads* 1 #[ quad* 4 5 6 19 ])) '( 4 5 6 19))
 104         (equalp (multiple-value-list (quad-aref* *quads* 1)) '(4 5 6 19))
 105         (equalp (quad-aref  *quads* 1) #[ quad 4 5 6 19])
 106         (equalp (quad-aref-setter *quads* 1 #(2 4 3 9))  #[ quad 2 4 3 9 ]))
 107   (equalp (multiple-value-list (quad-aref* *quads* 1)) '(2 4 3 9))
 108   (= (quad-array-dimensions *quads*) 2)
 109   (always-pass
 110         (let
 111                 ;; array extension
 112                 ((new-quads (make-quad-array 4 :initial-element 0 :adjustable t :fill-pointer 2)))
 113           (check
 114                 (= (quad-vector-push  #[ quad 8 9 22 34 ] new-quads) 3)
 115                 (equalp (quad-aref new-quads 2) #[ quad 8 9 22 34 ])
 116                 (= (quad-vector-push-extend #[ quad 27 28 29 34 ] new-quads) 4)
 117                 (equalp (quad-aref new-quads 3) #[ quad 27 28 29 34 ]))))
 118   (always-pass
 119         (let
 120                 ;; array extension
 121                 ((new-quads (make-quad-array 4 :initial-element 0 :adjustable t :fill-pointer 2)))
 122           (check
 123                 (= (quad-vector-push*  #[ quad* 8 9 22 34 ] new-quads) 3)
 124                 (equalp (quad-aref new-quads 2) #[ quad 8 9 22 34] )
 125                 (= (quad-vector-push-extend* #[ quad* 27 28 29 34 ] new-quads) 4)
 126                 (equalp (quad-aref new-quads 3) #[ quad 27 28 29 34])))))
 127
 128
 129 (cl-tuples::def-with-tuple quad)
 130 (cl-tuples::def-with-tuple* quad)
 131 (cl-tuples::def-with-tuple-aref quad)
 132
 133 (deftest test-tuple-macros ()
 134   (always-pass
 135         (let ((my-quad (make-quad 9 10 7 6)))
 136           (with-quad my-quad (e1 e2 e3 e4)
 137                 (check (equalp (list e1 e2 e3 e4) '(9 10 7 6)))))
 138         (let ((my-quad (make-quad 3 1 4 5)))
 139           (with-quad* (quad* my-quad) (e1 e2 e3 e4)
 140                 (check (equalp (list e1 e2 e3 e4) '(3 1 4 5)))))
 141         (with-quad-aref (*quads* 1 (el1 el2 el3 el4))
 142           (check (equalp (vector el1 el2 el3 el4) (quad-aref *quads* 1))))))
 143
 144 ;; generalised reference ?
 145
 146 (cl-tuples::def-tuple-setf*  quad)
 147 (cl-tuples::def-tuple-array-setf*  quad)
 148 (cl-tuples::def-tuple-array-setf quad)
 149
 150 (deftest test-tuple-setf ()
 151   (always-pass
 152         (let ((test-quad (new-quad))
 153                   (test-quads (make-quad-array 9)))
 154           (check
 155                 (equalp (multiple-value-list (setf (quad* test-quad)  #[ quad* -1 -2 -3 -4])) '( -1 -2 -3 -4))
 156                 (equalp test-quad #(-1 -2 -3 -4))
 157                 (equalp (multiple-value-list (setf (quad-aref* test-quads 1) #[ quad* -4 -3 -2 -1])) '(-4 -3 -2 -1))
 158                 (equalp (setf (quad-aref test-quads 2)  #( -10 -11 -12 -13)) #[ quad -10 -11 -12 -13])
 159                 (equalp (quad-aref test-quads 2)  #[ quad -10 -11 -12 -13])))))
 160
 161 (test-tuple-primitives)
 162 (test-tuple-arrays)
 163 (test-tuple-macros)
 164 (test-tuple-setf)
 165
 166 (def-tuple-type pair
 167         :tuple-element-type (unsigned-byte 8)
 168         :initial-element 0
 169         :elements (first second))
 170
 171 (defparameter *test-pair*
 172   (make-pair 1 2))
 173
 174 (defparameter *pair-array*
 175   (make-pair-array 2 :initial-element 0 :adjustable t :fill-pointer 1))
 176
 177 (deftest test-tuple-type ()
 178   (check
 179         (equalp *test-pair* #[ pair 1 2 ])
 180         (equalp (multiple-value-list (pair* *test-pair*)) '( 1 2 ))
 181         (equalp (multiple-value-list  (setf (pair* *test-pair*) #[ pair* 3 7])) '(3 7))
 182         (equalp *test-pair* #[ pair 3 7 ])))
 183
 184 (test-tuple-type)
 185
 186
 187 ;; test the vectors
 188
 189
 190 (defparameter *v2d* (make-vector2d* #[ vector2d* 1.0 2.0 ]))
 191 ;; ;; basic vector math
 192 (defparameter *vector0* (make-vector3d* #[ vector3d* 0.0 0.0 0.0 ] ))
 193 (defparameter *vector1* (make-vector3d* #[ vector3d* 1.0 1.0 1.0 ] ))
 194 (defparameter *vectorx* (make-vector3d* #[ vector3d* 1.0 0.0 0.0 ] ))
 195 (defparameter *vectory* (make-vector3d* #[ vector3d* 0.0 1.0 0.0 ] ))
 196 (defparameter *vectorz* (make-vector3d* #[ vector3d* 0.0 0.0 1.0 ] ))
 197 (defparameter *test-vector* (new-vector3d))
 198
 199 (defun === (x y &optional (epsilon 0.00001))
 200   (< (abs (- x y)) epsilon))
 201
 202 (deftest test-vectors ()
 203   (check
 204         (equalp (multiple-value-list
 205                          (cl-tuples::vector2d-scale* (vector2d* *v2d*) 0.5)) '( 0.5 1.0  ))
 206   (=== 0.0 (vector3d-length* (vector3d* *vector0*)))
 207   (=== (sqrt 3.0) (vector3d-length* (vector3d* *vector1*)))
 208   (equalp
 209    (multiple-value-list
 210         (vector3d-normal* (vector3d* *vector1*))) '(0.57735026 0.57735026 0.57735026))
 211   (equalp
 212    (multiple-value-list
 213         (vector3d-cross* (vector3d* *vectorx*) (vector3d* *vectory*))) '(0.0 0.0 1.0))
 214   (===
 215    (vector3d-dot* (vector3d* *vectorx*) (vector3d-normal* (vector3d* *vector1*)))
 216    0.57735026))
 217   (===
 218    (vector3d-length* (vector3d* *vector1*))
 219    (sqrt 3)))
 220
 221
 222 (test-vectors)
 223
 224
 225
 226
 227
 228
 229
 230 ;; ;; test identity mult
 231
 232 ;; (defparameter *test-matrix* (make-matrix44 (cl-tuples::make-test-matrix44)))
 233 ;; (defparameter *identity-matrix* (make-matrix44 (identity-matrix44)))
 234
 235 ;; (defparameter *vertex0* (make-vertex3d (vector3d-vertex3d (vector3d  *vector0*))))
 236 ;; (defparameter *vertex1* (make-vertex3d (vector3d-vertex3d (vector3d  *vector1*))))
 237 ;; (defparameter *vertexx* (make-vertex3d #{1.0 0.0 0.0 1.0}))
 238 ;; (defparameter *vertexy* (make-vertex3d #{0.0 1.0 0.0 1.0}))
 239 ;; (defparameter *vertexz* (make-vertex3d #{0.0 0.0 1.0 0.0}))
 240
 241 ;; (with-test *result*
 242 ;;   (equalp *test-vector* #(1.0 1.0 1.0))
 243 ;;   (setf *test-vector* (make-vector3d (delta-vector3d  (vertex3d  *vertex0*)  (vertex3d *vertex1*)))))
 244
 245 ;; (with-test *result*
 246 ;;   (= *result* 1.7320508)
 247 ;;   (setf *result*
 248 ;;              (vertex3d-distance (vertex3d  *vertex0*) (vertex3d  *vertex1*))))
 249
 250
 251 ;; (defun torad (x) (coerce  (* x (/ PI 180.0)) 'single-float))
 252
 253 ;; ;; basic matrix math
 254 ;; (defparameter *rotatex* (make-matrix44 (rotatex-matrix44 (torad 90))))
 255 ;; (defparameter *rotatey* (make-matrix44 (rotatey-matrix44 (torad 90))))
 256 ;; (defparameter *rotatez* (make-matrix44 (rotatez-matrix44 (torad 90))))
 257
 258 ;; (defparameter *vertexx0* (make-vertex3d  (transform-vertex3d
 259 ;;                                                                                (matrix44  *rotatex*)
 260 ;;                                                                                (vertex3d  *vertexx*))))
 261
 262 ;; (defparameter *vertexx1* (make-vertex3d
 263 ;;                                                (transform-vertex3d
 264 ;;                                                 (matrix44  *rotatey*)
 265 ;;                                                 (vertex3d  *vertexx0*))))
 266
 267 ;; (defparameter *vertexx2* (make-vertex3d
 268 ;;                                                (transform-vertex3d
 269 ;;                                                 (matrix44  *rotatez*)
 270 ;;                                                 (vertex3d  *vertexx1*))))
 271
 272 ;; (defparameter *concat-transform*
 273 ;;   (make-matrix44 (matrix44-product
 274 ;;                                (matrix44 *rotatex*)
 275 ;;                                (matrix44-product (matrix44  *rotatey*) (matrix44 *rotatez*)))))
 276
 277 ;; (defparameter *vertexx3* (make-vertex3d
 278 ;;                                                (transform-vertex3d
 279 ;;                                                 (matrix44 *concat-transform*)
 280 ;;                                                 (vertex3d *vertexx0*))))
 281
 282
 283 ;; (defparameter *vector-array* (make-vector3d-array 2 :adjustable t :fill-pointer 1))
 284
 285 ;; (setf (vector3d-aref *vector-array* 0) (vector3d *vectorx*))
 286
 287 ;; ;; to do - should return size
 288 ;; (vector3d-vector-push  (vector3d  *vectory*) *vector-array*)
 289
 290 ;; ;; to do - doesnt extend array properly
 291 ;; (vector3d-vector-push-extend (vector3d *vectorz*) *vector-array*)
 292
 293 ;; ;; ;; iterate across array, apply transforms
 294 ;; (loop
 295 ;;    for i from 0 below (vector3d-array-dimensions *vector-array*)
 296 ;;    do
 297 ;;       (setf (vector3d-aref *vector-array* i)
 298 ;;                 (cl-tuples::transform-vector3d
 299 ;;                      (matrix44 *concat-transform*)
 300 ;;                      (vector3d-aref *vector-array* i))))
 301
 302
 303
 304 ;; ;; quick test case for clos wrapper
 305
 306 ;; (def-tuple-class camera
 307 ;;      (:tuples
 308 ;;       ((up :type cl-tuples::vector3d)
 309 ;;        (forward :type vector3d)
 310 ;;        (location :type vertex3d)
 311 ;;        (vertices :type vertex3d :array 5))
 312 ;;       :slots
 313 ;;       ((focal-length :type single-float :accessor focal-length-of)
 314 ;;        (id :allocation :class :reader id-of))))
 315
 316 ;; ;;*test stanza*
 317 ;; (defparameter *test-camera* (make-instance 'camera))
 318 ;; (setf (up-of *test-camera*) #{ 0.0 0.0 0.0 })
 319 ;; (up-of *test-camera*)
 320 ;; (setf (up-of *test-camera*) #{ 1.0 2.0 3.0 })
 321 ;; (setf (vertices-of *test-camera* 3) #{ 2.0 3.0 -2.5 1.0 })
 322 ;; (vertices-of *test-camera* 3)
 323 ;; (vertices-of *test-camera* 4)
 324 ;; (vertices-of *test-camera* 1)
 325
 326 ;; (defparameter *test-shape* (make-vector3d-array 4))
 327
 328 ;; (setf (vector3d-aref *test-shape* 0) (vector3d* 3.14 0.0 3.14))
 329 ;; (setf (vector3d-aref *test-shape* 1) (vector3d* 3.14 0.0 -3.14))
 330 ;; (setf (vector3d-aref *test-shape* 2) (vector3d* -3.14 0.0 -3.14))
 331 ;; (setf (vector3d-aref *test-shape* 3) (vector3d* -3.14 0.0 3.14))
 332
 333
 334 ;; (defparameter *test-quaternion* (make-quaternion
 335 ;;                                                               (angle-axis-quaternion
 336 ;;                                                                (angle-axis* 0.0 1.0 0.0 (/ 3.14 2.0)))))
 337
 338
 339 ;; (defparameter *test-matrix*
 340 ;;   (make-matrix33
 341 ;;    (quaternion-matrix33 (quaternion *test-quaternion*))))
 342
 343
 344 ;; (loop
 345 ;;    for index from 0 below (vector3d-array-dimensions *test-shape*)
 346 ;;    do
 347 ;;       (setf (vector3d-aref *test-shape* index)
 348 ;;                 (quaternion-transform-vector3d
 349 ;;                      (vector3d-aref *test-shape* index)
 350 ;;                      (quaternion *test-quaternion*))))
 351
 352 ;; (loop
 353 ;;    for index from 0 below (vector3d-array-dimensions *test-shape*)
 354 ;;    do
 355 ;;       (setf (vector3d-aref *test-shape* index)
 356 ;;                 (transform-vector3d
 357 ;;                      (matrix44-matrix33 (matrix44 *rotatey*))
 358 ;;                      (vector3d-aref *test-shape* index))))