path: root/tests/physics-test.scm

;; Load dependencies first
(import scheme
        (chicken base)
        (chicken keyword)
        defstruct
        test
        (only srfi-1 every member make-list fold iota))

;; Create a mock tilemap module to avoid SDL dependency
(module downstroke-tilemap *
  (import scheme (chicken base) defstruct)

  (defstruct tileset
    tilewidth
    tileheight
    spacing
    tilecount
    columns
    image-source
    image)

  (defstruct layer
    name
    width
    height
    map)

  (defstruct tilemap
    width
    height
    tilewidth
    tileheight
    tileset-source
    tileset
    layers
    objects))

(import downstroke-tilemap)

;; Load entity module first (since world now imports entity)
(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)

;; Load physics module
(include "physics.scm")
(import downstroke-physics)

;; Load physics module
(include "input.scm")
(import downstroke-input)

;; Test suite for physics module
(test-begin "physics-module")

;; Helper to reduce tilemap boilerplate in tests
;; rows: list of lists of tile IDs, tiles are 16x16
(define (make-test-tilemap rows)
  (let* ((height (length rows))
         (width  (length (car rows)))
         (layer  (make-layer name: "test" width: width height: height map: rows)))
    (make-tilemap width: width height: height
                  tilewidth: 16 tileheight: 16
                  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 #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 (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #t))
           (result (apply-gravity #f e 0)))
      (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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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)
           (col-start (inexact->exact (floor (/ x tw))))
           (col-end   (inexact->exact (floor (/ (- (+ x w) 1) tw))))
           (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 "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"
  (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 2 #:vy 0)))
      (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0)))
        (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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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.
    ;; Rows 2 and 3 are both solid (tileheight=16, so row 2 = y=[32,47], row 3 = y=[48,63]).
    ;; 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  (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 "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"
  (test-group "player falls and lands on floor (10 frames)"
    ;; 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 (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
              (test-assert "player rests at or above floor" (<= (entity-ref e #:y) 32))
              (test-assert "y is non-negative" (>= (entity-ref e #:y) 0)))
            (loop (tick e tm (lambda (a) #f)) (- n 1))))))

  (test-group "player stable on floor (10 frames of gravity jitter)"
    ;; 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 (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))
            (loop (tick e tm (lambda (a) #f)) (- n 1))))))

  (test-group "player with real starting coordinates (x=182 y=350.5) falls 5 frames"
    ;; Use a large enough tilemap: 15 cols x 25 rows, solid floor at row 24
    (let* ((empty-row (make-list 15 0))
           (solid-row (make-list 15 1))
           (rows (append (make-list 24 empty-row) (list solid-row)))
           (tm (make-test-tilemap rows))
           (e0 (make-entity 182 350.5 16 16)))
      ;; Should not crash
      (let loop ((e e0) (n 5))
        (if (= n 0)
            (test-assert "player survived 5 frames" #t)
            (loop (tick e tm (lambda (a) #f)) (- n 1)))))))

(test-group "resolve-entity-collisions"
  (define (make-solid x y w h)
    (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))
           (b (make-solid 100 0 16 16))
           (result (resolve-entity-collisions (list a b))))
      (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
    ;; push on x (smaller), each by 3px
    (let* ((a (make-solid 0 0 16 16))
           (b (make-solid 10 0 16 16))
           (result (resolve-entity-collisions (list a b)))
           (ra (list-ref result 0))
           (rb (list-ref result 1)))
      (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
    (let* ((a (make-solid 0 0 16 16))
           (b (make-solid 0 10 16 16))
           (result (resolve-entity-collisions (list a b)))
           (ra (list-ref result 0))
           (rb (list-ref result 1)))
      (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
    ;; mover sideways off a narrow platform. Box center remains above shelf center → snap on top.
    (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)))
      (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 "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"
  (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
    ;; 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 (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 (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 (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 (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 (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 (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 (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 (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #t))
           (result (apply-acceleration #f e 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 "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 "entity unchanged" e (begin result)))))

(test-group "pixel->tile"
  (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 "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 "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 "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 "push pos" 64 (tile-push-pos -1 3 16 16))))

(test-group "list-set"
  (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 "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 "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 "#:x → #:width"  #:width  (axis->dimension #:x))
  (test "#:y → #:height" #:height (axis->dimension #:y)))

(test-group "axis->velocity"
  (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 "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 "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 "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 "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 "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))
          (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 (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)))
      (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))
           (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)))
      (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"
    ;; a at (0,0), b at (10,0), both 16x16: ovx=6, ovy=16 → push on x
    (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 "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 "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 "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 "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
                      #: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) (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 (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"
    (let ((a (make-solid 0 0))
          (b (make-solid 100 0)))
      (test-assert "returns #f" (not (resolve-pair a b)))))

  (test-group "overlap: returns (a2 . b2) pair"
    (let* ((a (make-solid 0 0))
           (b (make-solid 10 0))
           (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-group "immovable"
    (define (make-static x y)
      (entity #:type 'wall #:x x #:y y #:width 16 #:height 16 #:solid? #t #:immovable? #t))
    (define (make-box x y)
      (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)))
        (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 "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 "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"
    (test-assert "boxes overlap in center"
      (aabb-overlap? 0 0 10 10 5 5 10 10)))

  (test-group "two boxes not overlapping (separated horizontally)"
    (test-assert "boxes don't overlap when separated on x-axis"
      (not (aabb-overlap? 0 0 10 10 20 0 10 10))))

  (test-group "two boxes not overlapping (separated vertically)"
    (test-assert "boxes don't overlap when separated on y-axis"
      (not (aabb-overlap? 0 0 10 10 0 20 10 10))))

  (test-group "edge-touching exactly"
    (test-assert "touching edges are not overlapping"
      (not (aabb-overlap? 0 0 10 10 10 0 10 10))))

  (test-group "one box fully inside another"
    (test-assert "inner box overlaps with outer"
      (aabb-overlap? 0 0 20 20 5 5 10 10))))

(test-end "physics-module")
(test-exit)