Added tweens

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")