Support entity groups

1 files changed, 164 insertions, 117 deletions

diff --git a/demo/sandbox.scm b/demo/sandbox.scm
index ad2e056..d7bd53f 100644
--- a/demo/sandbox.scm
+++ b/demo/sandbox.scm
@@ -1,7 +1,8 @@
 (import scheme
         (chicken base)
         (chicken random)
-        (only srfi-1 drop iota take)
+        (only srfi-1 iota take)
+        (only srfi-197 chain)
         (prefix sdl2 "sdl2:")
         (prefix sdl2-ttf "ttf:")
         (prefix sdl2-image "img:")
@@ -11,147 +12,193 @@
         downstroke-physics
         downstroke-assets
         downstroke-entity
-        downstroke-scene-loader)
-
-(define *demo-t* 0.0)
-
-(define +static-skip+
-  '(jump acceleration gravity velocity-x velocity-y
-    tile-collisions-x tile-collisions-y on-solid))
-
-;; Mid-level shelf only: immovable solid AABBs (same layout as the old tilemap shelf).
-(define (make-shelf-platform gw gh tw th)
-  (let* ((shelf-tile-id 20)
-         (shelf-c0 10)
-         (shelf-n 10)
-         (x0 (* shelf-c0 tw))
-         (y  (- gh (* 6 th))))
-    (map (lambda (i)
-           (list #:type 'static-tile
-                 #:x (+ x0 (* i tw)) #:y y #:width tw #:height th
-                 #:tile-id shelf-tile-id #:solid? #t #:immovable? #t
-                 #:gravity? #f #:vx 0 #:vy 0 #:on-ground? #f
-                 #:skip-pipelines +static-skip+))
-         (iota shelf-n))))
-
-;; Floor only on the tilemap; shelf is entities (see make-shelf-platform).
+        downstroke-scene-loader
+        downstroke-tween
+        downstroke-prefabs)
+
+;; ── Constants ────────────────────────────────────────────────────────────────
+
+(define +game-width+  600)
+(define +game-height+ 400)
+
+(define +demo-bot-cycle-ms+          2600.0)
+(define +demo-bot-half-cycle-ms+     (/ +demo-bot-cycle-ms+ 2.0))
+(define +demo-bot-jump-interval-ms+  720.0)
+
+;; ── Mutable demo state ──────────────────────────────────────────────────────
+
+(define *demo-t*        0.0)
+(define *shelf-endpoints* #f)
+(define *shelf-tween*     #f)
+(define *shelf-origin*    #f)
+
+;; ── Tween helpers ────────────────────────────────────────────────────────────
+
+(define (other-endpoint x endpoints)
+  (let ((lo (car endpoints))
+        (hi (cdr endpoints)))
+    (if (< (abs (- x lo)) (abs (- x hi))) hi lo)))
+
+(define (make-ping-pong-tween leader endpoints)
+  (make-tween leader
+    props: `((#:x . ,(other-endpoint (entity-ref leader #:x 0) endpoints)))
+    duration: 3500 ease: 'sine-in-out))
+
+(define (scene-replace-group-origin! scene gid new-origin)
+  (scene-entities-set! scene
+    (map (lambda (e)
+           (if (and (entity-ref e #:group-origin? #f)
+                    (eq? (entity-ref e #:group-id) gid))
+               new-origin
+               e))
+         (scene-entities scene))))
+
+(define (advance-shelf-tween! scene dt)
+  (when (and *shelf-tween* *shelf-origin*)
+    (let ((gid (entity-ref *shelf-origin* #:group-id)))
+      (receive (tw2 e0) (tween-step *shelf-tween* *shelf-origin* dt)
+        (set! *shelf-tween* (if (tween-finished? tw2)
+                                (make-ping-pong-tween e0 *shelf-endpoints*)
+                                tw2))
+        (set! *shelf-origin* e0)
+        (scene-replace-group-origin! scene gid e0)))))
+
+;; ── Tilemap builder ──────────────────────────────────────────────────────────
+
 (define (make-sandbox-tilemap ts tw th gw gh)
-  (let* ((ncols (inexact->exact (ceiling (/ gw tw))))
-         (nrows (inexact->exact (ceiling (/ gh th))))
-         (floor-tile 20)
-         (air (map (lambda (_) (map (lambda (_) 0) (iota ncols))) (iota nrows)))
-         (floor-row (map (lambda (_) floor-tile) (iota ncols)))
-         (map-data (append (take air (- nrows 1)) (list floor-row)))
-         (layer (make-layer name: "ground"
-                            width: ncols height: nrows
-                            map: map-data)))
-    (make-tilemap width: ncols height: nrows
-                  tilewidth: tw tileheight: th
-                  tileset-source: ""
-                  tileset: ts
-                  layers: (list layer)
-                  objects: '())))
+  (let* ((ncols     (inexact->exact (ceiling (/ gw tw))))
+         (nrows     (inexact->exact (ceiling (/ gh th))))
+         (empty-row (map (lambda (_) 0) (iota ncols)))
+         (floor-row (map (lambda (_) 20) (iota ncols)))
+         (map-data  (append (map (lambda (_) empty-row) (iota (- nrows 1)))
+                            (list floor-row))))
+    (make-tilemap
+      width: ncols height: nrows
+      tilewidth: tw tileheight: th
+      tileset-source: "" tileset: ts
+      layers: (list (make-layer name: "ground"
+                                width: ncols height: nrows
+                                map: map-data))
+      objects: '())))
+
+;; ── Entity factories ─────────────────────────────────────────────────────────
+
+(define (make-box x y tw th)
+  (list #:type 'box
+        #:x x #:y y #:width tw #:height th
+        #:vx 0 #:vy 0
+        #:gravity? #t #:on-ground? #f
+        #:solid? #t #:immovable? #f
+        #:tile-id 29))
 
 (define (spawn-boxes tw th)
   (map (lambda (i)
-         (list #:type 'box
-               #:x (+ 30 (* i 55)) #:y (+ 10 (* (pseudo-random-integer 4) 20))
-               #:width tw #:height th
-               #:vx 0 #:vy 0
-               #:gravity? #t #:on-ground? #f
-               #:solid? #t #:immovable? #f
-               #:tile-id 29))
+         (make-box (+ 30 (* i 55))
+                   (+ 10 (* (pseudo-random-integer 4) 20))
+                   tw th))
        (iota 8)))
 
-;; #:demo-id offsets phase; #:demo-since-jump accumulates ms for jump cadence.
 (define (make-demo-bot x y tw th id)
   (list #:type 'demo-bot
-        #:x x #:y y
-        #:width tw #:height th
+        #:x x #:y y #:width tw #:height th
         #:vx 0 #:vy 0
         #:gravity? #t #:on-ground? #f
         #:solid? #t #:immovable? #f
         #:tile-id 1
-        #:demo-id id
-        #:demo-since-jump 0))
+        #:demo-id id #:demo-since-jump 0))
+
+;; ── Per-entity physics ──────────────────────────────────────────────────────
+
+(define (run-physics e tm)
+  (chain e
+         (apply-gravity _)
+         (apply-velocity-x _)
+         (resolve-tile-collisions-x _ tm)
+         (apply-velocity-y _)
+         (resolve-tile-collisions-y _ tm)))
 
 (define (update-demo-bot e dt tm)
-  (let* ((id (entity-ref e #:demo-id 0))
-         (cycle 2600.0)
-         (phase (modulo (+ *demo-t* (* id 400.0)) cycle))
-         (vx (if (< phase (/ cycle 2.0)) 3.0 -3.0))
-         (e (entity-set e #:vx vx))
-         ;; Set last frame by final pass: detect-on-solid after entity–entity resolve.
-         (ground? (entity-ref e #:on-ground? #f))
-         (since (+ (entity-ref e #:demo-since-jump 0) dt))
-         (jump-every 720.0)
-         (do-jump? (and ground? (>= since jump-every)))
-         (since (if do-jump? 0 since))
-         (e (entity-set e #:demo-since-jump since))
-         (e (apply-jump e do-jump?))
-         (e (apply-acceleration e))
-         (e (apply-gravity e))
-         (e (apply-velocity-x e))
-         (e (resolve-tile-collisions-x e tm))
-         (e (apply-velocity-y e))
-         (e (resolve-tile-collisions-y e tm)))
-    e))
-
-(define (update-box e tm)
-  (let* ((e (apply-gravity e))
-         (e (apply-velocity-x e))
-         (e (resolve-tile-collisions-x e tm))
-         (e (apply-velocity-y e))
-         (e (resolve-tile-collisions-y e tm)))
-    e))
+  (let* ((id       (entity-ref e #:demo-id 0))
+         (phase    (modulo (+ *demo-t* (* id 400.0)) +demo-bot-cycle-ms+))
+         (vx       (if (< phase +demo-bot-half-cycle-ms+) 3.0 -3.0))
+         (e        (entity-set e #:vx vx))
+         (ground?  (entity-ref e #:on-ground? #f))
+         (since    (+ (entity-ref e #:demo-since-jump 0) dt))
+         (jump?    (and ground? (>= since +demo-bot-jump-interval-ms+)))
+         (since    (if jump? 0 since)))
+    (chain (entity-set e #:demo-since-jump since)
+           (apply-jump _ jump?)
+           (apply-acceleration _)
+           (run-physics _ tm))))
+
+(define (integrate-entity e dt tm)
+  (case (entity-type e)
+    ((demo-bot) (update-demo-bot e dt tm))
+    ((box)      (run-physics e tm))
+    (else
+      (if (and (entity-ref e #:group-origin? #f)
+               (entity-ref e #:gravity? #f))
+          (run-physics e tm)
+          e))))
+
+;; ── Scene builder ───────────────────────────────────────────────────────────
+
+(define (init-shelf-tween! shelf-list tw)
+  (let* ((origin  (car shelf-list))
+         (x-left  (entity-ref origin #:x 0))
+         (x-right (+ x-left (* 6 tw))))
+    (set! *shelf-origin*    origin)
+    (set! *shelf-endpoints* (cons x-left x-right))
+    (set! *shelf-tween*     (make-ping-pong-tween origin *shelf-endpoints*))))
+
+(define (make-sandbox-scene game)
+  (let* ((reg  (load-prefabs "demo/assets/sandbox-groups.scm" (engine-mixins) '()))
+         (ts   (game-load-tileset! game 'tileset "demo/assets/monochrome_transparent.tsx"))
+         (tw   (tileset-tilewidth ts))
+         (th   (tileset-tileheight ts))
+         (tex  (create-texture-from-tileset (game-renderer game) ts))
+         (gw   (game-width game))
+         (gh   (game-height game))
+         (tm   (make-sandbox-tilemap ts tw th gw gh))
+         (shelf-list (instantiate-group-prefab reg 'shelf-platform
+                       (* 10 tw) (- gh (* 6 th))))
+         (raft-list  (instantiate-group-prefab reg 'collision-raft
+                       120 (- gh (* 14 th))))
+         (bots  (list (make-demo-bot  80 80 tw th 0)
+                      (make-demo-bot 220 60 tw th 1)
+                      (make-demo-bot 380 100 tw th 2))))
+    (init-shelf-tween! shelf-list tw)
+    (make-scene
+      entities:        (append shelf-list raft-list (spawn-boxes tw th) bots)
+      tilemap:         tm
+      tileset:         #f
+      camera:          (make-camera x: 0 y: 0)
+      tileset-texture: tex
+      camera-target:   #f
+      background:      '(32 34 40))))
+
+;; ── Game ─────────────────────────────────────────────────────────────────────
 
 (define *game*
   (make-game
-    title: "Demo: Physics Sandbox" width: 600 height: 400
+    title: "Demo: Physics Sandbox"
+    width: +game-width+ height: +game-height+
 
     create: (lambda (game)
-      (let* ((ts  (game-load-tileset! game 'tileset
-                   "demo/assets/monochrome_transparent.tsx"))
-             (tw  (tileset-tilewidth ts))
-             (th  (tileset-tileheight ts))
-             (tex (create-texture-from-tileset (game-renderer game) ts))
-             (gw  (game-width game))
-             (gh  (game-height game))
-             (tm  (make-sandbox-tilemap ts tw th gw gh))
-             (shelf (make-shelf-platform gw gh tw th))
-             (bots
-               (list (make-demo-bot 80  80 tw th 0)
-                     (make-demo-bot 220 60 tw th 1)
-                     (make-demo-bot 380 100 tw th 2)))
-             (entities (append shelf (spawn-boxes tw th) bots))
-             (scene (make-scene
-                      entities:        entities
-                      tilemap:         tm
-                      tileset:         #f
-                      camera:          (make-camera x: 0 y: 0)
-                      tileset-texture: tex
-                      camera-target:   #f
-                      background:      '(32 34 40))))
-        (game-scene-set! game scene)))
+      (game-scene-set! game (make-sandbox-scene game)))
 
     update: (lambda (game dt)
       (set! *demo-t* (+ *demo-t* dt))
       (let* ((scene (game-scene game))
              (tm    (scene-tilemap scene)))
+        (advance-shelf-tween! scene dt)
+        (scene-update-entities scene (lambda (e) (integrate-entity e dt tm)))
+        (scene-sync-groups! scene)
+        (scene-resolve-collisions scene)
         (scene-update-entities scene
           (lambda (e)
-            (cond
-              ((eq? (entity-type e) 'demo-bot)
-               (update-demo-bot e dt tm))
-              ((eq? (entity-type e) 'box)
-               (update-box e tm))
-              (else e))))
-        (scene-resolve-collisions scene)
-        (let ((post (scene-entities scene)))
-          (scene-update-entities scene
-            (lambda (e)
-              (if (entity-ref e #:gravity? #f)
-                  (detect-on-solid e tm post)
-                  e))))))))
+            (if (entity-ref e #:gravity? #f)
+                (detect-on-solid e tm (scene-entities scene))
+                e)))))))
 
 (game-run! *game*)