aboutsummaryrefslogtreecommitdiff
path: root/physics.scm
diff options
context:
space:
mode:
Diffstat (limited to 'physics.scm')
-rw-r--r--physics.scm624
1 files changed, 313 insertions, 311 deletions
diff --git a/physics.scm b/physics.scm
index b95fc86..543e786 100644
--- a/physics.scm
+++ b/physics.scm
@@ -1,315 +1,317 @@
(module downstroke-physics
- (resolve-entity-collisions resolve-pair
- aabb-overlap? push-apart push-along-axis aabb-overlap-on-axis
- entity-center-on-axis push-entity axis->velocity axis->dimension
- index-pairs list-set detect-on-solid
- resolve-tile-collisions-y resolve-tile-collisions-x resolve-tile-collisions-axis
- tile-push-pos entity-tile-cells pixel->tile build-cell-list
- apply-velocity apply-velocity-y apply-velocity-x apply-gravity apply-acceleration
- *jump-force* *gravity*)
- (import scheme
- (chicken base)
- (chicken keyword)
- (only srfi-1 any fold iota)
- defstruct
- downstroke-tilemap
- downstroke-entity
- downstroke-world
- simple-logger)
-
- ;; Gravity constant: pixels per frame per frame
- (define *gravity* 1)
-
- ;; Jump force: vertical acceleration applied on jump (one frame)
- (define *jump-force* 15)
-
- ;; Feet may be this far (pixels) from another solid's top and count as standing on it.
- (define *entity-ground-contact-tolerance* 5)
- ;; If |vy| is above this, another entity does not count as ground (mid-air / fast fall).
- (define *entity-ground-vy-max* 12)
-
- ;; Per-entity steps use define-pipeline from downstroke-entity (see docs/physics.org
- ;; for #:skip-pipelines symbol names).
-
- ;; Consume #:ay into #:vy and clear it (one-shot acceleration)
- (define-pipeline (apply-acceleration acceleration) (scene entity dt)
- guard: (entity-ref entity #:gravity? #f)
- (let ((ay (entity-ref entity #:ay 0))
- (vy (entity-ref entity #:vy 0)))
- (entity-set (entity-set entity #:vy (+ vy ay)) #:ay 0)))
-
- ;; Apply gravity to an entity if it has gravity enabled
- (define-pipeline (apply-gravity gravity) (scene entity dt)
- guard: (entity-ref entity #:gravity? #f)
- (entity-set entity #:vy (+ (entity-ref entity #:vy) *gravity*)))
-
- ;; Update entity's x by its vx velocity
- (define-pipeline (apply-velocity-x velocity-x) (scene entity dt)
- (let ((x (entity-ref entity #:x 0))
- (vx (entity-ref entity #:vx 0)))
- (entity-set entity #:x (+ x vx))))
-
- ;; Update entity's y by its vy velocity
- (define-pipeline (apply-velocity-y velocity-y) (scene entity dt)
- (let ((y (entity-ref entity #:y 0))
- (vy (entity-ref entity #:vy 0)))
- (entity-set entity #:y (+ y vy))))
-
- ;; Legacy function: update both x and y by velocities
- (define (apply-velocity entity)
- "Legacy function: update both x and y by velocities."
- (let* ((x (entity-ref entity #:x 0))
- (y (entity-ref entity #:y 0))
- (vx (entity-ref entity #:vx 0))
- (vy (entity-ref entity #:vy 0))
- (e (if (downstroke-entity#entity-skips-pipeline? entity 'velocity-x)
- entity
- (entity-set entity #:x (+ x vx))))
- (e (if (downstroke-entity#entity-skips-pipeline? entity 'velocity-y)
- e
- (entity-set e #:y (+ (entity-ref e #:y 0) vy)))))
- e))
-
- ;; Build list of (col . row) pairs to check for collisions
- (define (build-cell-list col-start col-end row-start row-end)
- (let loop ((col col-start) (row row-start) (acc '()))
- (log-debug "Build-cell-list loop with: ~a" (list col row acc))
- (if (> col col-end)
- (if (>= row row-end)
- (reverse acc)
- (loop col-start (+ row 1) acc))
- (loop (+ col 1) row (cons (cons col row) acc)))))
-
- ;; Convert a pixel coordinate to a tile grid index
- (define (pixel->tile pixel tile-size)
- (inexact->exact (floor (/ pixel tile-size))))
-
- ;; Return all tile cells (col . row) overlapping the entity's bounding box
- (define (entity-tile-cells entity tilemap)
- (let ((x (entity-ref entity #:x 0))
- (y (entity-ref entity #:y 0))
- (w (entity-ref entity #:width 0))
- (h (entity-ref entity #:height 0))
- (tw (tilemap-tilewidth tilemap))
- (th (tilemap-tileheight tilemap)))
- (build-cell-list
- (pixel->tile x tw)
- (pixel->tile (- (+ x w) 1) tw)
- (pixel->tile y th)
- (pixel->tile (- (+ y h) 1) th))))
-
- ;; Snap position to the near or far edge of a tile after collision.
- ;; Moving forward (v>0): snap entity's leading edge to tile's near edge.
- ;; Moving backward (v<0): snap entity's trailing edge to tile's far edge.
- (define (tile-push-pos v coord tile-size entity-size)
- (if (> v 0)
- (- (* coord tile-size) entity-size)
- (* (+ coord 1) tile-size)))
-
- ;; Resolve collisions with tiles along a single axis.
- ;; push-fn: (v col row) -> new-pos
- ;; For v>0 (moving right/down): snap to the FIRST solid cell (shallowest penetration).
- ;; For v<0 (moving left/up): snap to the LAST solid cell (deepest penetration from above/left).
- (define (resolve-tile-collisions-axis entity tilemap vel-key pos-key push-fn)
- (let ((v (entity-ref entity vel-key 0)))
- (if (zero? v)
- entity
- (fold (lambda (cell acc)
- (log-debug "resolve-~a: cell=~a acc=~a" vel-key cell acc)
- (let* ((col (car cell))
- (row (cdr cell))
- (tile-id (tilemap-tile-at tilemap col row)))
- (if (zero? tile-id)
- acc
- (if (and (> v 0) (zero? (entity-ref acc vel-key v)))
- acc ; v>0: first collision already resolved, don't overwrite
- (entity-set (entity-set acc pos-key (push-fn v col row)) vel-key 0)))))
+(resolve-entity-collisions
+ resolve-pair
+ aabb-overlap? push-apart push-along-axis aabb-overlap-on-axis
+ entity-center-on-axis push-entity axis->velocity axis->dimension
+ index-pairs list-set detect-on-solid
+ resolve-tile-collisions-y resolve-tile-collisions-x resolve-tile-collisions-axis
+ tile-push-pos entity-tile-cells pixel->tile build-cell-list
+ apply-velocity apply-velocity-y apply-velocity-x apply-gravity apply-acceleration
+ *jump-force* *gravity*)
+
+(import scheme
+ (chicken base)
+ (chicken keyword)
+ (only srfi-1 any fold iota)
+ defstruct
+ downstroke-tilemap
+ downstroke-entity
+ downstroke-world
+ simple-logger)
+
+;; Gravity constant: pixels per frame per frame
+(define *gravity* 1)
+
+;; Jump force: vertical acceleration applied on jump (one frame)
+(define *jump-force* 15)
+
+;; Feet may be this far (pixels) from another solid's top and count as standing on it.
+(define *entity-ground-contact-tolerance* 5)
+;; If |vy| is above this, another entity does not count as ground (mid-air / fast fall).
+(define *entity-ground-vy-max* 12)
+
+;; Per-entity steps use define-pipeline from downstroke-entity (see docs/physics.org
+;; for #:skip-pipelines symbol names).
+
+;; Consume #:ay into #:vy and clear it (one-shot acceleration)
+(define-pipeline (apply-acceleration acceleration) (scene entity dt)
+ guard: (entity-ref entity #:gravity? #f)
+ (let ((ay (entity-ref entity #:ay 0))
+ (vy (entity-ref entity #:vy 0)))
+ (entity-set (entity-set entity #:vy (+ vy ay)) #:ay 0)))
+
+;; Apply gravity to an entity if it has gravity enabled
+(define-pipeline (apply-gravity gravity) (scene entity dt)
+ guard: (entity-ref entity #:gravity? #f)
+ (entity-set entity #:vy (+ (entity-ref entity #:vy) *gravity*)))
+
+;; Update entity's x by its vx velocity
+(define-pipeline (apply-velocity-x velocity-x) (scene entity dt)
+ (let ((x (entity-ref entity #:x 0))
+ (vx (entity-ref entity #:vx 0)))
+ (entity-set entity #:x (+ x vx))))
+
+;; Update entity's y by its vy velocity
+(define-pipeline (apply-velocity-y velocity-y) (scene entity dt)
+ (let ((y (entity-ref entity #:y 0))
+ (vy (entity-ref entity #:vy 0)))
+ (entity-set entity #:y (+ y vy))))
+
+;; Legacy function: update both x and y by velocities
+(define (apply-velocity entity)
+ "Legacy function: update both x and y by velocities."
+ (let* ((x (entity-ref entity #:x 0))
+ (y (entity-ref entity #:y 0))
+ (vx (entity-ref entity #:vx 0))
+ (vy (entity-ref entity #:vy 0))
+ (e (if (downstroke-entity#entity-skips-pipeline? entity 'velocity-x)
entity
- (entity-tile-cells entity tilemap)))))
-
- ;; Resolve horizontal collisions with solid tiles
- (define-pipeline (resolve-tile-collisions-x tile-collisions-x) (scene entity dt)
- guard: (scene-tilemap scene)
- (let* ((tilemap (scene-tilemap scene))
- (w (entity-ref entity #:width 0))
- (tw (tilemap-tilewidth tilemap)))
- (resolve-tile-collisions-axis entity tilemap #:vx #:x
- (lambda (v col row) (tile-push-pos v col tw w)))))
-
- ;; Resolve vertical collisions with solid tiles
- (define-pipeline (resolve-tile-collisions-y tile-collisions-y) (scene entity dt)
- guard: (scene-tilemap scene)
- (let* ((tilemap (scene-tilemap scene))
- (h (entity-ref entity #:height 0))
- (th (tilemap-tileheight tilemap)))
- (resolve-tile-collisions-axis entity tilemap #:vy #:y
- (lambda (v col row) (tile-push-pos v row th h)))))
-
- ;; True if ~self~ is supported by another solid's top surface (moving platforms, crates, …).
- (define (entity-solid-support-below? self others)
- (let* ((bx (entity-ref self #:x 0))
- (bw (entity-ref self #:width 0))
- (by (entity-ref self #:y 0))
- (bh (entity-ref self #:height 0))
- (bottom (+ by bh))
- (vy (abs (entity-ref self #:vy 0))))
- (and (<= vy *entity-ground-vy-max*)
- (any (lambda (o)
- (and (not (eq? self o))
- (entity-ref o #:solid? #f)
- (let* ((ox (entity-ref o #:x 0))
- (oy (entity-ref o #:y 0))
- (ow (entity-ref o #:width 0)))
- (and (< bx (+ ox ow))
- (< ox (+ bx bw))
- (<= (abs (- bottom oy)) *entity-ground-contact-tolerance*)))))
- others))))
-
- (define (tile-ground-below? entity tilemap)
- (let* ((x (entity-ref entity #:x 0))
- (w (entity-ref entity #:width 0))
- (tw (tilemap-tilewidth tilemap))
- (th (tilemap-tileheight tilemap))
- (probe-y (+ (entity-ref entity #:y 0)
- (entity-ref entity #:height 0)
- 1))
- (row (pixel->tile probe-y th))
- (col-left (pixel->tile x tw))
- (col-right (pixel->tile (- (+ x w) 1) tw)))
- (or (not (zero? (tilemap-tile-at tilemap col-left row)))
- (not (zero? (tilemap-tile-at tilemap col-right row))))))
-
- (define-pipeline (detect-on-solid on-solid) (scene entity dt)
- guard: (entity-ref entity #:gravity? #f)
- (let* ((tilemap (scene-tilemap scene))
- (on-tile? (and tilemap (tile-ground-below? entity tilemap)))
- (on-entity? (entity-solid-support-below? entity (scene-entities scene))))
- (entity-set entity #:on-ground? (or on-tile? on-entity?))))
-
- ;; Replace element at idx in lst with val
- (define (list-set lst idx val)
- (let loop ((lst lst) (i 0) (acc '()))
- (if (null? lst)
- (reverse acc)
- (loop (cdr lst) (+ i 1)
- (cons (if (= i idx) val (car lst)) acc)))))
-
- ;; Generate all unique (i . j) index pairs where i < j
- (define (index-pairs n)
- (if (< n 2) '()
- (apply append
- (map (lambda (i)
- (map (lambda (j) (cons i j))
- (iota (- n i 1) (+ i 1))))
- (iota (- n 1))))))
-
- (define (axis->dimension axis)
- (case axis
- ((#:x) #:width)
- ((#:y) #:height)))
-
- (define (axis->velocity axis)
- (case axis
- ((#:x) #:vx)
- ((#:y) #:vy)))
-
- ;; Push entity along one axis by half-overlap, setting velocity in push direction
- (define (push-entity entity pos-key vel-key pos overlap sign)
- (entity-set (entity-set entity pos-key (+ pos (* sign (/ overlap 2)))) vel-key sign))
-
-
- (define (entity-center-on-axis entity axis)
- (let ((dimension (axis->dimension axis)))
- (+ (entity-ref entity axis 0) (/ (entity-ref entity dimension 0) 2))))
-
- (define (aabb-overlap-on-axis axis a b)
- (let ((dimension (axis->dimension axis)))
- (- (/ (+ (entity-ref a dimension 0) (entity-ref b dimension 0)) 2)
- (abs (- (entity-center-on-axis b axis) (entity-center-on-axis a axis))))))
-
- (define (push-along-axis axis a b overlap)
- (let* ((a-center (entity-center-on-axis a axis))
- (b-center (entity-center-on-axis b axis))
- (delta (if (< a-center b-center) -1 1))
- (axis-velocity-key (axis->velocity axis)))
- (cons (push-entity a axis axis-velocity-key (entity-ref a axis 0) overlap delta)
- (push-entity b axis axis-velocity-key (entity-ref b axis 0) overlap (- delta)))))
-
- ;; Push two overlapping entities apart along the minimum penetration axis.
- ;; Returns (a2 . b2) with updated positions and velocities.
- (define (push-apart a b)
- (let* ((ovx (aabb-overlap-on-axis #:x a b))
- (ovy (aabb-overlap-on-axis #:y a b)))
- (if (<= ovx ovy)
- (push-along-axis #:x a b ovx)
- (push-along-axis #:y a b ovy))))
-
- ;; Move ~m~ out of ~s~ along the shallow penetration axis; ~s~ is unchanged.
- ;; Used when ~s~ has #:immovable? #t.
- ;;
- ;; When ~m~ is falling onto ~s~ from above, the minimum-penetration axis can be
- ;; horizontal (narrow overlap in X but deeper in Y), which shoves the mover
- ;; sideways instead of resting it on the platform. Prefer vertical separation
- ;; whenever ~m~'s center is still above ~s~'s center (landing contact).
- (define (push-movable-along-axis m s axis overlap)
- (let* ((mc (entity-center-on-axis m axis))
- (sc (entity-center-on-axis s axis))
- (dir (if (< mc sc) -1 1))
- (pos (entity-ref m axis 0))
- (vel (axis->velocity axis)))
- (entity-set (entity-set m axis (+ pos (* dir overlap))) vel 0)))
-
- (define (separate-movable-from-static m s)
- (let* ((ovx (aabb-overlap-on-axis #:x m s))
- (ovy (aabb-overlap-on-axis #:y m s))
- (land-on-top? (and (< (entity-center-on-axis m #:y)
- (entity-center-on-axis s #:y))
- (> ovy 0))))
- (cond
- (land-on-top? (push-movable-along-axis m s #:y ovy))
- ((<= ovx ovy) (push-movable-along-axis m s #:x ovx))
- (else (push-movable-along-axis m s #:y ovy)))))
-
- ;; Check if two axis-aligned bounding boxes overlap.
- ;; Returns #t if they overlap, #f if they don't (including edge-touching).
- (define (aabb-overlap? x1 y1 w1 h1 x2 y2 w2 h2)
- (not (or (>= x1 (+ x2 w2))
- (>= x2 (+ x1 w1))
- (>= y1 (+ y2 h2))
- (>= y2 (+ y1 h1)))))
-
- ;; Resolve AABB collision between two solid entities.
- ;; Returns (a2 . b2) with positions/velocities adjusted, or #f if no collision.
- ;; #:immovable? #t marks static geometry; only the other entity is displaced.
- (define (resolve-pair a b)
- (and (not (downstroke-entity#entity-skips-pipeline? a 'entity-collisions))
- (not (downstroke-entity#entity-skips-pipeline? b 'entity-collisions))
- (entity-ref a #:solid? #f)
- (entity-ref b #:solid? #f)
- (aabb-overlap? (entity-ref a #:x 0) (entity-ref a #:y 0)
- (entity-ref a #:width 0) (entity-ref a #:height 0)
- (entity-ref b #:x 0) (entity-ref b #:y 0)
- (entity-ref b #:width 0) (entity-ref b #:height 0))
- (let ((ia (entity-ref a #:immovable? #f))
- (ib (entity-ref b #:immovable? #f)))
- (cond
- ((and ia ib) #f)
- (ia (let ((b2 (separate-movable-from-static b a)))
- (and b2 (cons a b2))))
- (ib (let ((a2 (separate-movable-from-static a b)))
- (and a2 (cons a2 b))))
- (else (push-apart a b))))))
-
- ;; Detect and resolve AABB overlaps between all pairs of solid entities.
- ;; Returns a new entity list with collisions resolved.
- (define (resolve-entity-collisions entities)
- (fold (lambda (pair ents)
- (let* ((i (car pair)) (j (cdr pair))
- (result (resolve-pair (list-ref ents i) (list-ref ents j))))
- (if result
- (list-set (list-set ents i (car result)) j (cdr result))
- ents)))
- entities
- (index-pairs (length entities))))
+ (entity-set entity #:x (+ x vx))))
+ (e (if (downstroke-entity#entity-skips-pipeline? entity 'velocity-y)
+ e
+ (entity-set e #:y (+ (entity-ref e #:y 0) vy)))))
+ e))
+
+;; Build list of (col . row) pairs to check for collisions
+(define (build-cell-list col-start col-end row-start row-end)
+ (let loop ((col col-start) (row row-start) (acc '()))
+ (log-debug "Build-cell-list loop with: ~a" (list col row acc))
+ (if (> col col-end)
+ (if (>= row row-end)
+ (reverse acc)
+ (loop col-start (+ row 1) acc))
+ (loop (+ col 1) row (cons (cons col row) acc)))))
+
+;; Convert a pixel coordinate to a tile grid index
+(define (pixel->tile pixel tile-size)
+ (inexact->exact (floor (/ pixel tile-size))))
+
+;; Return all tile cells (col . row) overlapping the entity's bounding box
+(define (entity-tile-cells entity tilemap)
+ (let ((x (entity-ref entity #:x 0))
+ (y (entity-ref entity #:y 0))
+ (w (entity-ref entity #:width 0))
+ (h (entity-ref entity #:height 0))
+ (tw (tilemap-tilewidth tilemap))
+ (th (tilemap-tileheight tilemap)))
+ (build-cell-list
+ (pixel->tile x tw)
+ (pixel->tile (- (+ x w) 1) tw)
+ (pixel->tile y th)
+ (pixel->tile (- (+ y h) 1) th))))
+
+;; Snap position to the near or far edge of a tile after collision.
+;; Moving forward (v>0): snap entity's leading edge to tile's near edge.
+;; Moving backward (v<0): snap entity's trailing edge to tile's far edge.
+(define (tile-push-pos v coord tile-size entity-size)
+ (if (> v 0)
+ (- (* coord tile-size) entity-size)
+ (* (+ coord 1) tile-size)))
+
+;; Resolve collisions with tiles along a single axis.
+;; push-fn: (v col row) -> new-pos
+;; For v>0 (moving right/down): snap to the FIRST solid cell (shallowest penetration).
+;; For v<0 (moving left/up): snap to the LAST solid cell (deepest penetration from above/left).
+(define (resolve-tile-collisions-axis entity tilemap vel-key pos-key push-fn)
+ (let ((v (entity-ref entity vel-key 0)))
+ (if (zero? v)
+ entity
+ (fold (lambda (cell acc)
+ (log-debug "resolve-~a: cell=~a acc=~a" vel-key cell acc)
+ (let* ((col (car cell))
+ (row (cdr cell))
+ (tile-id (tilemap-tile-at tilemap col row)))
+ (if (zero? tile-id)
+ acc
+ (if (and (> v 0) (zero? (entity-ref acc vel-key v)))
+ acc ; v>0: first collision already resolved, don't overwrite
+ (entity-set (entity-set acc pos-key (push-fn v col row)) vel-key 0)))))
+ entity
+ (entity-tile-cells entity tilemap)))))
+
+;; Resolve horizontal collisions with solid tiles
+(define-pipeline (resolve-tile-collisions-x tile-collisions-x) (scene entity dt)
+ guard: (scene-tilemap scene)
+ (let* ((tilemap (scene-tilemap scene))
+ (w (entity-ref entity #:width 0))
+ (tw (tilemap-tilewidth tilemap)))
+ (resolve-tile-collisions-axis entity tilemap #:vx #:x
+ (lambda (v col row) (tile-push-pos v col tw w)))))
+
+;; Resolve vertical collisions with solid tiles
+(define-pipeline (resolve-tile-collisions-y tile-collisions-y) (scene entity dt)
+ guard: (scene-tilemap scene)
+ (let* ((tilemap (scene-tilemap scene))
+ (h (entity-ref entity #:height 0))
+ (th (tilemap-tileheight tilemap)))
+ (resolve-tile-collisions-axis entity tilemap #:vy #:y
+ (lambda (v col row) (tile-push-pos v row th h)))))
+
+;; True if ~self~ is supported by another solid's top surface (moving platforms, crates, …).
+(define (entity-solid-support-below? self others)
+ (let* ((bx (entity-ref self #:x 0))
+ (bw (entity-ref self #:width 0))
+ (by (entity-ref self #:y 0))
+ (bh (entity-ref self #:height 0))
+ (bottom (+ by bh))
+ (vy (abs (entity-ref self #:vy 0))))
+ (and (<= vy *entity-ground-vy-max*)
+ (any (lambda (o)
+ (and (not (eq? self o))
+ (entity-ref o #:solid? #f)
+ (let* ((ox (entity-ref o #:x 0))
+ (oy (entity-ref o #:y 0))
+ (ow (entity-ref o #:width 0)))
+ (and (< bx (+ ox ow))
+ (< ox (+ bx bw))
+ (<= (abs (- bottom oy)) *entity-ground-contact-tolerance*)))))
+ others))))
+
+(define (tile-ground-below? entity tilemap)
+ (let* ((x (entity-ref entity #:x 0))
+ (w (entity-ref entity #:width 0))
+ (tw (tilemap-tilewidth tilemap))
+ (th (tilemap-tileheight tilemap))
+ (probe-y (+ (entity-ref entity #:y 0)
+ (entity-ref entity #:height 0)
+ 1))
+ (row (pixel->tile probe-y th))
+ (col-left (pixel->tile x tw))
+ (col-right (pixel->tile (- (+ x w) 1) tw)))
+ (or (not (zero? (tilemap-tile-at tilemap col-left row)))
+ (not (zero? (tilemap-tile-at tilemap col-right row))))))
+
+(define-pipeline (detect-on-solid on-solid) (scene entity dt)
+ guard: (entity-ref entity #:gravity? #f)
+ (let* ((tilemap (scene-tilemap scene))
+ (on-tile? (and tilemap (tile-ground-below? entity tilemap)))
+ (on-entity? (entity-solid-support-below? entity (scene-entities scene))))
+ (entity-set entity #:on-ground? (or on-tile? on-entity?))))
+
+;; Replace element at idx in lst with val
+(define (list-set lst idx val)
+ (let loop ((lst lst) (i 0) (acc '()))
+ (if (null? lst)
+ (reverse acc)
+ (loop (cdr lst) (+ i 1)
+ (cons (if (= i idx) val (car lst)) acc)))))
+
+;; Generate all unique (i . j) index pairs where i < j
+(define (index-pairs n)
+ (if (< n 2) '()
+ (apply append
+ (map (lambda (i)
+ (map (lambda (j) (cons i j))
+ (iota (- n i 1) (+ i 1))))
+ (iota (- n 1))))))
+
+(define (axis->dimension axis)
+ (case axis
+ ((#:x) #:width)
+ ((#:y) #:height)))
+
+(define (axis->velocity axis)
+ (case axis
+ ((#:x) #:vx)
+ ((#:y) #:vy)))
+
+;; Push entity along one axis by half-overlap, setting velocity in push direction
+(define (push-entity entity pos-key vel-key pos overlap sign)
+ (entity-set (entity-set entity pos-key (+ pos (* sign (/ overlap 2)))) vel-key sign))
+
+
+(define (entity-center-on-axis entity axis)
+ (let ((dimension (axis->dimension axis)))
+ (+ (entity-ref entity axis 0) (/ (entity-ref entity dimension 0) 2))))
+
+(define (aabb-overlap-on-axis axis a b)
+ (let ((dimension (axis->dimension axis)))
+ (- (/ (+ (entity-ref a dimension 0) (entity-ref b dimension 0)) 2)
+ (abs (- (entity-center-on-axis b axis) (entity-center-on-axis a axis))))))
+
+(define (push-along-axis axis a b overlap)
+ (let* ((a-center (entity-center-on-axis a axis))
+ (b-center (entity-center-on-axis b axis))
+ (delta (if (< a-center b-center) -1 1))
+ (axis-velocity-key (axis->velocity axis)))
+ (cons (push-entity a axis axis-velocity-key (entity-ref a axis 0) overlap delta)
+ (push-entity b axis axis-velocity-key (entity-ref b axis 0) overlap (- delta)))))
+
+;; Push two overlapping entities apart along the minimum penetration axis.
+;; Returns (a2 . b2) with updated positions and velocities.
+(define (push-apart a b)
+ (let* ((ovx (aabb-overlap-on-axis #:x a b))
+ (ovy (aabb-overlap-on-axis #:y a b)))
+ (if (<= ovx ovy)
+ (push-along-axis #:x a b ovx)
+ (push-along-axis #:y a b ovy))))
+
+;; Move ~m~ out of ~s~ along the shallow penetration axis; ~s~ is unchanged.
+;; Used when ~s~ has #:immovable? #t.
+;;
+;; When ~m~ is falling onto ~s~ from above, the minimum-penetration axis can be
+;; horizontal (narrow overlap in X but deeper in Y), which shoves the mover
+;; sideways instead of resting it on the platform. Prefer vertical separation
+;; whenever ~m~'s center is still above ~s~'s center (landing contact).
+(define (push-movable-along-axis m s axis overlap)
+ (let* ((mc (entity-center-on-axis m axis))
+ (sc (entity-center-on-axis s axis))
+ (dir (if (< mc sc) -1 1))
+ (pos (entity-ref m axis 0))
+ (vel (axis->velocity axis)))
+ (entity-set (entity-set m axis (+ pos (* dir overlap))) vel 0)))
+
+(define (separate-movable-from-static m s)
+ (let* ((ovx (aabb-overlap-on-axis #:x m s))
+ (ovy (aabb-overlap-on-axis #:y m s))
+ (land-on-top? (and (< (entity-center-on-axis m #:y)
+ (entity-center-on-axis s #:y))
+ (> ovy 0))))
+ (cond
+ (land-on-top? (push-movable-along-axis m s #:y ovy))
+ ((<= ovx ovy) (push-movable-along-axis m s #:x ovx))
+ (else (push-movable-along-axis m s #:y ovy)))))
+
+;; Check if two axis-aligned bounding boxes overlap.
+;; Returns #t if they overlap, #f if they don't (including edge-touching).
+(define (aabb-overlap? x1 y1 w1 h1 x2 y2 w2 h2)
+ (not (or (>= x1 (+ x2 w2))
+ (>= x2 (+ x1 w1))
+ (>= y1 (+ y2 h2))
+ (>= y2 (+ y1 h1)))))
+
+;; Resolve AABB collision between two solid entities.
+;; Returns (a2 . b2) with positions/velocities adjusted, or #f if no collision.
+;; #:immovable? #t marks static geometry; only the other entity is displaced.
+(define (resolve-pair a b)
+ (and (not (downstroke-entity#entity-skips-pipeline? a 'entity-collisions))
+ (not (downstroke-entity#entity-skips-pipeline? b 'entity-collisions))
+ (entity-ref a #:solid? #f)
+ (entity-ref b #:solid? #f)
+ (aabb-overlap? (entity-ref a #:x 0) (entity-ref a #:y 0)
+ (entity-ref a #:width 0) (entity-ref a #:height 0)
+ (entity-ref b #:x 0) (entity-ref b #:y 0)
+ (entity-ref b #:width 0) (entity-ref b #:height 0))
+ (let ((ia (entity-ref a #:immovable? #f))
+ (ib (entity-ref b #:immovable? #f)))
+ (cond
+ ((and ia ib) #f)
+ (ia (let ((b2 (separate-movable-from-static b a)))
+ (and b2 (cons a b2))))
+ (ib (let ((a2 (separate-movable-from-static a b)))
+ (and a2 (cons a2 b))))
+ (else (push-apart a b))))))
+
+;; Detect and resolve AABB overlaps between all pairs of solid entities.
+;; Returns a new entity list with collisions resolved.
+(define (resolve-entity-collisions entities)
+ (fold (lambda (pair ents)
+ (let* ((i (car pair)) (j (cdr pair))
+ (result (resolve-pair (list-ref ents i) (list-ref ents j))))
+ (if result
+ (list-set (list-set ents i (car result)) j (cdr result))
+ ents)))
+ entities
+ (index-pairs (length entities))))
)
generated by cgit v1.2.3 (git 2.46.0) at 2026-04-20 22:12:55 +0000