diff options
Diffstat (limited to 'tests/physics-test.scm')
| -rw-r--r-- | tests/physics-test.scm | 247 |
1 files changed, 126 insertions, 121 deletions
diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 88ddcce..4ab4b17 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -41,6 +41,11 @@ (include "entity.scm") (import downstroke-entity) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + ;; Load world module first (include "world.scm") (import downstroke-world) @@ -74,82 +79,82 @@ ;; Integration helper: simulate one frame of physics (define (tick e tm held?) (let* ((e (apply-input-to-entity e held?)) - (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 (apply-gravity #f e 0)) + (e (apply-velocity-x #f e 0)) + (e (resolve-tile-collisions-x (test-scene tilemap: tm) e 0)) + (e (apply-velocity-y #f e 0)) + (e (resolve-tile-collisions-y (test-scene tilemap: tm) e 0)) + (e (detect-on-solid (test-scene tilemap: tm) e 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 #f 0))) + (let* ((e (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #t)) + (result (apply-gravity #f e 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)) (test-equal "vx unchanged" 0 (entity-ref result #:vx)))) (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 #f 0))) + (let* ((e (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 3 #:gravity? #t)) + (result (apply-gravity #f e 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 #f 0))) + (let* ((e (entity #:type 'static #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #f)) + (result (apply-gravity #f e 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 #f 0))) + (let* ((e (entity #:type 'static #:x 5 #:y 5)) + (result (apply-gravity #f e 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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 5 #:vy -2)) + (result (apply-velocity-x #f e 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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 0 #:vy 3)) + (result (apply-velocity-x #f e 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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy -5)) + (result (apply-velocity-y #f e 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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy 0)) + (result (apply-velocity-y #f e 0))) (test-equal "x unchanged" 10 (entity-ref result #:x)) (test-equal "y unchanged" 20 (entity-ref result #:y))))) (test-group "apply-velocity" (test-group "basic movement" - (let* ((e '(#:type rock #:x 10 #:y 20 #:vx 3 #:vy -2)) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy -2)) (result (apply-velocity e))) (test-equal "x moved by vx" 13 (entity-ref result #:x)) (test-equal "y moved by vy" 18 (entity-ref result #:y)))) (test-group "zero velocity" - (let* ((e '(#:type rock #:x 10 #:y 20 #:vx 0 #:vy 0)) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 0 #:vy 0)) (result (apply-velocity e))) (test-equal "x unchanged" 10 (entity-ref result #:x)) (test-equal "y unchanged" 20 (entity-ref result #:y)))) (test-group "no velocity fields (defaults to 0)" - (let* ((e '(#:type static #:x 5 #:y 5)) + (let* ((e (entity #:type 'static #:x 5 #:y 5)) (result (apply-velocity e))) (test-equal "x unchanged" 5 (entity-ref result #:x)) (test-equal "y unchanged" 5 (entity-ref result #:y))))) @@ -201,100 +206,100 @@ (test-group "resolve-tile-collisions-x" (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 2 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 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 (test-scene tilemap: tm) 0)))) + (e (entity #: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 (test-scene tilemap: tm) e 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 20 #:y 16 #:width 16 #:height 16 #:vx 5 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (test-equal "pushed left of solid tile" 0 (entity-ref result #:x)) (test-equal "vx zeroed" 0 (entity-ref result #:vx))))) (test-group "collision moving left: push right" ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 16 #:y 16 #:width 16 #:height 16 #:vx -5 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (test-equal "pushed right of solid tile" 32 (entity-ref result #:x)) (test-equal "vx zeroed" 0 (entity-ref result #:vx))))) (test-group "floating-point x position" ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 20.5 #:y 16 #:width 16 #:height 16 #:vx 2 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (test-equal "pushed left of solid tile" 0 (entity-ref result #:x)) (test-equal "vx zeroed" 0 (entity-ref result #:vx))))) (test-group "entity spanning two columns: both checked" ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 28 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 34 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (test-equal "pushed left of wall" 28 (entity-ref result #:x)) (test-equal "vx zeroed" 0 (entity-ref result #:vx)))))) (test-group "resolve-tile-collisions-y" (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 2))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 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 (test-scene tilemap: tm) 0)))) + (e (entity #: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 (test-scene tilemap: tm) e 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 20 #:width 16 #:height 16 #:vx 0 #:vy 5))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "pushed above solid tile" 0 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) (test-group "collision moving up: push down" ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 16 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy -5))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "pushed below solid tile" 32 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) (test-group "floating-point y position" ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 20.5 #:width 16 #:height 16 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "pushed above solid tile" 0 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) (test-group "entity spanning two rows: both checked" ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 28 #:width 16 #:height 20 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 20 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "pushed above floor" 28 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy)))))) @@ -304,8 +309,8 @@ ;; After apply-velocity-y the entity lands at y=34 (overlapping both rows 2 and 3). ;; 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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "snapped to first solid row" 16 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) @@ -315,8 +320,8 @@ ;; 3x4 tilemap: air on rows 0-2, solid floor on row 3 ;; Player starts at y=0, 16px tall; floor is at y=48 (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0) (1 1 1)))) - (e0 '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 - #:vx 0 #:vy 0 #:gravity? #t #:input-map ()))) + (e0 (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:input-map '()))) (let loop ((e e0) (n 10)) (if (= n 0) (begin @@ -328,8 +333,8 @@ ;; Player already on floor, should stay there (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 1 1)))) ;; Floor at row 2 (y=32); player at y=16, height=16: bottom at y=32 - (e0 '(#:type player #:x 0 #:y 16 #:width 16 #:height 16 - #:vx 0 #:vy 0 #:gravity? #t #:input-map ()))) + (e0 (entity #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:input-map '()))) (let loop ((e e0) (n 10)) (if (= n 0) (test-assert "player stays on floor" (<= (entity-ref e #:y) 16)) @@ -350,7 +355,7 @@ (test-group "resolve-entity-collisions" (define (make-solid x y w h) - (list #:type 'block #:x x #:y y #:width w #:height h #:solid? #t)) + (entity #:type 'block #:x x #:y y #:width w #:height h #:solid? #t)) (test-group "no overlap: entities unchanged" (let* ((a (make-solid 0 0 16 16)) @@ -383,9 +388,9 @@ (test-group "immovable: landing uses vertical separation when horizontal overlap is shallower" ;; Without the landing rule, ovx < ovy would pick horizontal separation and shove the ;; mover sideways off a narrow platform. Box center remains above shelf center → snap on top. - (let* ((shelf (list #:type 'static #:x 100 #:y 200 #:width 16 #:height 16 - #:solid? #t #:immovable? #t)) - (box (list #:type 'box #:x 92 #:y 196 #:width 16 #:height 16 + (let* ((shelf (entity #:type 'static #:x 100 #:y 200 #:width 16 #:height 16 + #:solid? #t #:immovable? #t)) + (box (entity #:type 'box #:x 92 #:y 196 #:width 16 #:height 16 #:solid? #t #:immovable? #f #:vx 0 #:vy 0)) (result (resolve-entity-collisions (list shelf box))) (box2 (list-ref result 1))) @@ -394,7 +399,7 @@ (test-group "non-solid entity ignored" (let* ((a (make-solid 0 0 16 16)) - (b (list #:type 'goal #:x 5 #:y 5 #:width 16 #:height 16)) + (b (entity #:type 'goal #:x 5 #:y 5 #:width 16 #:height 16)) (result (resolve-entity-collisions (list a b)))) (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))))) @@ -406,72 +411,72 @@ ;; tilewidth=tileheight=16 ;; Entity standing: y=16, h=16 → bottom at y=32, probe at y=33 → row=2 → solid (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) e 0))) (test-assert "on-ground? is #t" (entity-ref result #:on-ground? #f)))) (test-group "entity in mid-air" ;; Entity in mid-air: y=0, h=16 → bottom at 16, probe at 17 → row=1 → empty (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #t)) + (result (detect-on-solid (test-scene tilemap: tm) e 0))) (test-assert "on-ground? is #f" (not (entity-ref result #:on-ground? #f))))) (test-group "entity probe spans two tiles, left is solid" ;; Entity at x=0, w=16: left foot at col 0; probe below ;; Row with solid at col 0, empty at col 1: should be on-ground (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) e 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" ;; Entity at x=8, w=16: left foot at col 0, right foot at col 1; probe below ;; Row with empty at col 0, solid at col 1: should be on-ground (right foot on solid) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) e 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" ;; 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)) + (platform (entity #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 + #:solid? #t #:vx 0 #:vy 0 #:gravity? #f)) + (player (entity #: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 (test-scene tilemap: tm entities: ents) 0))) + (result (detect-on-solid (test-scene tilemap: tm entities: ents) player 0))) (test-assert "on-ground? from entity top" (entity-ref result #:on-ground? #f)))) (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 (test-scene tilemap: tm) 0))) + (platform (entity #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 #:solid? #t)) + (player (entity #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) player 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 #f 0))) + (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #t)) + (result (apply-acceleration #f e 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 #f 0))) + (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 0 #:gravity? #t)) + (result (apply-acceleration #f e 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 #f 0))) + (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #f)) + (result (apply-acceleration #f e 0))) (test-equal "entity unchanged" e result)))) (test-group "pixel->tile" @@ -485,14 +490,14 @@ (test-group "entity-tile-cells" (test-group "entity aligned to one tile" (let* ((tm (make-test-tilemap '((0 0) (0 0)))) - (e '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (cells (entity-tile-cells e tm))) (test-equal "one cell" 1 (length cells)) (test-equal "cell is (0 . 0)" '(0 . 0) (car cells)))) (test-group "entity spanning 2 cols and 2 rows" (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) - (e '(#:type player #:x 8 #:y 8 #:width 16 #:height 16)) + (e (entity #:type 'player #:x 8 #:y 8 #:width 16 #:height 16)) (cells (entity-tile-cells e tm))) (test-equal "four cells" 4 (length cells))))) @@ -531,43 +536,43 @@ (test-group "push-entity" (test-group "push right (sign=1): x += overlap/2, vx=1" - (let* ((e '(#:type player #:x 10 #:y 0 #:vx 0 #:vy 0)) + (let* ((e (entity #:type 'player #:x 10 #:y 0 #:vx 0 #:vy 0)) (result (push-entity e #:x #:vx 10 6 1))) (test-equal "x = 10 + 3" 13 (entity-ref result #:x 0)) (test-equal "vx = 1" 1 (entity-ref result #:vx 0)))) (test-group "push left (sign=-1): x -= overlap/2, vx=-1" - (let* ((e '(#:type player #:x 10 #:y 0 #:vx 0 #:vy 0)) + (let* ((e (entity #:type 'player #:x 10 #:y 0 #:vx 0 #:vy 0)) (result (push-entity e #:x #:vx 10 6 -1))) (test-equal "x = 10 - 3" 7 (entity-ref result #:x 0)) (test-equal "vx = -1" -1 (entity-ref result #:vx 0))))) (test-group "entity-center-on-axis" - (let ((e '(#:type player #:x 10 #:y 20 #:width 16 #:height 24))) + (let ((e (entity #:type 'player #:x 10 #:y 20 #:width 16 #:height 24))) (test-equal "center-x = 10 + 8 = 18" 18 (entity-center-on-axis e #:x)) (test-equal "center-y = 20 + 12 = 32" 32 (entity-center-on-axis e #:y)))) (test-group "aabb-overlap-on-axis" (test-group "x overlap: a at x=0 w=16, b at x=10 w=16 → overlap=6" ;; half-sum of widths = 16, center dist = |18 - 8| = 10, overlap = 16 - 10 = 6 - (let ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 10 #:y 0 #:width 16 #:height 16))) + (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 10 #:y 0 #:width 16 #:height 16))) (test-equal "x overlap = 6" 6 (aabb-overlap-on-axis #:x a b)))) (test-group "y overlap: a at y=0 h=16, b at y=10 h=16 → overlap=6" - (let ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 0 #:y 10 #:width 16 #:height 16))) + (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 0 #:y 10 #:width 16 #:height 16))) (test-equal "y overlap = 6" 6 (aabb-overlap-on-axis #:y a b)))) (test-group "no overlap: negative value" - (let ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 100 #:y 0 #:width 16 #:height 16))) + (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 100 #:y 0 #:width 16 #:height 16))) (test-assert "x overlap is negative" (< (aabb-overlap-on-axis #:x a b) 0))))) (test-group "push-along-axis" (test-group "x axis: a left of b, pushed apart" - (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 10 #:y 0 #:width 16 #:height 16)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 10 #:y 0 #:width 16 #:height 16)) (result (push-along-axis #:x a b 6)) (ra (car result)) (rb (cdr result))) @@ -577,8 +582,8 @@ (test-equal "b vx = 1" 1 (entity-ref rb #:vx 0)))) (test-group "y axis: a above b, pushed apart" - (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 0 #:y 10 #:width 16 #:height 16)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 0 #:y 10 #:width 16 #:height 16)) (result (push-along-axis #:y a b 6)) (ra (car result)) (rb (cdr result))) @@ -588,42 +593,42 @@ (test-group "push-apart" (test-group "x overlap smaller: pushes on x axis" ;; a at (0,0), b at (10,0), both 16x16: ovx=6, ovy=16 → push on x - (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 10 #:y 0 #:width 16 #:height 16)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 10 #:y 0 #:width 16 #:height 16)) (result (push-apart a b))) (test-equal "a pushed left" -3 (entity-ref (car result) #:x 0)) (test-equal "b pushed right" 13 (entity-ref (cdr result) #:x 0)))) (test-group "y overlap smaller: pushes on y axis" ;; a at (0,0), b at (0,10), both 16x16: ovx=16, ovy=6 → push on y - (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) - (b '(#:type player #:x 0 #:y 10 #:width 16 #:height 16)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 0 #:y 10 #:width 16 #:height 16)) (result (push-apart a b))) (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 #f 0))) + (let* ((e (entity #:type 't #:vy 0 #:gravity? #t #:skip-pipelines '(gravity))) + (r (apply-gravity #f e 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 #f 0))) + (let* ((e (entity #:type 't #:x 10 #:vx 5 #:skip-pipelines '(velocity-x))) + (r (apply-velocity-x #f e 0))) (test-equal "skipped: x unchanged" 10 (entity-ref r #:x)))) (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))) + (define (make-solid x y) (entity #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (let* ((a (entity #: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)) + (define (make-solid x y) (entity #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) (test-group "one entity not solid: returns #f" (let ((a (make-solid 0 0)) - (b '(#:type ghost #:x 5 #:y 5 #:width 16 #:height 16))) + (b (entity #:type 'ghost #:x 5 #:y 5 #:width 16 #:height 16))) (test-assert "returns #f" (not (resolve-pair a b))))) (test-group "no overlap: returns #f" @@ -641,9 +646,9 @@ (test-group "immovable" (define (make-static x y) - (list #:type 'wall #:x x #:y y #:width 16 #:height 16 #:solid? #t #:immovable? #t)) + (entity #: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)) + (entity #: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))) |