aboutsummaryrefslogtreecommitdiff
path: root/tests/physics-test.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/physics-test.scm')
-rw-r--r--tests/physics-test.scm119
1 files changed, 47 insertions, 72 deletions
diff --git a/tests/physics-test.scm b/tests/physics-test.scm
index a5b40e9..6d1da86 100644
--- a/tests/physics-test.scm
+++ b/tests/physics-test.scm
@@ -67,22 +67,26 @@
tileset-source: "" tileset: #f
layers: (list layer) objects: '())))
+;; Helper to wrap a tilemap (and optional entities) in a scene for pipeline functions
+(define (test-scene #!key (entities '()) (tilemap #f))
+ (make-scene entities: entities tilemap: tilemap camera-target: #f))
+
;; Integration helper: simulate one frame of physics
(define (tick e tm held?)
(let* ((e (apply-input-to-entity e held?))
- (e (apply-gravity e))
- (e (apply-velocity-x e))
- (e (resolve-tile-collisions-x e tm))
- (e (apply-velocity-y e))
- (e (resolve-tile-collisions-y e tm))
- (e (detect-on-solid e tm)))
+ (e (apply-gravity e #f 0))
+ (e (apply-velocity-x e #f 0))
+ (e (resolve-tile-collisions-x e (test-scene tilemap: tm) 0))
+ (e (apply-velocity-y e #f 0))
+ (e (resolve-tile-collisions-y e (test-scene tilemap: tm) 0))
+ (e (detect-on-solid e (test-scene tilemap: tm) 0)))
e))
;; Test: apply-gravity
(test-group "apply-gravity"
(test-group "gravity? true, vy starts at 0"
(let* ((e '(#:type rock #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #t))
- (result (apply-gravity e)))
+ (result (apply-gravity e #f 0)))
(test-equal "vy increased by gravity" *gravity* (entity-ref result #:vy))
(test-equal "x unchanged" 0 (entity-ref result #:x))
(test-equal "y unchanged" 0 (entity-ref result #:y))
@@ -90,44 +94,44 @@
(test-group "gravity? true, vy already has value"
(let* ((e '(#:type rock #:x 0 #:y 0 #:vx 0 #:vy 3 #:gravity? #t))
- (result (apply-gravity e)))
+ (result (apply-gravity e #f 0)))
(test-equal "vy increased by gravity" 4 (entity-ref result #:vy))))
(test-group "gravity? false"
(let* ((e '(#:type static #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #f))
- (result (apply-gravity e)))
+ (result (apply-gravity e #f 0)))
(test-equal "vy unchanged" 0 (entity-ref result #:vy))))
(test-group "no gravity? field at all"
(let* ((e '(#:type static #:x 5 #:y 5))
- (result (apply-gravity e)))
+ (result (apply-gravity e #f 0)))
(test-equal "entity unchanged" e result))))
(test-group "apply-velocity-x"
(test-group "basic horizontal movement"
(let* ((e '(#:type rock #:x 10 #:y 20 #:vx 5 #:vy -2))
- (result (apply-velocity-x e)))
+ (result (apply-velocity-x e #f 0)))
(test-equal "x moved by vx" 15 (entity-ref result #:x))
(test-equal "y unchanged" 20 (entity-ref result #:y))
(test-equal "vy unchanged" -2 (entity-ref result #:vy))))
(test-group "zero vx"
(let* ((e '(#:type rock #:x 10 #:y 20 #:vx 0 #:vy 3))
- (result (apply-velocity-x e)))
+ (result (apply-velocity-x e #f 0)))
(test-equal "x unchanged" 10 (entity-ref result #:x))
(test-equal "y unchanged" 20 (entity-ref result #:y)))))
(test-group "apply-velocity-y"
(test-group "basic vertical movement"
(let* ((e '(#:type rock #:x 10 #:y 20 #:vx 3 #:vy -5))
- (result (apply-velocity-y e)))
+ (result (apply-velocity-y e #f 0)))
(test-equal "x unchanged" 10 (entity-ref result #:x))
(test-equal "y moved by vy" 15 (entity-ref result #:y))
(test-equal "vx unchanged" 3 (entity-ref result #:vx))))
(test-group "zero vy"
(let* ((e '(#:type rock #:x 10 #:y 20 #:vx 3 #:vy 0))
- (result (apply-velocity-y e)))
+ (result (apply-velocity-y e #f 0)))
(test-equal "x unchanged" 10 (entity-ref result #:x))
(test-equal "y unchanged" 20 (entity-ref result #:y)))))
@@ -198,20 +202,20 @@
(test-group "no collision: entity unchanged"
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 2 #:vy 0)))
- (let ((result (resolve-tile-collisions-x e tm)))
+ (let ((result (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)))
(test-equal "x unchanged" 0 (entity-ref result #:x))
(test-equal "vx unchanged" 2 (entity-ref result #:vx)))))
(test-group "zero vx: skipped entirely"
(let* ((tm (make-test-tilemap '((0 1 0) (0 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 0)))
- (test-equal "entity eq? when vx=0" e (resolve-tile-collisions-x e tm))))
+ (test-equal "entity eq? when vx=0" e (resolve-tile-collisions-x e (test-scene tilemap: tm) 0))))
(test-group "collision moving right: push left"
;; solid at col=1 (x=16..31); entity at x=20 overlaps it, vx>0
(let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0))))
(e '(#:type player #:x 20 #:y 16 #:width 16 #:height 16 #:vx 5 #:vy 0)))
- (let ((result (resolve-tile-collisions-x e tm)))
+ (let ((result (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)))
(test-equal "pushed left of solid tile" 0 (entity-ref result #:x))
(test-equal "vx zeroed" 0 (entity-ref result #:vx)))))
@@ -219,7 +223,7 @@
;; solid at col=1 (x=16..31); entity at x=16 overlaps it, vx<0
(let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0))))
(e '(#:type player #:x 16 #:y 16 #:width 16 #:height 16 #:vx -5 #:vy 0)))
- (let ((result (resolve-tile-collisions-x e tm)))
+ (let ((result (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)))
(test-equal "pushed right of solid tile" 32 (entity-ref result #:x))
(test-equal "vx zeroed" 0 (entity-ref result #:vx)))))
@@ -227,7 +231,7 @@
;; solid at col=1; entity at x=20.5 (float), vx>0
(let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0))))
(e '(#:type player #:x 20.5 #:y 16 #:width 16 #:height 16 #:vx 2 #:vy 0)))
- (let ((result (resolve-tile-collisions-x e tm)))
+ (let ((result (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)))
(test-equal "pushed left of solid tile" 0 (entity-ref result #:x))
(test-equal "vx zeroed" 0 (entity-ref result #:vx)))))
@@ -235,12 +239,12 @@
;; wall at col=3; 20px-wide entity at x=28 spans cols 1 and 2, no collision
(let* ((tm (make-test-tilemap '((0 0 0 1) (0 0 0 1) (0 0 0 1))))
(e '(#:type player #:x 28 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0)))
- (let ((result (resolve-tile-collisions-x e tm)))
+ (let ((result (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)))
(test-equal "no collision yet" 28 (entity-ref result #:x))))
;; entity moved to x=34 now spans cols 2 and 3 (solid), pushed left
(let* ((tm (make-test-tilemap '((0 0 0 1) (0 0 0 1) (0 0 0 1))))
(e '(#:type player #:x 34 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0)))
- (let ((result (resolve-tile-collisions-x e tm)))
+ (let ((result (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)))
(test-equal "pushed left of wall" 28 (entity-ref result #:x))
(test-equal "vx zeroed" 0 (entity-ref result #:vx))))))
@@ -248,20 +252,20 @@
(test-group "no collision: entity unchanged"
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 2)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "y unchanged" 0 (entity-ref result #:y))
(test-equal "vy unchanged" 2 (entity-ref result #:vy)))))
(test-group "zero vy: skipped entirely"
(let* ((tm (make-test-tilemap '((1 0 0) (0 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 0)))
- (test-equal "entity eq? when vy=0" e (resolve-tile-collisions-y e tm))))
+ (test-equal "entity eq? when vy=0" e (resolve-tile-collisions-y e (test-scene tilemap: tm) 0))))
(test-group "collision moving down: push up"
;; solid at row=1 (y=16..31); entity at y=20 overlaps it, vy>0
(let* ((tm (make-test-tilemap '((0 0 0) (1 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 20 #:width 16 #:height 16 #:vx 0 #:vy 5)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "pushed above solid tile" 0 (entity-ref result #:y))
(test-equal "vy zeroed" 0 (entity-ref result #:vy)))))
@@ -269,7 +273,7 @@
;; solid at row=1 (y=16..31); entity at y=16 overlaps it from below, vy<0
(let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0))))
(e '(#:type player #:x 16 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy -5)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "pushed below solid tile" 32 (entity-ref result #:y))
(test-equal "vy zeroed" 0 (entity-ref result #:vy)))))
@@ -277,7 +281,7 @@
;; solid at row=1; entity at y=20.5 (float), vy>0
(let* ((tm (make-test-tilemap '((0 0 0) (1 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 20.5 #:width 16 #:height 16 #:vx 0 #:vy 3)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "pushed above solid tile" 0 (entity-ref result #:y))
(test-equal "vy zeroed" 0 (entity-ref result #:vy)))))
@@ -285,12 +289,12 @@
;; floor at row=3; 20px-tall entity at y=28 spans rows 1 and 2, no collision
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0) (1 1 1))))
(e '(#:type player #:x 0 #:y 28 #:width 16 #:height 20 #:vx 0 #:vy 3)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "no collision yet" 28 (entity-ref result #:y))))
;; entity at y=34 now spans rows 2 and 3 (solid), pushed up
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0) (1 1 1))))
(e '(#:type player #:x 0 #:y 34 #:width 16 #:height 20 #:vx 0 #:vy 3)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "pushed above floor" 28 (entity-ref result #:y))
(test-equal "vy zeroed" 0 (entity-ref result #:vy))))))
@@ -301,7 +305,7 @@
;; Correct: snap to top of row 2 → y=16. Bug was: fold overwrote row 2 snap with row 3 snap → y=32 (inside row 2).
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0) (1 0 0) (0 0 0))))
(e '(#:type player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20)))
- (let ((result (resolve-tile-collisions-y e tm)))
+ (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)))
(test-equal "snapped to first solid row" 16 (entity-ref result #:y))
(test-equal "vy zeroed" 0 (entity-ref result #:vy)))))
@@ -395,7 +399,7 @@
(test-equal "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0))
(test-equal "b x unchanged" 5 (entity-ref (list-ref result 1) #:x 0)))))
-;; New tests for detect-on-solid and apply-jump
+;; Tests for detect-on-solid
(test-group "detect-on-solid"
(test-group "entity standing on solid tile"
;; Tilemap: 3 rows, row 2 is solid (tile=1), rows 0-1 empty (tile=0)
@@ -404,7 +408,7 @@
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 1 1))))
(e (list #:type 'player #:x 0 #:y 16 #:width 16 #:height 16
#:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f))
- (result (detect-on-solid e tm)))
+ (result (detect-on-solid e (test-scene tilemap: tm) 0)))
(test-assert "on-ground? is #t" (entity-ref result #:on-ground? #f))))
(test-group "entity in mid-air"
@@ -412,7 +416,7 @@
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 1 1))))
(e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16
#:vx 0 #:vy 0 #:gravity? #t #:on-ground? #t))
- (result (detect-on-solid e tm)))
+ (result (detect-on-solid e (test-scene tilemap: tm) 0)))
(test-assert "on-ground? is #f" (not (entity-ref result #:on-ground? #f)))))
(test-group "entity probe spans two tiles, left is solid"
@@ -421,7 +425,7 @@
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0))))
(e (list #:type 'player #:x 0 #:y 16 #:width 16 #:height 16
#:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f))
- (result (detect-on-solid e tm)))
+ (result (detect-on-solid e (test-scene tilemap: tm) 0)))
(test-assert "on-ground? is #t (left foot on solid)" (entity-ref result #:on-ground? #f))))
(test-group "entity probe spans two tiles, right is solid"
@@ -430,7 +434,7 @@
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 1 0))))
(e (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16
#:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f))
- (result (detect-on-solid e tm)))
+ (result (detect-on-solid e (test-scene tilemap: tm) 0)))
(test-assert "on-ground? is #t (right foot on solid)" (entity-ref result #:on-ground? #f))))
(test-group "standing on solid entity (no tile): moving platform / crate"
@@ -441,58 +445,33 @@
(player (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16
#:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f))
(ents (list platform player))
- (result (detect-on-solid player tm ents)))
+ (result (detect-on-solid player (test-scene tilemap: tm entities: ents) 0)))
(test-assert "on-ground? from entity top" (entity-ref result #:on-ground? #f))))
- (test-group "two-arg detect-on-solid skips entity list (backward compatible)"
+ (test-group "scene with empty entity list: no entity below"
(let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0))))
(platform (list #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 #:solid? #t))
(player (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16
#:gravity? #t #:on-ground? #f))
- (result (detect-on-solid player tm)))
- (test-assert "no third arg → not on ground" (not (entity-ref result #:on-ground? #f))))))
-
-(test-group "apply-jump"
- (test-group "on-ground and pressed → impulse applied"
- (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16
- #:vx 0 #:vy 0 #:on-ground? #t))
- (result (apply-jump e #t)))
- (test-equal "ay is -jump-force" (- *jump-force*) (entity-ref result #:ay 0))))
-
- (test-group "on-ground but not pressed → unchanged"
- (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16
- #:vx 0 #:vy 0 #:on-ground? #t))
- (result (apply-jump e #f)))
- (test-equal "vy unchanged" 0 (entity-ref result #:vy 0))))
-
- (test-group "in-air and pressed → no double jump"
- (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16
- #:vx 0 #:vy -5 #:on-ground? #f))
- (result (apply-jump e #t)))
- (test-equal "vy unchanged (no double jump)" -5 (entity-ref result #:vy 0))))
-
- (test-group "in-air and not pressed → unchanged"
- (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16
- #:vx 0 #:vy -5 #:on-ground? #f))
- (result (apply-jump e #f)))
- (test-equal "vy unchanged" -5 (entity-ref result #:vy 0)))))
+ (result (detect-on-solid player (test-scene tilemap: tm) 0)))
+ (test-assert "empty entity list → not on ground" (not (entity-ref result #:on-ground? #f))))))
(test-group "apply-acceleration"
(test-group "gravity? #t, ay set: consumed into vy and cleared"
(let* ((e '(#:type player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #t))
- (result (apply-acceleration e)))
+ (result (apply-acceleration e #f 0)))
(test-equal "vy += ay" 8 (entity-ref result #:vy 0))
(test-equal "ay cleared" 0 (entity-ref result #:ay 0))))
(test-group "gravity? #t, ay is 0: vy unchanged"
(let* ((e '(#:type player #:x 0 #:y 0 #:vy 3 #:ay 0 #:gravity? #t))
- (result (apply-acceleration e)))
+ (result (apply-acceleration e #f 0)))
(test-equal "vy unchanged" 3 (entity-ref result #:vy 0))
(test-equal "ay still 0" 0 (entity-ref result #:ay 0))))
(test-group "gravity? #f: entity unchanged"
(let* ((e '(#:type player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #f))
- (result (apply-acceleration e)))
+ (result (apply-acceleration e #f 0)))
(test-equal "entity unchanged" e result))))
(test-group "pixel->tile"
@@ -626,16 +605,12 @@
(test-group "skip-pipelines"
(test-group "apply-gravity"
(let* ((e '(#:type t #:vy 0 #:gravity? #t #:skip-pipelines (gravity)))
- (r (apply-gravity e)))
+ (r (apply-gravity e #f 0)))
(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)))
+ (r (apply-velocity-x e #f 0)))
(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