path: root/physics.scm

(module downstroke-physics
    (scene-resolve-collisions 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 apply-jump 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) (entity)
    (if (not (entity-ref entity #:gravity? #f))
        entity
        (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) (entity)
    (if (entity-ref entity #:gravity? #f)
        (entity-set entity #:vy (+ (entity-ref entity #:vy) *gravity*))
        entity))

  ;; Update entity's x by its vx velocity
  (define-pipeline (apply-velocity-x velocity-x) (entity)
    (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) (entity)
    (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)))))
                entity
                (entity-tile-cells entity tilemap)))))

  ;; Resolve horizontal collisions with solid tiles
  (define-pipeline (resolve-tile-collisions-x tile-collisions-x) (entity tilemap)
    (let ((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) (entity tilemap)
    (let ((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)
      (entity tilemap #!optional (other-entities #f))
    (if (not (entity-ref entity #:gravity? #f))
        entity
        (let* ((on-tile?   (and tilemap (tile-ground-below? entity tilemap)))
               (on-entity? (and other-entities
                                (entity-solid-support-below? entity other-entities))))
          (entity-set entity #:on-ground? (or on-tile? on-entity?)))))

  ;; Set vertical acceleration for jump (consumed next frame by apply-acceleration)
  (define-pipeline (apply-jump jump) (entity jump-pressed?)
    (if (and jump-pressed? (entity-ref entity #:on-ground? #f))
        (entity-set entity #:ay (- (entity-ref entity #:jump-force *jump-force*)))
        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))))

  ;; Returns a new scene with entity-entity collisions resolved.
  (define (scene-resolve-collisions scene)
    (update-scene scene
      entities: (resolve-entity-collisions (scene-entities scene)))))