diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/entity-test.scm | 19 | ||||
| -rw-r--r-- | tests/physics-test.scm | 20 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 28 | ||||
| -rw-r--r-- | tests/tween-test.scm | 82 |
4 files changed, 149 insertions, 0 deletions
diff --git a/tests/entity-test.scm b/tests/entity-test.scm index 5df8e76..988d1c9 100644 --- a/tests/entity-test.scm +++ b/tests/entity-test.scm @@ -113,4 +113,23 @@ (test-equal "right dvx" 2 (car (cdr (assq 'right imap)))) (test-equal "right dvy" 0 (cdr (cdr (assq 'right imap)))))) +(test-group "entity-skips-pipeline?" + (test-assert "absent skip list" + (not (entity-skips-pipeline? '(#:type a) 'gravity))) + (test-assert "empty skip list" + (not (entity-skips-pipeline? '(#:skip-pipelines ()) 'gravity))) + (test-assert "member" + (entity-skips-pipeline? '(#:skip-pipelines (gravity velocity-x)) 'gravity)) + (test-assert "not member" + (not (entity-skips-pipeline? '(#:skip-pipelines (gravity)) 'velocity-x)))) + +(define-pipeline (fixture-pipeline fixture-skip) (ent) + (entity-set ent #:x 42)) + +(test-group "define-pipeline" + (let ((e '(#:type t #:x 0))) + (test-equal "runs body" 42 (entity-ref (fixture-pipeline e) #:x))) + (let ((e '(#:type t #:x 0 #:skip-pipelines (fixture-skip)))) + (test-equal "skipped" 0 (entity-ref (fixture-pipeline e) #:x)))) + (test-end "entity") diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 67c8377..b40f8d1 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -592,6 +592,26 @@ (test-equal "a pushed up" -3 (entity-ref (car result) #:y 0)) (test-equal "b pushed down" 13 (entity-ref (cdr result) #:y 0))))) +(test-group "skip-pipelines" + (test-group "apply-gravity" + (let* ((e '(#:type t #:vy 0 #:gravity? #t #:skip-pipelines (gravity))) + (r (apply-gravity e))) + (test-equal "skipped: vy unchanged" 0 (entity-ref r #:vy)))) + (test-group "apply-velocity-x" + (let* ((e '(#:type t #:x 10 #:vx 5 #:skip-pipelines (velocity-x))) + (r (apply-velocity-x e))) + (test-equal "skipped: x unchanged" 10 (entity-ref r #:x)))) + (test-group "apply-jump" + (let* ((e '(#:type t #:on-ground? #t #:skip-pipelines (jump))) + (r (apply-jump e #t))) + (test-assert "skipped: no ay" (not (memq #:ay r))))) + (test-group "resolve-pair with entity-collisions skip" + (define (make-solid x y) (list #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (let* ((a (list #:type 'ghost #:x 0 #:y 0 #:width 16 #:height 16 #:solid? #t + #:skip-pipelines '(entity-collisions))) + (b (make-solid 10 0))) + (test-assert "no resolution" (not (resolve-pair a b)))))) + (test-group "resolve-pair" (define (make-solid x y) (list #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index 1a8f7df..8ebeedf 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -266,4 +266,32 @@ (test-assert "does not crash with full scene" (begin (render-debug-scene! renderer scene) #t))))) +(test-group "scene-entities must be plists" + (let* ((cam (make-camera x: 0 y: 0)) + (tileset (make-tileset tilewidth: 16 tileheight: 16 + spacing: 0 tilecount: 100 columns: 10 + image-source: "" image: #f)) + (layer (make-layer name: "ground" width: 1 height: 1 map: '((0)))) + (tilemap (make-tilemap width: 1 height: 1 tilewidth: 16 tileheight: 16 + tileset-source: "" tileset: tileset + layers: (list layer) objects: '())) + (tex 'mock-texture) + (entity (list #:type 'box #:x 10 #:y 20 #:width 16 #:height 16 #:tile-id 1)) + (cell (vector entity 'extra-data 0 100 'linear #t)) + (scene-ok (make-scene entities: (list entity) + tilemap: tilemap camera: cam + tileset-texture: tex camera-target: #f)) + (scene-bad (make-scene entities: (list cell) + tilemap: tilemap camera: cam + tileset-texture: tex camera-target: #f))) + (test-assert "render-scene! works with plist entities" + (begin (render-scene! #f scene-ok) #t)) + (test-error "render-scene! errors when entity list contains a vector" + #t (render-scene! #f scene-bad)) + (test-assert "extracting entity from cell vector fixes the issue" + (let ((scene-fixed (make-scene entities: (list (vector-ref cell 0)) + tilemap: tilemap camera: cam + tileset-texture: tex camera-target: #f))) + (begin (render-scene! #f scene-fixed) #t))))) + (test-end "renderer") diff --git a/tests/tween-test.scm b/tests/tween-test.scm new file mode 100644 index 0000000..ebe62e0 --- /dev/null +++ b/tests/tween-test.scm @@ -0,0 +1,82 @@ +(import srfi-64 + (chicken base)) +(include "entity.scm") +(include "tween.scm") +(import downstroke-entity downstroke-tween) + +(test-begin "tween") + +(test-group "ease functions" + (test-equal "linear mid" 0.5 (ease-linear 0.5)) + (test-equal "quad-in mid" 0.25 (ease-quad-in 0.5)) + (test-equal "quad-out mid" 0.75 (ease-quad-out 0.5)) + (test-equal "quad-in-out mid" 0.5 (ease-quad-in-out 0.5)) + (test-equal "cubic-in mid" 0.125 (ease-cubic-in 0.5)) + (test-assert "sine-in-out endpoints" + (and (= 0.0 (ease-sine-in-out 0)) (= 1.0 (ease-sine-in-out 1)))) + (test-equal "expo-in at 0" 0.0 (ease-expo-in 0)) + (test-equal "expo-out at 1" 1.0 (ease-expo-out 1)) + (test-equal "expo-in-out mid" 0.5 (ease-expo-in-out 0.5)) + (test-equal "cubic-in-out mid" 0.5 (ease-cubic-in-out 0.5)) + (test-equal "cubic-out mid" 0.875 (ease-cubic-out 0.5)) + (test-assert "cubic-in-out stays in [0,1]" + (let loop ((i 0) (ok #t)) + (if (> i 100) ok + (let* ((t (/ i 100)) + (v (ease-cubic-in-out t))) + (loop (+ i 1) (and ok (>= v 0) (<= v 1)))))))) + +(test-group "ease-named" + (test-equal "quad-in-out proc" ease-quad-in-out (ease-named 'quad-in-out))) + +(test-group "ease-resolve" + (test-equal "symbol" ease-cubic-out (ease-resolve 'cubic-out)) + (test-equal "procedure passthrough" ease-linear (ease-resolve ease-linear))) + +(test-group "make-tween / tween-step" + (test-group "linear completes to target" + (let* ((ent (list #:type 'a #:x 0 #:y 10)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 delay: 0 ease: 'linear))) + (receive (tw2 e2) (tween-step tw ent 100) + (test-assert "finished" (tween-finished? tw2)) + (test-equal "x at end" 100.0 (entity-ref e2 #:x)) + (test-equal "y preserved" 10 (entity-ref e2 #:y))))) + + (test-group "delay holds props" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 50)) duration: 100 delay: 40 ease: 'linear))) + (receive (tw2 e2) (tween-step tw ent 30) + (test-assert "not finished" (not (tween-finished? tw2))) + (test-equal "x unchanged during delay" 0 (entity-ref e2 #:x)) + (receive (tw3 e3) (tween-step tw2 e2 9) + (test-assert "still in delay at 39ms" (not (tween-finished? tw3))) + (test-equal "x still 0" 0 (entity-ref e3 #:x)) + (receive (_tw4 e4) (tween-step tw3 e3 50) + (test-assert "past delay, moved" (> (entity-ref e4 #:x) 0))))))) + + (test-group "midpoint linear" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 delay: 0 ease: 'linear))) + (receive (_ e2) (tween-step tw ent 50) + (test-equal "halfway x" 50.0 (entity-ref e2 #:x))))) + + (test-group "on-complete runs once" + (let ((calls 0)) + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 10)) duration: 10 delay: 0 ease: 'linear + on-complete: (lambda (_) (set! calls (+ calls 1)))))) + (receive (tw2 e2) (tween-step tw ent 10) + (test-equal "one call" 1 calls) + (receive (tw3 e3) (tween-step tw2 e2 5) + (test-equal "still one call" 1 calls) + (test-equal "entity stable" e3 e2)))))) + + (test-group "idempotent after finish" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 20)) duration: 10 delay: 0 ease: 'linear))) + (receive (tw2 e2) (tween-step tw ent 10) + (receive (tw3 e3) (tween-step tw2 e2 999) + (test-assert (tween-finished? tw3)) + (test-equal "x stays" 20.0 (entity-ref e3 #:x))))))) + +(test-end "tween") |