diff options
| author | Gene Pasquet <dev@etenil.net> | 2026-04-17 16:52:41 +0100 |
|---|---|---|
| committer | Gene Pasquet <dev@etenil.net> | 2026-04-17 16:52:41 +0100 |
| commit | a02b892e2ad1e1605ff942c63afdd618daa48be4 (patch) | |
| tree | 7ccd9278a0cdc7fd2f156b0b4710f6ac00acab27 /tests/physics-test.scm | |
| parent | 8251c85a4a588504d38a2fad05e4b0fe1cdccb9d (diff) | |
Migrate tests to the test egg
Diffstat (limited to 'tests/physics-test.scm')
| -rw-r--r-- | tests/physics-test.scm | 241 |
1 files changed, 121 insertions, 120 deletions
diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 4ab4b17..76b480c 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -3,7 +3,7 @@ (chicken base) (chicken keyword) defstruct - srfi-64 + test (only srfi-1 every member make-list fold iota)) ;; Create a mock tilemap module to avoid SDL dependency @@ -92,102 +92,102 @@ (test-group "gravity? true, vy starts at 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 "vy increased by gravity" *gravity* (entity-ref result #:vy)) + (test "x unchanged" 0 (entity-ref result #:x)) + (test "y unchanged" 0 (entity-ref result #:y)) + (test "vx unchanged" 0 (entity-ref result #:vx)))) (test-group "gravity? true, vy already has value" (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 "vy increased by gravity" 4 (entity-ref result #:vy)))) (test-group "gravity? false" (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 "vy unchanged" 0 (entity-ref result #:vy)))) (test-group "no gravity? field at all" (let* ((e (entity #:type 'static #:x 5 #:y 5)) (result (apply-gravity #f e 0))) - (test-equal "entity unchanged" e result)))) + (test "entity unchanged" e (begin result))))) (test-group "apply-velocity-x" (test-group "basic horizontal movement" (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 "x moved by vx" 15 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y)) + (test "vy unchanged" -2 (entity-ref result #:vy)))) (test-group "zero vx" (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 "x unchanged" 10 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y))))) (test-group "apply-velocity-y" (test-group "basic vertical movement" (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 "x unchanged" 10 (entity-ref result #:x)) + (test "y moved by vy" 15 (entity-ref result #:y)) + (test "vx unchanged" 3 (entity-ref result #:vx)))) (test-group "zero vy" (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 "x unchanged" 10 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y))))) (test-group "apply-velocity" (test-group "basic movement" (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 "x moved by vx" 13 (entity-ref result #:x)) + (test "y moved by vy" 18 (entity-ref result #:y)))) (test-group "zero velocity" (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 "x unchanged" 10 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y)))) (test-group "no velocity fields (defaults to 0)" (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))))) + (test "x unchanged" 5 (entity-ref result #:x)) + (test "y unchanged" 5 (entity-ref result #:y))))) (test-group "build-cell-list" (test-group "single cell" (let ((cells (build-cell-list 5 5 3 3))) - (test-equal "one cell" 1 (length cells)) - (test-equal "cell is pair" '(5 . 3) (car cells)))) + (test "one cell" 1 (length cells)) + (test "cell is pair" '(5 . 3) (car cells)))) (test-group "two columns one row" (let ((cells (build-cell-list 11 12 22 22))) - (test-equal "two cells" 2 (length cells)) + (test "two cells" 2 (length cells)) (test-assert "all cells are pairs" (every pair? cells)) (test-assert "contains (11 . 22)" (member '(11 . 22) cells)) (test-assert "contains (12 . 22)" (member '(12 . 22) cells)))) (test-group "one column two rows" (let ((cells (build-cell-list 5 5 2 3))) - (test-equal "two cells" 2 (length cells)) + (test "two cells" 2 (length cells)) (test-assert "all cells are pairs" (every pair? cells)) (test-assert "contains (5 . 2)" (member '(5 . 2) cells)) (test-assert "contains (5 . 3)" (member '(5 . 3) cells)))) (test-group "2x2 grid" (let ((cells (build-cell-list 0 1 0 1))) - (test-equal "four cells" 4 (length cells)) + (test "four cells" 4 (length cells)) (test-assert "all cells are pairs" (every pair? cells)) (test-assert "no #f in list" (not (member #f cells))))) (test-group "empty when col-start > col-end" (let ((cells (build-cell-list 5 4 0 0))) - (test-equal "empty list" '() cells))) + (test "empty list" '() (begin cells)))) (test-group "player-like values (x=182 y=352 w=16 h=16 tw=16 th=16)" (let* ((x 182) (y 352) (w 16) (h 16) (tw 16) (th 16) @@ -196,11 +196,11 @@ (row-start (inexact->exact (floor (/ y th)))) (row-end (inexact->exact (floor (/ (- (+ y h) 1) th)))) (cells (build-cell-list col-start col-end row-start row-end))) - (test-equal "col-start" 11 col-start) - (test-equal "col-end" 12 col-end) - (test-equal "row-start" 22 row-start) - (test-equal "row-end" 22 row-end) - (test-equal "two cells" 2 (length cells)) + (test "col-start" 11 (begin col-start)) + (test "col-end" 12 (begin col-end)) + (test "row-start" 22 (begin row-start)) + (test "row-end" 22 (begin row-end)) + (test "two cells" 2 (length cells)) (test-assert "all cells are pairs" (every pair? cells))))) (test-group "resolve-tile-collisions-x" @@ -208,100 +208,100 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 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 "x unchanged" 0 (entity-ref result #:x)) + (test "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 (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 "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 (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 "pushed left of solid tile" 0 (entity-ref result #:x)) + (test "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 (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 "pushed right of solid tile" 32 (entity-ref result #:x)) + (test "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 (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 "pushed left of solid tile" 0 (entity-ref result #:x)) + (test "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 (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)))) + (test "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 (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 "pushed left of wall" 28 (entity-ref result #:x)) + (test "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 (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 "y unchanged" 0 (entity-ref result #:y)) + (test "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 (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 "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 (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 "pushed above solid tile" 0 (entity-ref result #:y)) + (test "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 (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 "pushed below solid tile" 32 (entity-ref result #:y)) + (test "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 (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 "pushed above solid tile" 0 (entity-ref result #:y)) + (test "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 (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)))) + (test "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 (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)))))) + (test "pushed above floor" 28 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy)))))) (test-group "high-velocity fall: snaps to first solid row, not last" ;; Regression: entity falls fast enough that apply-velocity-y moves it into TWO solid rows. @@ -311,8 +311,8 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0) (1 0 0) (0 0 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))))) + (test "snapped to first solid row" 16 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy))))) ;; Integration test: simulate the actual game physics loop (test-group "multi-frame physics simulation" @@ -361,8 +361,8 @@ (let* ((a (make-solid 0 0 16 16)) (b (make-solid 100 0 16 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" 100 (entity-ref (list-ref result 1) #:x 0)))) + (test "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0)) + (test "b x unchanged" 100 (entity-ref (list-ref result 1) #:x 0)))) (test-group "horizontal overlap: pushed apart on x" ;; a at x=0, b at x=10, both 16x16 → overlap-x = (16+16)/2 - 10 = 6, overlap-y = (16+16)/2 - 0 = 16 @@ -372,8 +372,8 @@ (result (resolve-entity-collisions (list a b))) (ra (list-ref result 0)) (rb (list-ref result 1))) - (test-equal "a pushed left by 3" -3 (entity-ref ra #:x 0)) - (test-equal "b pushed right by 3" 13 (entity-ref rb #:x 0)))) + (test "a pushed left by 3" -3 (entity-ref ra #:x 0)) + (test "b pushed right by 3" 13 (entity-ref rb #:x 0)))) (test-group "vertical overlap: pushed apart on y" ;; a at y=0, b at y=10, both 16x16 → overlap-x=16, overlap-y=6 → push on y @@ -382,8 +382,8 @@ (result (resolve-entity-collisions (list a b))) (ra (list-ref result 0)) (rb (list-ref result 1))) - (test-equal "a pushed up by 3" -3 (entity-ref ra #:y 0)) - (test-equal "b pushed down by 3" 13 (entity-ref rb #:y 0)))) + (test "a pushed up by 3" -3 (entity-ref ra #:y 0)) + (test "b pushed down by 3" 13 (entity-ref rb #:y 0)))) (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 @@ -394,15 +394,15 @@ #:solid? #t #:immovable? #f #:vx 0 #:vy 0)) (result (resolve-entity-collisions (list shelf box))) (box2 (list-ref result 1))) - (test-equal "box rests on shelf top (y = shelf_y - height)" 184 (entity-ref box2 #:y 0)) - (test-equal "vy zeroed" 0 (entity-ref box2 #:vy 0)))) + (test "box rests on shelf top (y = shelf_y - height)" 184 (entity-ref box2 #:y 0)) + (test "vy zeroed" 0 (entity-ref box2 #:vy 0)))) (test-group "non-solid entity ignored" (let* ((a (make-solid 0 0 16 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))))) + (test "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0)) + (test "b x unchanged" 5 (entity-ref (list-ref result 1) #:x 0))))) ;; Tests for detect-on-solid (test-group "detect-on-solid" @@ -465,104 +465,104 @@ (test-group "gravity? #t, ay set: consumed into vy and cleared" (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 "vy += ay" 8 (entity-ref result #:vy 0)) + (test "ay cleared" 0 (entity-ref result #:ay 0)))) (test-group "gravity? #t, ay is 0: vy unchanged" (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 "vy unchanged" 3 (entity-ref result #:vy 0)) + (test "ay still 0" 0 (entity-ref result #:ay 0)))) (test-group "gravity? #f: entity unchanged" (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 "entity unchanged" e (begin result))))) (test-group "pixel->tile" - (test-equal "pixel 0 in 16px tile → 0" 0 (pixel->tile 0 16)) - (test-equal "pixel 15 in 16px tile → 0" 0 (pixel->tile 15 16)) - (test-equal "pixel 16 in 16px tile → 1" 1 (pixel->tile 16 16)) - (test-equal "pixel 24 in 16px tile → 1" 1 (pixel->tile 24 16)) - (test-equal "pixel 24.7 in 16px tile → 1" 1 (pixel->tile 24.7 16)) - (test-equal "pixel 32 in 16px tile → 2" 2 (pixel->tile 32 16))) + (test "pixel 0 in 16px tile → 0" 0 (pixel->tile 0 16)) + (test "pixel 15 in 16px tile → 0" 0 (pixel->tile 15 16)) + (test "pixel 16 in 16px tile → 1" 1 (pixel->tile 16 16)) + (test "pixel 24 in 16px tile → 1" 1 (pixel->tile 24 16)) + (test "pixel 24.7 in 16px tile → 1" 1 (pixel->tile 24.7 16)) + (test "pixel 32 in 16px tile → 2" 2 (pixel->tile 32 16))) (test-group "entity-tile-cells" (test-group "entity aligned to one tile" (let* ((tm (make-test-tilemap '((0 0) (0 0)))) (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 "one cell" 1 (length cells)) + (test "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 (entity #:type 'player #:x 8 #:y 8 #:width 16 #:height 16)) (cells (entity-tile-cells e tm))) - (test-equal "four cells" 4 (length cells))))) + (test "four cells" 4 (length cells))))) (test-group "tile-push-pos" (test-group "moving forward (v>0): snap leading edge to near side of tile" ;; coord=3, tile-size=16, entity-size=16 → 3*16 - 16 = 32 - (test-equal "push pos" 32 (tile-push-pos 1 3 16 16))) + (test "push pos" 32 (tile-push-pos 1 3 16 16))) (test-group "moving backward (v<0): snap trailing edge to far side of tile" ;; coord=3, tile-size=16 → (3+1)*16 = 64 - (test-equal "push pos" 64 (tile-push-pos -1 3 16 16)))) + (test "push pos" 64 (tile-push-pos -1 3 16 16)))) (test-group "list-set" - (test-equal "replace first" '(x b c) (list-set '(a b c) 0 'x)) - (test-equal "replace middle" '(a x c) (list-set '(a b c) 1 'x)) - (test-equal "replace last" '(a b x) (list-set '(a b c) 2 'x))) + (test "replace first" '(x b c) (list-set '(a b c) 0 'x)) + (test "replace middle" '(a x c) (list-set '(a b c) 1 'x)) + (test "replace last" '(a b x) (list-set '(a b c) 2 'x))) (test-group "index-pairs" - (test-equal "n=0: empty" '() (index-pairs 0)) - (test-equal "n=1: empty" '() (index-pairs 1)) - (test-equal "n=2: one pair" '((0 . 1)) (index-pairs 2)) + (test "n=0: empty" '() (index-pairs 0)) + (test "n=1: empty" '() (index-pairs 1)) + (test "n=2: one pair" '((0 . 1)) (index-pairs 2)) (test-group "n=3: three pairs" (let ((pairs (index-pairs 3))) - (test-equal "count" 3 (length pairs)) + (test "count" 3 (length pairs)) (test-assert "(0 . 1)" (member '(0 . 1) pairs)) (test-assert "(0 . 2)" (member '(0 . 2) pairs)) (test-assert "(1 . 2)" (member '(1 . 2) pairs))))) (test-group "axis->dimension" - (test-equal "#:x → #:width" #:width (axis->dimension #:x)) - (test-equal "#:y → #:height" #:height (axis->dimension #:y))) + (test "#:x → #:width" #:width (axis->dimension #:x)) + (test "#:y → #:height" #:height (axis->dimension #:y))) (test-group "axis->velocity" - (test-equal "#:x → #:vx" #:vx (axis->velocity #:x)) - (test-equal "#:y → #:vy" #:vy (axis->velocity #:y))) + (test "#:x → #:vx" #:vx (axis->velocity #:x)) + (test "#:y → #:vy" #:vy (axis->velocity #:y))) (test-group "push-entity" (test-group "push right (sign=1): x += overlap/2, vx=1" (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 "x = 10 + 3" 13 (entity-ref result #:x 0)) + (test "vx = 1" 1 (entity-ref result #:vx 0)))) (test-group "push left (sign=-1): x -= overlap/2, vx=-1" (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 "x = 10 - 3" 7 (entity-ref result #:x 0)) + (test "vx = -1" -1 (entity-ref result #:vx 0))))) (test-group "entity-center-on-axis" (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 "center-x = 10 + 8 = 18" 18 (entity-center-on-axis e #:x)) + (test "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 (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 "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 (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 "y overlap = 6" 6 (aabb-overlap-on-axis #:y a b)))) (test-group "no overlap: negative value" (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) @@ -576,10 +576,10 @@ (result (push-along-axis #:x a b 6)) (ra (car result)) (rb (cdr result))) - (test-equal "a pushed left to -3" -3 (entity-ref ra #:x 0)) - (test-equal "b pushed right to 13" 13 (entity-ref rb #:x 0)) - (test-equal "a vx = -1" -1 (entity-ref ra #:vx 0)) - (test-equal "b vx = 1" 1 (entity-ref rb #:vx 0)))) + (test "a pushed left to -3" -3 (entity-ref ra #:x 0)) + (test "b pushed right to 13" 13 (entity-ref rb #:x 0)) + (test "a vx = -1" -1 (entity-ref ra #:vx 0)) + (test "b vx = 1" 1 (entity-ref rb #:vx 0)))) (test-group "y axis: a above b, pushed apart" (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) @@ -587,8 +587,8 @@ (result (push-along-axis #:y a b 6)) (ra (car result)) (rb (cdr result))) - (test-equal "a pushed up to -3" -3 (entity-ref ra #:y 0)) - (test-equal "b pushed down to 13" 13 (entity-ref rb #:y 0))))) + (test "a pushed up to -3" -3 (entity-ref ra #:y 0)) + (test "b pushed down to 13" 13 (entity-ref rb #:y 0))))) (test-group "push-apart" (test-group "x overlap smaller: pushes on x axis" @@ -596,26 +596,26 @@ (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 "a pushed left" -3 (entity-ref (car result) #:x 0)) + (test "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 (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 "a pushed up" -3 (entity-ref (car result) #:y 0)) + (test "b pushed down" 13 (entity-ref (cdr result) #:y 0))))) (test-group "skip-pipelines" (test-group "apply-gravity" (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 "skipped: vy unchanged" 0 (entity-ref r #:vy)))) (test-group "apply-velocity-x" (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 "skipped: x unchanged" 10 (entity-ref r #:x)))) (test-group "resolve-pair with entity-collisions skip" (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 @@ -660,7 +660,7 @@ (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 "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)) @@ -669,7 +669,7 @@ (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 "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?" @@ -694,3 +694,4 @@ (aabb-overlap? 0 0 20 20 5 5 10 10)))) (test-end "physics-module") +(test-exit) |
