path: root/physics.scm

(module downstroke-physics *
  (import scheme
      (chicken base)
      (chicken keyword)
      (only srfi-1 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)

  ;; Consume #:ay into #:vy and clear it (one-shot acceleration)
  (define (apply-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 (apply-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 (apply-velocity-x entity)
    "Update entity's x by its vx velocity."
    (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 (apply-velocity-y entity)
    "Update entity's y by its vy velocity."
    (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)))
      (entity-set (entity-set entity #:x (+ x vx)) #:y (+ y vy))))

  ;; 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 (resolve-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 (resolve-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)))))

  ;; Detect if entity is standing on ground by probing 1px below feet
  (define (detect-ground entity tilemap)
    (if (not (entity-ref entity #:gravity? #f))
        entity
        (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))
               (on-ground? (or (not (zero? (tilemap-tile-at tilemap col-left row)))
                               (not (zero? (tilemap-tile-at tilemap col-right row))))))
          (entity-set entity #:on-ground? on-ground?))))

  ;; Set vertical acceleration for jump (consumed next frame by apply-acceleration)
  (define (apply-jump entity jump-pressed?)
    "Set #:ay to jump force if jump pressed and entity is on ground."
    (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))))

  ;; 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.
  (define (resolve-pair a b)
    (and (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))
         (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))))

  ;; Wrapper for scene-resolve-collisions
  (define (scene-resolve-collisions scene)
    (scene-entities-set! scene
      (resolve-entity-collisions (scene-entities scene)))
    scene))