From 19a5db8606a82830a5ccd0ed46d8e0cf3c95db0a Mon Sep 17 00:00:00 2001 From: Gene Pasquet Date: Tue, 7 Apr 2026 23:36:12 +0100 Subject: Work on demos --- tests/physics-test.scm | 65 +++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 56 insertions(+), 9 deletions(-) (limited to 'tests/physics-test.scm') diff --git a/tests/physics-test.scm b/tests/physics-test.scm index b40f8d1..04ec6bb 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -75,7 +75,7 @@ (e (resolve-tile-collisions-x e tm)) (e (apply-velocity-y e)) (e (resolve-tile-collisions-y e tm)) - (e (detect-ground e tm))) + (e (detect-on-solid e tm))) e)) ;; Test: apply-gravity @@ -383,8 +383,8 @@ (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-ground and apply-jump -(test-group "detect-ground" +;; New tests for detect-on-solid and apply-jump +(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) ;; tilewidth=tileheight=16 @@ -392,7 +392,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-ground e tm))) + (result (detect-on-solid e tm))) (test-assert "on-ground? is #t" (entity-ref result #:on-ground? #f)))) (test-group "entity in mid-air" @@ -400,7 +400,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-ground e tm))) + (result (detect-on-solid e tm))) (test-assert "on-ground? is #f" (not (entity-ref result #:on-ground? #f))))) (test-group "entity probe spans two tiles, left is solid" @@ -409,7 +409,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-ground e tm))) + (result (detect-on-solid e tm))) (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" @@ -418,8 +418,27 @@ (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-ground e tm))) - (test-assert "on-ground? is #t (right foot on solid)" (entity-ref result #:on-ground? #f))))) + (result (detect-on-solid e tm))) + (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" + ;; All-air tilemap; wide platform top at y=32; player feet (bottom) at y=32 + (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 #:vx 0 #:vy 0 #:gravity? #f)) + (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))) + (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)" + (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" @@ -631,7 +650,35 @@ (result (resolve-pair a b))) (test-assert "result is a pair" (pair? result)) (test-assert "a2 is an entity" (pair? (car result))) - (test-assert "b2 is an entity" (pair? (cdr result)))))) + (test-assert "b2 is an entity" (pair? (cdr result))))) + + (test-group "immovable" + (define (make-static x y) + (list #:type 'wall #:x x #:y y #:width 16 #:height 16 #:solid? #t #:immovable? #t)) + (define (make-box x y) + (list #:type 'box #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (test-group "both immovable and overlapping: #f" + (let* ((a (make-static 0 0)) + (b (make-static 8 0))) + (test-assert "no resolution" (not (resolve-pair a b))))) + (test-group "wall(a) left, box(b) overlaps: only box moves" + (let* ((wall (make-static 0 0)) + (box (make-box 8 0)) + (r (resolve-pair wall box)) + (a2 (car r)) + (b2 (cdr r))) + (test-assert "result is pair" (pair? r)) + (test-equal "a2 is wall (unchanged x)" 0 (entity-ref a2 #:x)) + (test-assert "b2 is box (pushed right)" (> (entity-ref b2 #:x) 8)))) + (test-group "box(a) first, wall(b) second" + (let* ((wall (make-static 0 0)) + (box (make-box 8 0)) + (r (resolve-pair box wall)) + (a2 (car r)) + (b2 (cdr r))) + (test-assert "result is pair" (pair? r)) + (test-equal "b2 is wall (unchanged x)" 0 (entity-ref b2 #:x)) + (test-assert "a2 is box (pushed right)" (> (entity-ref a2 #:x) 8)))))) (test-group "aabb-overlap?" (test-group "two boxes clearly overlapping" -- cgit v1.2.3