Enrich entities pipelining to provide scene context to processors

4 files changed, 58 insertions, 34 deletions

diff --git a/tests/animation-test.scm b/tests/animation-test.scm
index aaaba41..9a71dec 100644
--- a/tests/animation-test.scm
+++ b/tests/animation-test.scm
@@ -9,13 +9,13 @@
 
 (test-group "frame->tile-id"
   (test-group "tile IDs only"
-    (test-equal "first frame, frames (0)" 1 (frame->tile-id '(0) 0))
-    (test-equal "wraps around" 1 (frame->tile-id '(0 1) 2))
-    (test-equal "frame 1 of (27 28)" 29 (frame->tile-id '(27 28) 1)))
+    (test-equal "first frame, frames (0)" 0 (frame->tile-id '(0) 0))
+    (test-equal "wraps around" 0 (frame->tile-id '(0 1) 2))
+    (test-equal "frame 1 of (27 28)" 28 (frame->tile-id '(27 28) 1)))
   (test-group "tile IDs and durations"
-    (test-equal "first frame, frames (0)" 1 (frame->tile-id '((0 10)) 0))
-    (test-equal "wraps around" 1 (frame->tile-id '((0 10) (1 10)) 2))
-    (test-equal "frame 1 of (27 28)" 29 (frame->tile-id '((27 10) (28 10)) 1))))
+    (test-equal "first frame, frames (0)" 0 (frame->tile-id '((0 10)) 0))
+    (test-equal "wraps around" 0 (frame->tile-id '((0 10) (1 10)) 2))
+    (test-equal "frame 1 of (27 28)" 28 (frame->tile-id '((27 10) (28 10)) 1))))
 
 (test-group "frame->duration"
   (test-equal "first frame, frames (0)" 100 (frame->duration '((0 100)) 0))
@@ -31,17 +31,36 @@
       (test-equal "resets tick" 0 (entity-ref switched #:anim-tick)))))
 
 (test-group "animate-entity"
-  (let* ((anims '((#:name walk #:frames (0 1) #:duration 4)))
-         (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0))
-         (stepped (animate-entity entity anims)))
-    (test-equal "increments tick" 1 (entity-ref stepped #:anim-tick))
-    (test-equal "sets tile-id on first tick" 1 (entity-ref stepped #:tile-id)))
-  (let* ((anims '((#:name walk #:frames (0 1) #:duration 2)))
-         (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 1))
-         (advanced (animate-entity entity anims)))
-    (test-equal "advances frame when tick reaches duration" 1 (entity-ref advanced #:anim-frame))
-    (test-equal "resets tick on frame advance" 0 (entity-ref advanced #:anim-tick)))
-  (let* ((entity (list #:type 'player)))
-    (test-equal "unchanged entity without anim-name" entity (animate-entity entity '()))))
+  (test-group "Single frames"
+    (let* ((anims '((#:name walk #:frames (2 3) #:duration 4)))
+           (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0))
+           (stepped (animate-entity entity anims)))
+      (test-equal "increments tick" 1 (entity-ref stepped #:anim-tick))
+      (test-equal "sets tile-id on first tick" 2 (entity-ref stepped #:tile-id)))
+    (let* ((anims '((#:name walk #:frames (0 1) #:duration 2)))
+           (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 1))
+           (advanced (animate-entity entity anims)))
+      (test-equal "advances frame when tick reaches duration" 1 (entity-ref advanced #:anim-frame))
+      (test-equal "resets tick on frame advance" 0 (entity-ref advanced #:anim-tick))))
+  (test-group "Frames with duration"
+    (let* ((anims '((#:name walk #:frames ((0 10) (1 20)) #:duration 4)))
+           (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 9))
+           (stepped (animate-entity entity anims)))
+      (test-equal "ticks resets on frame switch" 0 (entity-ref stepped #:anim-tick))
+      (test-equal "sets tile-id on 10th tick" 1 (entity-ref stepped #:tile-id))
+      (test-equal "sets duration to frame duration" 20 (entity-ref stepped #:duration))))
+  (test-group "Empty"
+    (let* ((entity (list #:type 'player)))
+      (test-equal "unchanged entity without anim-name" entity (animate-entity entity '())))))
+
+(test-group "animation pipeline"
+  (test-group "animated entity"
+    (let* ((anims '((#:name walk #:frames (2 3) #:duration 4)))
+           (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0 #:animations anims))
+	   (stepped-entity (apply-animation entity #f 10)))
+      (test-equal "Updated animated entity" 1 (entity-ref stepped-entity #:anim-tick)))
+    (let* ((entity (list #:type 'static))
+	   (stepped-entity (apply-animation entity #f 10)))
+      (test-equal "unchanged static entity" #f (entity-ref stepped-entity #:anim-tick)))))
 
 (test-end "animation")
diff --git a/tests/entity-test.scm b/tests/entity-test.scm
index 9c7607c..3b83dff 100644
--- a/tests/entity-test.scm
+++ b/tests/entity-test.scm
@@ -82,12 +82,12 @@
 (test-group "entity-set-many"
   (test-group "Set multiple entities with lists"
     (let ((e (entity-set-many '(#:x 10 #:y 20) '((#:x 15) (#:y 25)))))
-      (test-equal "value x updated" (entity-ref e #:x) 15)
-      (test-equal "value y updated" (entity-ref e #:y) 25)))
+      (test-equal "value x updated" 15 (entity-ref e #:x))
+      (test-equal "value y updated" 25 (entity-ref e #:y))))
   (test-group "Set multiple entities with cons"
     (let ((e (entity-set-many '(#:x 10 #:y 20) (list (cons #:x 15) (cons #:y 25)))))
-      (test-equal "value x updated" (entity-ref e #:x) 15)
-      (test-equal "value y updated" (entity-ref e #:y) 25))))
+      (test-equal "value x updated" 15 (entity-ref e #:x))
+      (test-equal "value y updated" 25 (entity-ref e #:y)))))
 
 ;; Test: entity-update applies transformations
 (test-group "entity-update"
@@ -118,7 +118,7 @@
   (test-assert "not member"
     (not (entity-skips-pipeline? '(#:skip-pipelines (gravity)) 'velocity-x))))
 
-(define-pipeline (fixture-pipeline fixture-skip) (ent)
+(define-pipeline (fixture-pipeline fixture-skip) (scene_ ent)
   (entity-set ent #:x 42))
 
 (test-group "define-pipeline"
@@ -127,7 +127,7 @@
   (let ((e '(#:type t #:x 0 #:skip-pipelines (fixture-skip))))
     (test-equal "skipped" 0 (entity-ref (fixture-pipeline e) #:x))))
 
-(define-pipeline (guarded-pipeline guarded-skip) (ent)
+(define-pipeline (guarded-pipeline guarded-skip) (scene_ ent)
     guard: (entity-ref ent #:active? #f)
   (entity-set ent #:x 99))
 
diff --git a/tests/input-test.scm b/tests/input-test.scm
index 44af6e8..0d1e4b5 100644
--- a/tests/input-test.scm
+++ b/tests/input-test.scm
@@ -117,6 +117,11 @@
                   #f
                   (input-pressed? state3 'up)))))
 
+(define (make-physics-entity)
+  (entity-set-many (make-entity 0 0 16 16)
+		   '((#:vx 0) (#:vy 0)
+		     (#:input-map ((left . (-2 . 0)) (right . (2 . 0)))))))
+
 ;; Test: apply-input-to-entity applies input to entity
 (test-group "apply-input-to-entity"
   (test-group "no input-map: entity unchanged"
@@ -125,35 +130,35 @@
       (test-equal "entity returned as-is" e out)))
 
   (test-group "no actions held: velocity is zero"
-    (let* ((e   (make-entity 0 0 16 16))
+    (let* ((e   (make-physics-entity))
            (out (apply-input-to-entity e (lambda (a) #f))))
       (test-equal "vx is 0" 0 (entity-ref out #:vx))
       (test-equal "vy is 0" 0 (entity-ref out #:vy))))
 
   (test-group "right held: vx=2 vy=0"
-    (let* ((e   (make-entity 0 0 16 16))
+    (let* ((e   (make-physics-entity))
            (out (apply-input-to-entity e (lambda (a) (eq? a 'right)))))
       (test-equal "vx is 2" 2 (entity-ref out #:vx))
       (test-equal "vy is 0" 0 (entity-ref out #:vy))))
 
   (test-group "right+down held: vx=2 vy unchanged"
-    (let* ((e   (make-entity 0 0 16 16))
+    (let* ((e   (make-physics-entity))
            (out (apply-input-to-entity e (lambda (a) (memv a '(right down))))))
       (test-equal "vx is 2" 2 (entity-ref out #:vx))
       (test-equal "vy is unchanged (input handler does not set vy)" 0 (entity-ref out #:vy))))
 
   (test-group "right held: facing set to 1"
-    (let* ((e   (make-entity 0 0 16 16))
+    (let* ((e   (make-physics-entity))
            (out (apply-input-to-entity e (lambda (a) (eq? a 'right)))))
       (test-equal "facing is 1" 1 (entity-ref out #:facing 0))))
 
   (test-group "left held: facing set to -1"
-    (let* ((e   (make-entity 0 0 16 16))
+    (let* ((e   (make-physics-entity))
            (out (apply-input-to-entity e (lambda (a) (eq? a 'left)))))
       (test-equal "facing is -1" -1 (entity-ref out #:facing 0))))
 
   (test-group "no key held: facing retains previous value"
-    (let* ((e   (entity-set (make-entity 0 0 16 16) #:facing 1))
+    (let* ((e   (entity-set (make-physics-entity) #:facing 1))
            (out (apply-input-to-entity e (lambda (a) #f))))
       (test-equal "facing stays 1 when vx=0" 1 (entity-ref out #:facing 0)))))
 
diff --git a/tests/world-test.scm b/tests/world-test.scm
index 557a121..bfbb336 100644
--- a/tests/world-test.scm
+++ b/tests/world-test.scm
@@ -110,7 +110,7 @@
 
 ;; Test: scene with entities and tilemap
 (test-group "scene-with-data"
-  (let* ((player (make-entity 100 100 16 16))
+  (let* ((player (entity-set (make-entity 100 100 16 16) #:type 'player))
          (enemy '(#:type enemy #:x 200 #:y 200))
          (tilemap "mock-tilemap")
          (scene (make-scene entities: (list player enemy)
@@ -159,7 +159,7 @@
   (let* ((e1 '(#:type player #:x 100 #:y 100))
          (e2 '(#:type enemy #:x 200 #:y 200))
          (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f))
-         (move-right (lambda (entity)
+         (move-right (lambda (scene entity)
                       (let ((x (entity-ref entity #:x))
                             (y (entity-ref entity #:y))
                             (type (entity-ref entity #:type)))
@@ -184,7 +184,7 @@
   (let* ((e1 '(#:type player #:x 100))
          (e2 '(#:type enemy #:x 200))
          (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f))
-         (scene2 (scene-map-entities scene (lambda (e) e))))
+         (scene2 (scene-map-entities scene (lambda (scene e) e))))
 
     (test-equal "entity count unchanged" 2 (length (scene-entities scene2)))
     (test-equal "first entity unchanged"
@@ -200,7 +200,7 @@
     (test-equal "entity added" 1 (length (scene-entities scene)))
 
     (let ((scene (scene-map-entities scene
-                   (lambda (e)
+                   (lambda (scene e)
                      (let ((x (entity-ref e #:x))
                            (y (entity-ref e #:y))
                            (type (entity-type e)))