Initial port of macroknight to an engine

1 files changed, 238 insertions, 0 deletions

diff --git a/physics.scm b/physics.scm
new file mode 100644
index 0000000..83cc85b
--- /dev/null
+++ b/physics.scm
@@ -0,0 +1,238 @@
+(module physics *
+  (import scheme
+      (chicken base)
+      (chicken keyword)
+      (only srfi-1 fold iota)
+      defstruct
+      tilemap
+      entity
+      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
+  (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
+                        (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))