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 ;; test the vectors
 189
 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))
 198
 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))))))
 208
 209
 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))))
 224
 225
 226 (test-vectors)
 227
 228
 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))))))
 254
 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))
 266
 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))))
 270
 271 (test-matrices)
 272
 273 (defun test-cl-tuples ()
 274   ;; going to have to rewrite the tests to stop depending on top-level vars..
 275   t)
 276
 277 ;; ;; test identity mult
 278
 279 ;; (defparameter *test-matrix* (make-matrix44 (cl-tuples::make-test-matrix44)))
 280 ;; (defparameter *identity-matrix* (make-matrix44 (identity-matrix44)))
 281
 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}))
 287
 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*)))))
 291
 292 ;; (with-test *result*
 293 ;;   (= *result* 1.7320508f0)
 294 ;;   (setf *result*
 295 ;;              (vertex3d-distance (vertex3d  *vertex0*) (vertex3d  *vertex1*))))
 296
 297
 298 ;; (defun torad (x) (coerce  (* x (/ PI 180f0)) 'single-float))
 299
 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))))
 304
 305 ;; (defparameter *vertexx0* (make-vertex3d  (transform-vertex3d
 306 ;;                                                                                (matrix44  *rotatex*)
 307 ;;                                                                                (vertex3d  *vertexx*))))
 308
 309 ;; (defparameter *vertexx1* (make-vertex3d
 310 ;;                                                (transform-vertex3d
 311 ;;                                                 (matrix44  *rotatey*)
 312 ;;                                                 (vertex3d  *vertexx0*))))
 313
 314 ;; (defparameter *vertexx2* (make-vertex3d
 315 ;;                                                (transform-vertex3d
 316 ;;                                                 (matrix44  *rotatez*)
 317 ;;                                                 (vertex3d  *vertexx1*))))
 318
 319 ;; (defparameter *concat-transform*
 320 ;;   (make-matrix44 (matrix44-product
 321 ;;                                (matrix44 *rotatex*)
 322 ;;                                (matrix44-product (matrix44  *rotatey*) (matrix44 *rotatez*)))))
 323
 324 ;; (defparameter *vertexx3* (make-vertex3d
 325 ;;                                                (transform-vertex3d
 326 ;;                                                 (matrix44 *concat-transform*)
 327 ;;                                                 (vertex3d *vertexx0*))))
 328
 329
 330 ;; (defparameter *vector-array* (make-vector3d-array 2 :adjustable t :fill-pointer 1))
 331
 332 ;; (setf (vector3d-aref *vector-array* 0) (vector3d *vectorx*))
 333
 334 ;; ;; to do - should return size
 335 ;; (vector3d-vector-push  (vector3d  *vectory*) *vector-array*)
 336
 337 ;; ;; to do - doesnt extend array properly
 338 ;; (vector3d-vector-push-extend (vector3d *vectorz*) *vector-array*)
 339
 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))))
 348
 349
 350
 351 ;; ;; quick test case for clos wrapper
 352
 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))))
 362
 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)
 372
 373 ;; (defparameter *test-shape* (make-vector3d-array 4))
 374
 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))
 379
 380
 381 ;; (defparameter *test-quaternion* (make-quaternion
 382 ;;                                                               (angle-axis-quaternion
 383 ;;                                                                (angle-axis* 0.0f0 1.0f0 0.0f0 (/ 3.14f0 2.0f0)))))
 384
 385
 386 ;; (defparameter *test-matrix*
 387 ;;   (make-matrix33
 388 ;;    (quaternion-matrix33 (quaternion *test-quaternion*))))
 389
 390
 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*))))
 398
 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))))