From f8cc4a748bb8b6431a1023a876745b1bb473eb19 Mon Sep 17 00:00:00 2001
From: Gene Pasquet <dev@etenil.net>
Date: Wed, 8 Apr 2026 00:30:11 +0100
Subject: Support entity groups

---
 demo/tweens.scm | 268 +++++++++++++++++++++++++++++---------------------------
 1 file changed, 141 insertions(+), 127 deletions(-)

(limited to 'demo/tweens.scm')

diff --git a/demo/tweens.scm b/demo/tweens.scm
index ad9c80b..34c7759 100644
--- a/demo/tweens.scm
+++ b/demo/tweens.scm
@@ -1,6 +1,7 @@
 (import scheme
         (chicken base)
-        (only srfi-1 iota map)
+        (only srfi-1 iota)
+        (only srfi-197 chain)
         (prefix sdl2 "sdl2:")
         (prefix sdl2-ttf "ttf:")
         downstroke-engine
@@ -10,120 +11,130 @@
         downstroke-entity
         downstroke-tween)
 
-;; One row per easing symbol: #(entity tween left-x right-x ease-sym to-right?)
-(define *ease-cells* #f)
+;; ── Constants ────────────────────────────────────────────────────────────────
 
-(define *knock-ent* #f)
-(define *knock-tw* #f)
-(define *knock-cd* 0)
+(define +ease-duration+ 2600)
+(define +knock-cooldown-ms+ 3200)
+(define +knock-distance+ 88)
+(define +knock-duration+ 650)
+(define +knock-skip+ '(jump acceleration gravity velocity-x velocity-y))
 
-(define +knock-skip+
-  '(jump acceleration gravity velocity-x velocity-y))
-
-(define *ease-syms*
+(define +ease-syms+
   '(linear quad-in quad-out quad-in-out cubic-in cubic-out cubic-in-out
     sine-in-out expo-in expo-out expo-in-out back-out))
 
-;; Distinct RGB triples for each easing row (no tileset).
-(define *ease-colors*
-  '((220 90 90)
-    (240 140 60)
-    (240 200 60)
-    (180 220 70)
-    (80 200 120)
-    (70 180 200)
-    (100 140 240)
-    (160 100 220)
-    (220 80 180)
-    (100 100 110)
-    (140 180 200)
-    (200 120 80)))
-
-(define *label-font* #f)
-(define *title-font* #f)
+(define +ease-colors+
+  '((220  90  90) (240 140  60) (240 200  60) (180 220  70)
+    ( 80 200 120) ( 70 180 200) (100 140 240) (160 100 220)
+    (220  80 180) (100 100 110) (140 180 200) (200 120  80)))
 
-(define (clamp-entity-to-screen e gw gh)
-  "Clamp position and zero velocity on edges; set #:on-ground? on bottom when using gravity."
-  (let* ((w  (entity-ref e #:width 0))
-         (h  (entity-ref e #:height 0))
-         (x  (entity-ref e #:x 0))
-         (y  (entity-ref e #:y 0))
-         (vx (entity-ref e #:vx 0))
-         (vy (entity-ref e #:vy 0))
-         (nx (max 0 (min (- gw w) x)))
-         (ny (max 0 (min (- gh h) y)))
-         (ground? (and (entity-ref e #:gravity? #f) (= ny (- gh h))))
-         (e (entity-set e #:x nx))
-         (e (entity-set e #:y ny))
-         (e (entity-set e #:vx (if (= nx x) vx 0)))
-         (e (entity-set e #:vy (if (= ny y) vy 0)))
-         (e (entity-set e #:on-ground? ground?)))
-    e))
+;; ── State ────────────────────────────────────────────────────────────────────
+
+(define *ease-cells*  #f)   ; vector of #(ent tw left right ease-sym to-right?)
+(define *knock-ent*   #f)
+(define *knock-tw*    #f)
+(define *knock-cd*    0)
+(define *label-font*  #f)
+(define *title-font*  #f)
+
+;; ── Ease grid ────────────────────────────────────────────────────────────────
 
 (define (make-ease-cell ease-sym y rgb)
-  (let* ((left 20)
+  (let* ((left  20)
          (right (+ left 120))
-         (ent (list #:type 'tween-demo #:x left #:y y #:width 14 #:height 14
-                    #:vx 0 #:vy 0 #:gravity? #f #:solid? #f #:color rgb))
-         (tw (make-tween ent props: `((#:x . ,right)) duration: 2600 ease: ease-sym)))
+         (ent   (list #:type 'tween-demo #:x left #:y y
+                      #:width 14 #:height 14
+                      #:vx 0 #:vy 0 #:gravity? #f #:solid? #f #:color rgb))
+         (tw    (make-tween ent props: `((#:x . ,right))
+                  duration: +ease-duration+ ease: ease-sym)))
     (vector ent tw left right ease-sym #t)))
 
 (define (advance-ease-cell! cell dt)
-  (let ((ent (vector-ref cell 0))
-        (tw (vector-ref cell 1))
-        (left (vector-ref cell 2))
-        (right (vector-ref cell 3))
-        (ease (vector-ref cell 4))
+  (let ((ent      (vector-ref cell 0))
+        (tw       (vector-ref cell 1))
+        (left     (vector-ref cell 2))
+        (right    (vector-ref cell 3))
+        (ease     (vector-ref cell 4))
         (to-right? (vector-ref cell 5)))
     (receive (tw2 ent2) (tween-step tw ent dt)
       (vector-set! cell 0 ent2)
-      (cond ((tween-finished? tw2)
-             (let* ((next-to-right? (not to-right?))
-                    (target-x (if next-to-right? right left))
-                    (tw3 (make-tween ent2 props: `((#:x . ,target-x))
-                                     duration: 2600 ease: ease)))
-               (vector-set! cell 1 tw3)
-               (vector-set! cell 5 next-to-right?)))
-            (else (vector-set! cell 1 tw2))))))
+      (if (tween-finished? tw2)
+          (let* ((next-dir (not to-right?))
+                 (target   (if next-dir right left)))
+            (vector-set! cell 1 (make-tween ent2 props: `((#:x . ,target))
+                                  duration: +ease-duration+ ease: ease))
+            (vector-set! cell 5 next-dir))
+          (vector-set! cell 1 tw2)))))
 
-(define (update-knockback! dt tm gw gh)
-  (set! *knock-cd* (+ *knock-cd* dt))
-  (when (and *knock-ent* (not *knock-tw*) (>= *knock-cd* 3200))
+;; ── Knockback crate ──────────────────────────────────────────────────────────
+
+(define (run-physics e tm)
+  (chain e
+         (apply-jump _ #f)
+         (apply-acceleration _)
+         (apply-gravity _)
+         (apply-velocity-x _)
+         (resolve-tile-collisions-x _ tm)
+         (apply-velocity-y _)
+         (resolve-tile-collisions-y _ tm)
+         (detect-on-solid _ tm)))
+
+(define (clamp-entity-to-screen e gw gh)
+  (let* ((w  (entity-ref e #:width 0))
+         (h  (entity-ref e #:height 0))
+         (x  (entity-ref e #:x 0))
+         (y  (entity-ref e #:y 0))
+         (nx (max 0 (min (- gw w) x)))
+         (ny (max 0 (min (- gh h) y)))
+         (on-floor? (and (entity-ref e #:gravity? #f) (= ny (- gh h)))))
+    (chain e
+           (entity-set _ #:x nx)
+           (entity-set _ #:y ny)
+           (entity-set _ #:vx (if (= nx x) (entity-ref e #:vx 0) 0))
+           (entity-set _ #:vy (if (= ny y) (entity-ref e #:vy 0) 0))
+           (entity-set _ #:on-ground? on-floor?))))
+
+(define (run-physics-no-tilemap e gw gh)
+  (chain e
+         (apply-jump _ #f)
+         (apply-acceleration _)
+         (apply-gravity _)
+         (apply-velocity-x _)
+         (apply-velocity-y _)
+         (clamp-entity-to-screen _ gw gh)))
+
+(define (maybe-start-knockback!)
+  (when (and *knock-ent* (not *knock-tw*) (>= *knock-cd* +knock-cooldown-ms+))
     (set! *knock-cd* 0)
     (let ((x (entity-ref *knock-ent* #:x 0)))
       (set! *knock-ent* (entity-set *knock-ent* #:skip-pipelines +knock-skip+))
-      (set! *knock-tw* (make-tween *knock-ent*
-                      props: `((#:x . ,(+ x 88)))
-                      duration: 650
-                      ease: 'back-out
-                      on-complete: (lambda (e)
-                                     (set! *knock-ent* (entity-set e #:skip-pipelines '())))))))
+      (set! *knock-tw*
+        (make-tween *knock-ent*
+          props: `((#:x . ,(+ x +knock-distance+)))
+          duration: +knock-duration+
+          ease: 'back-out
+          on-complete: (lambda (e)
+                         (set! *knock-ent* (entity-set e #:skip-pipelines '()))))))))
+
+(define (advance-knockback-tween! dt)
   (when *knock-tw*
     (receive (t2 e2) (tween-step *knock-tw* *knock-ent* dt)
-      (set! *knock-tw* (if (tween-finished? t2) #f t2))
-      (set! *knock-ent* e2)))
+      (set! *knock-tw*  (if (tween-finished? t2) #f t2))
+      (set! *knock-ent* e2))))
+
+(define (update-knockback! dt tm gw gh)
+  (set! *knock-cd* (+ *knock-cd* dt))
+  (maybe-start-knockback!)
+  (advance-knockback-tween! dt)
   (when *knock-ent*
     (set! *knock-ent*
       (if tm
-          (let* ((e *knock-ent*)
-                 (e (apply-jump e #f))
-                 (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 (detect-on-solid e tm)))
-            e)
-          (let* ((e *knock-ent*)
-                 (e (apply-jump e #f))
-                 (e (apply-acceleration e))
-                 (e (apply-gravity e))
-                 (e (apply-velocity-x e))
-                 (e (apply-velocity-y e)))
-            (clamp-entity-to-screen e gw gh))))))
-
-(define (tweens-demo-render-labels! renderer)
+          (run-physics *knock-ent* tm)
+          (run-physics-no-tilemap *knock-ent* gw gh)))))
+
+;; ── Rendering ────────────────────────────────────────────────────────────────
+
+(define (draw-ease-labels! renderer)
   (let ((white (sdl2:make-color 255 255 255 255)))
     (draw-ui-text renderer *title-font*
       "Tween demo - easing rows + knockback / skip-pipelines" white 12 6)
@@ -132,54 +143,57 @@
       white 12 32)
     (do ((i 0 (+ i 1))) ((>= i (vector-length *ease-cells*)))
       (let* ((cell (vector-ref *ease-cells* i))
-             (ent (vector-ref cell 0))
-             (lab (symbol->string (vector-ref cell 4))))
-        (draw-ui-text renderer *label-font* lab white 158 (- (entity-ref ent #:y 0) 2))))))
+             (ent  (vector-ref cell 0))
+             (lab  (symbol->string (vector-ref cell 4))))
+        (draw-ui-text renderer *label-font* lab white
+          158 (- (entity-ref ent #:y 0) 2))))))
+
+(define (ease-cell-entities)
+  (map (lambda (i) (vector-ref (vector-ref *ease-cells* i) 0))
+       (iota (vector-length *ease-cells*))))
+
+;; ── Game ─────────────────────────────────────────────────────────────────────
 
 (define *game*
   (make-game
     title: "Demo: Tweens" width: 640 height: 480
+
     preload: (lambda (_game)
       (set! *title-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 22))
       (set! *label-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 13)))
+
     create: (lambda (game)
-      (let ((scene (make-scene entities: '()
-                               tilemap: #f
-                               camera: (make-camera x: 0 y: 0)
-                               tileset-texture: #f
-                               camera-target: #f
-                               background: '(26 28 34))))
-        (set! *ease-cells*
-          (list->vector
-            (map (lambda (ease i)
-                   (make-ease-cell ease (+ 52 (* i 20))
-                     (list-ref *ease-colors* i)))
-                 *ease-syms*
-                 (iota (length *ease-syms*)))))
-        (set! *knock-ent*
-          (list #:type 'knock-crate #:x 200 #:y 80 #:width 18 #:height 18
-                #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f #:solid? #f
-                #:color '(140 110 70)))
-        (set! *knock-tw* #f)
-        (set! *knock-cd* 2500)
-        (scene-entities-set! scene
-          (append (map (lambda (i) (vector-ref (vector-ref *ease-cells* i) 0))
-                       (iota (vector-length *ease-cells*)))
-                  (list *knock-ent*)))
-        (game-scene-set! game scene)))
+      (set! *ease-cells*
+        (list->vector
+          (map (lambda (ease i)
+                 (make-ease-cell ease (+ 52 (* i 20)) (list-ref +ease-colors+ i)))
+               +ease-syms+ (iota (length +ease-syms+)))))
+      (set! *knock-ent*
+        (list #:type 'knock-crate #:x 200 #:y 80
+              #:width 18 #:height 18
+              #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f #:solid? #f
+              #:color '(140 110 70)))
+      (set! *knock-tw* #f)
+      (set! *knock-cd* 2500)
+      (game-scene-set! game
+        (make-scene entities: (append (ease-cell-entities) (list *knock-ent*))
+                     tilemap: #f
+                     camera: (make-camera x: 0 y: 0)
+                     tileset-texture: #f
+                     camera-target: #f
+                     background: '(26 28 34))))
+
     update: (lambda (game dt)
-      (let* ((scene (game-scene game))
-             (tm (scene-tilemap scene))
-             (gw (game-width game))
-             (gh (game-height game)))
+      (let ((tm (scene-tilemap (game-scene game)))
+            (gw (game-width game))
+            (gh (game-height game)))
         (do ((i 0 (+ i 1))) ((>= i (vector-length *ease-cells*)))
           (advance-ease-cell! (vector-ref *ease-cells* i) dt))
         (update-knockback! dt tm gw gh)
-        (scene-entities-set! scene
-          (append (map (lambda (i) (vector-ref (vector-ref *ease-cells* i) 0))
-                       (iota (vector-length *ease-cells*)))
-                  (list *knock-ent*)))))
+        (scene-entities-set! (game-scene game)
+          (append (ease-cell-entities) (list *knock-ent*)))))
+
     render: (lambda (game)
-      (tweens-demo-render-labels! (game-renderer game)))))
+      (draw-ease-labels! (game-renderer game)))))
 
 (game-run! *game*)
-- 
cgit v1.2.3