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.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   "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
 213                          (cl-tuples::vector2d-scale* (vector2d* *v2d*) 0.5)) '( 0.5 1.0  ))
 214   (=== 0.0 (vector3d-length* (vector3d* *vector0*)))
 215   (=== (sqrt 3.0) (vector3d-length* (vector3d* *vector1*)))
 216   (equalp
 217    (multiple-value-list
 218         (vector3d-normal* (vector3d* *vector1*))) '(0.57735026 0.57735026 0.57735026))
 219   (equalp
 220    (multiple-value-list
 221         (vector3d-cross* (vector3d* *vectorx*) (vector3d* *vectory*))) '(0.0 0.0 1.0))
 222   (===
 223    (vector3d-dot* (vector3d* *vectorx*) (vector3d-normal* (vector3d* *vector1*)))
 224    0.57735026))
 225   (===
 226    (vector3d-length* (vector3d* *vector1*))
 227    (sqrt 3)))
 228
 229
 230 (test-vectors)
 231
 232
 233 (deftest test-matrices ()
 234          (flet ((torad (x) (coerce (* x (/ FAST-PI 180.0)) 'fast-float)))
 235            (let* ((rotatexccw (make-matrix44* (rotatex-matrix44* (torad 90.0))))
 236                           (rotatexcw  (make-matrix44* (rotatex-matrix44* (torad -90.0))))
 237                           (vector0 (make-vector3d 0.0 0.0 0.0))
 238                           (vector1 (make-vector3d 1.0 1.0 1.0))
 239                           (vertex0 (make-vertex3d* (vector3d-vertex3d* (vector3d*  vector0))))
 240                           (vertex1 (make-vertex3d* (vector3d-vertex3d* (vector3d* vector1)))))
 241                  (check
 242                    (equalp
 243                         (multiple-value-list
 244                          (vector3d-difference*  (vector3d-values* 0.0 0.0 0.0) (vector3d-values* 1.0 1.0 1.0))) '(-1.0 -1.0 -1.0))
 245                    (=== (vertex3d-distance* (vertex3d* vertex0) (vertex3d* vertex1))
 246                                 1.7320508)
 247                    (=== (let ((result (multiple-value-list
 248                                                            (transform-vertex3d*
 249                                                                 (matrix44* rotatexccw)
 250                                                                 (transform-vertex3d*
 251                                                                  (matrix44* rotatexcw)
 252                                                                  (vertex3d-values*  0.0 0.0 1.0 1.0))))))
 253                                   (format t "~A~%" result)
 254                                   result)
 255                                 '(0.0 0.0 1.0 1.0))))))
 256
 257 ;; (flet ((torad (x) (coerce (* x (/ FAST-PI 180.0)) 'fast-float)))
 258 ;;   (let* ((rotatexccw (make-matrix44* (rotatex-matrix44* (torad 90.0))))
 259 ;;               (rotatexcw  (make-matrix44* (rotatex-matrix44* (torad -90.0)))))
 260 ;;               (result (multiple-value-list
 261 ;;                                (transform-vertex3d*
 262 ;;                                 (rotatex-matrix44* (matrix44* rotatexccw))
 263 ;;                                 (transform-vertex3d*
 264 ;;                                      (matrix44* rotatexcw)
 265 ;;                                      (vertex3d-values*  0.0 0.0 1.0 1.0))))))
 266 ;;      (format t "~A~%" result)
 267 ;;      result))
 268
 269 ;; ;; check expander functions and with functions
 270 ;; (flet ((torad (x) (coerce (* x (/ FAST-PI 180.0)) 'fast-float)))
 271 ;;   (rotatex-matrix44* (the fast-float (torad 90.0))))
 272
 273 (test-matrices)
 274
 275 (defun test-cl-tuples ()
 276   ;; going to have to rewrite the tests to stop depending on top-level vars..
 277   t)
 278
 279 ;; ;; test identity mult
 280
 281 ;; (defparameter *test-matrix* (make-matrix44 (cl-tuples::make-test-matrix44)))
 282 ;; (defparameter *identity-matrix* (make-matrix44 (identity-matrix44)))
 283
 284 ;; (defparameter *vertex0* (make-vertex3d (vector3d-vertex3d (vector3d  *vector0*))))
 285 ;; (defparameter *vertex1* (make-vertex3d (vector3d-vertex3d (vector3d  *vector1*))))
 286 ;; (defparameter *vertexx* (make-vertex3d #{1.0 0.0 0.0 1.0}))
 287 ;; (defparameter *vertexy* (make-vertex3d #{0.0 1.0 0.0 1.0}))
 288 ;; (defparameter *vertexz* (make-vertex3d #{0.0 0.0 1.0 0.0}))
 289
 290 ;; (with-test *result*
 291 ;;   (equalp *test-vector* #(1.0 1.0 1.0))
 292 ;;   (setf *test-vector* (make-vector3d (delta-vector3d  (vertex3d  *vertex0*)  (vertex3d *vertex1*)))))
 293
 294 ;; (with-test *result*
 295 ;;   (= *result* 1.7320508)
 296 ;;   (setf *result*
 297 ;;              (vertex3d-distance (vertex3d  *vertex0*) (vertex3d  *vertex1*))))
 298
 299
 300 ;; (defun torad (x) (coerce  (* x (/ PI 180.0)) 'single-float))
 301
 302 ;; ;; basic matrix math
 303 ;; (defparameter *rotatex* (make-matrix44 (rotatex-matrix44 (torad 90))))
 304 ;; (defparameter *rotatey* (make-matrix44 (rotatey-matrix44 (torad 90))))
 305 ;; (defparameter *rotatez* (make-matrix44 (rotatez-matrix44 (torad 90))))
 306
 307 ;; (defparameter *vertexx0* (make-vertex3d  (transform-vertex3d
 308 ;;                                                                                (matrix44  *rotatex*)
 309 ;;                                                                                (vertex3d  *vertexx*))))
 310
 311 ;; (defparameter *vertexx1* (make-vertex3d
 312 ;;                                                (transform-vertex3d
 313 ;;                                                 (matrix44  *rotatey*)
 314 ;;                                                 (vertex3d  *vertexx0*))))
 315
 316 ;; (defparameter *vertexx2* (make-vertex3d
 317 ;;                                                (transform-vertex3d
 318 ;;                                                 (matrix44  *rotatez*)
 319 ;;                                                 (vertex3d  *vertexx1*))))
 320
 321 ;; (defparameter *concat-transform*
 322 ;;   (make-matrix44 (matrix44-product
 323 ;;                                (matrix44 *rotatex*)
 324 ;;                                (matrix44-product (matrix44  *rotatey*) (matrix44 *rotatez*)))))
 325
 326 ;; (defparameter *vertexx3* (make-vertex3d
 327 ;;                                                (transform-vertex3d
 328 ;;                                                 (matrix44 *concat-transform*)
 329 ;;                                                 (vertex3d *vertexx0*))))
 330
 331
 332 ;; (defparameter *vector-array* (make-vector3d-array 2 :adjustable t :fill-pointer 1))
 333
 334 ;; (setf (vector3d-aref *vector-array* 0) (vector3d *vectorx*))
 335
 336 ;; ;; to do - should return size
 337 ;; (vector3d-vector-push  (vector3d  *vectory*) *vector-array*)
 338
 339 ;; ;; to do - doesnt extend array properly
 340 ;; (vector3d-vector-push-extend (vector3d *vectorz*) *vector-array*)
 341
 342 ;; ;; ;; iterate across array, apply transforms
 343 ;; (loop
 344 ;;    for i from 0 below (vector3d-array-dimensions *vector-array*)
 345 ;;    do
 346 ;;       (setf (vector3d-aref *vector-array* i)
 347 ;;                 (cl-tuples::transform-vector3d
 348 ;;                      (matrix44 *concat-transform*)
 349 ;;                      (vector3d-aref *vector-array* i))))
 350
 351
 352
 353 ;; ;; quick test case for clos wrapper
 354
 355 ;; (def-tuple-class camera
 356 ;;      (:tuples
 357 ;;       ((up :type cl-tuples::vector3d)
 358 ;;        (forward :type vector3d)
 359 ;;        (location :type vertex3d)
 360 ;;        (vertices :type vertex3d :array 5))
 361 ;;       :slots
 362 ;;       ((focal-length :type single-float :accessor focal-length-of)
 363 ;;        (id :allocation :class :reader id-of))))
 364
 365 ;; ;;*test stanza*
 366 ;; (defparameter *test-camera* (make-instance 'camera))
 367 ;; (setf (up-of *test-camera*) #{ 0.0 0.0 0.0 })
 368 ;; (up-of *test-camera*)
 369 ;; (setf (up-of *test-camera*) #{ 1.0 2.0 3.0 })
 370 ;; (setf (vertices-of *test-camera* 3) #{ 2.0 3.0 -2.5 1.0 })
 371 ;; (vertices-of *test-camera* 3)
 372 ;; (vertices-of *test-camera* 4)
 373 ;; (vertices-of *test-camera* 1)
 374
 375 ;; (defparameter *test-shape* (make-vector3d-array 4))
 376
 377 ;; (setf (vector3d-aref *test-shape* 0) (vector3d* 3.14 0.0 3.14))
 378 ;; (setf (vector3d-aref *test-shape* 1) (vector3d* 3.14 0.0 -3.14))
 379 ;; (setf (vector3d-aref *test-shape* 2) (vector3d* -3.14 0.0 -3.14))
 380 ;; (setf (vector3d-aref *test-shape* 3) (vector3d* -3.14 0.0 3.14))
 381
 382
 383 ;; (defparameter *test-quaternion* (make-quaternion
 384 ;;                                                               (angle-axis-quaternion
 385 ;;                                                                (angle-axis* 0.0 1.0 0.0 (/ 3.14 2.0)))))
 386
 387
 388 ;; (defparameter *test-matrix*
 389 ;;   (make-matrix33
 390 ;;    (quaternion-matrix33 (quaternion *test-quaternion*))))
 391
 392
 393 ;; (loop
 394 ;;    for index from 0 below (vector3d-array-dimensions *test-shape*)
 395 ;;    do
 396 ;;       (setf (vector3d-aref *test-shape* index)
 397 ;;                 (quaternion-transform-vector3d
 398 ;;                      (vector3d-aref *test-shape* index)
 399 ;;                      (quaternion *test-quaternion*))))
 400
 401 ;; (loop
 402 ;;    for index from 0 below (vector3d-array-dimensions *test-shape*)
 403 ;;    do
 404 ;;       (setf (vector3d-aref *test-shape* index)
 405 ;;                 (transform-vector3d
 406 ;;                      (matrix44-matrix33 (matrix44 *rotatey*))
 407 ;;                      (vector3d-aref *test-shape* index))))