Work on demos

1 files changed, 56 insertions, 9 deletions

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"