diff options
| -rw-r--r-- | animation.scm | 39 | ||||
| -rw-r--r-- | demo/sandbox.scm | 58 | ||||
| -rw-r--r-- | demo/tweens.scm | 175 | ||||
| -rw-r--r-- | docs/api.org | 20 | ||||
| -rw-r--r-- | docs/entities.org | 3 | ||||
| -rw-r--r-- | docs/tweens.org | 59 | ||||
| -rw-r--r-- | engine.scm | 112 | ||||
| -rw-r--r-- | input.scm | 24 | ||||
| -rw-r--r-- | physics.scm | 74 | ||||
| -rw-r--r-- | renderer.scm | 33 | ||||
| -rw-r--r-- | tests/tween-test.scm | 136 | ||||
| -rw-r--r-- | tween.scm | 104 | ||||
| -rw-r--r-- | world.scm | 31 |
13 files changed, 474 insertions, 394 deletions
diff --git a/animation.scm b/animation.scm index a152753..4caf1fe 100644 --- a/animation.scm +++ b/animation.scm @@ -32,24 +32,25 @@ ;; Pass the animation table for this entity's type. ;; Entities without #:anim-name are returned unchanged. + (define (advance-animation entity anim) + (let* ((tick (+ 1 (entity-ref entity #:anim-tick 0))) + (duration (animation-duration anim)) + (frames (animation-frames anim)) + (frame (entity-ref entity #:anim-frame 0))) + (if (>= tick duration) + (let ((new-frame (modulo (+ frame 1) (length frames)))) + (entity-set (entity-set (entity-set entity + #:anim-tick 0) + #:anim-frame new-frame) + #:tile-id (frame->tile-id frames new-frame))) + (entity-set (entity-set entity #:anim-tick tick) + #:tile-id (frame->tile-id frames frame))))) + (define (animate-entity entity animations) - (let ((anim-name (entity-ref entity #:anim-name #f))) - (if (not anim-name) - entity - (let* ((entry (assq anim-name animations)) - (anim (and entry (cdr entry)))) - (if (not anim) - entity - (let* ((tick (+ 1 (entity-ref entity #:anim-tick 0))) - (duration (animation-duration anim)) - (frames (animation-frames anim)) - (frame (entity-ref entity #:anim-frame 0))) - (if (>= tick duration) - (let ((new-frame (modulo (+ frame 1) (length frames)))) - (entity-set (entity-set (entity-set entity - #:anim-tick 0) - #:anim-frame new-frame) - #:tile-id (frame->tile-id frames new-frame))) - (entity-set (entity-set entity #:anim-tick tick) - #:tile-id (frame->tile-id frames frame))))))))) + (let* ((anim-name (entity-ref entity #:anim-name #f)) + (entry (and anim-name (assq anim-name animations))) + (anim (and entry (cdr entry)))) + (if anim + (advance-animation entity anim) + entity))) ) ;; End of animation module diff --git a/demo/sandbox.scm b/demo/sandbox.scm index d7bd53f..f757c7f 100644 --- a/demo/sandbox.scm +++ b/demo/sandbox.scm @@ -27,41 +27,7 @@ ;; ── 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))))) +(define *demo-t* 0.0) ;; ── Tilemap builder ────────────────────────────────────────────────────────── @@ -143,13 +109,16 @@ ;; ── Scene builder ─────────────────────────────────────────────────────────── -(define (init-shelf-tween! shelf-list tw) +(define (attach-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*)))) + (x-right (+ x-left (* 6 tw))) + (tweened (entity-set origin #:tween + (make-tween origin + props: `((#:x . ,x-right)) + duration: 3500 ease: 'sine-in-out + repeat: -1 yoyo?: #t)))) + (cons tweened (cdr shelf-list)))) (define (make-sandbox-scene game) (let* ((reg (load-prefabs "demo/assets/sandbox-groups.scm" (engine-mixins) '())) @@ -160,14 +129,15 @@ (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)))) + (shelf-list (attach-shelf-tween! + (instantiate-group-prefab reg 'shelf-platform + (* 10 tw) (- gh (* 6 th))) + tw)) (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 @@ -191,7 +161,7 @@ (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) (step-tweens e dt))) (scene-update-entities scene (lambda (e) (integrate-entity e dt tm))) (scene-sync-groups! scene) (scene-resolve-collisions scene) diff --git a/demo/tweens.scm b/demo/tweens.scm index 34c7759..a286a49 100644 --- a/demo/tweens.scm +++ b/demo/tweens.scm @@ -1,23 +1,17 @@ (import scheme (chicken base) (only srfi-1 iota) - (only srfi-197 chain) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") downstroke-engine downstroke-world downstroke-renderer - downstroke-physics downstroke-entity downstroke-tween) ;; ── Constants ──────────────────────────────────────────────────────────────── (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 +ease-syms+ '(linear quad-in quad-out quad-in-out cubic-in cubic-out cubic-in-out @@ -30,127 +24,39 @@ ;; ── 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) +(define (make-ease-entity ease-sym y rgb) (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: +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)) - (to-right? (vector-ref cell 5))) - (receive (tw2 ent2) (tween-step tw ent dt) - (vector-set! cell 0 ent2) - (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))))) - -;; ── 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 +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)))) - -(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 - (run-physics *knock-ent* tm) - (run-physics-no-tilemap *knock-ent* gw gh))))) + (base (list #:x left #:y y))) + (list #:type 'tween-demo #:x left #:y y + #:width 14 #:height 14 + #:vx 0 #:vy 0 #:gravity? #f #:solid? #f + #:color rgb + #:ease-name ease-sym + #:tween (make-tween base props: `((#:x . ,right)) + duration: +ease-duration+ ease: ease-sym + repeat: -1 yoyo?: #t)))) ;; ── Rendering ──────────────────────────────────────────────────────────────── -(define (draw-ease-labels! renderer) +(define (draw-ease-labels! renderer entities) (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) + "Tween demo - easing curves" white 12 6) (draw-ui-text renderer *label-font* - "Each box loops on X; bottom crate tweens right with physics skipped, screen bounds only." - 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)))))) - -(define (ease-cell-entities) - (map (lambda (i) (vector-ref (vector-ref *ease-cells* i) 0)) - (iota (vector-length *ease-cells*)))) + "Each box ping-pongs with repeat: -1 yoyo?: #t" white 12 32) + (for-each + (lambda (e) + (let ((name (entity-ref e #:ease-name #f))) + (when name + (draw-ui-text renderer *label-font* (symbol->string name) white + 158 (- (entity-ref e #:y 0) 2))))) + entities))) ;; ── Game ───────────────────────────────────────────────────────────────────── @@ -163,37 +69,24 @@ (set! *label-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 13))) create: (lambda (game) - (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)))) + (make-scene + entities: (map (lambda (ease i) + (make-ease-entity ease (+ 52 (* i 20)) + (list-ref +ease-colors+ i))) + +ease-syms+ (iota (length +ease-syms+))) + tilemap: #f + camera: (make-camera x: 0 y: 0) + tileset-texture: #f + camera-target: #f + background: '(26 28 34)))) update: (lambda (game dt) - (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! (game-scene game) - (append (ease-cell-entities) (list *knock-ent*))))) + (scene-update-entities (game-scene game) + (lambda (e) (step-tweens e dt)))) render: (lambda (game) - (draw-ease-labels! (game-renderer game))))) + (draw-ease-labels! (game-renderer game) + (scene-entities (game-scene game)))))) (game-run! *game*) diff --git a/docs/api.org b/docs/api.org index c418ec8..d4dc074 100644 --- a/docs/api.org +++ b/docs/api.org @@ -430,7 +430,8 @@ All entities can have these keys. Not all are required: | ~#:on-ground?~ | boolean | Is entity touching a solid tile below? | | ~#:facing~ | integer | 1 (right) or -1 (left) | | ~#:solid?~ | boolean | Participate in AABB entity collisions? | -| ~#:skip-pipelines~ | list | Symbols naming pipeline steps to skip; physics defines the built-in set (~docs/physics.org~) | +| ~#:skip-pipelines~ | list | Symbols naming pipeline steps to skip; physics defines the built-in set (~docs/physics.org~); ~'tweens~ skips ~step-tweens~ | +| ~#:tween~ | tween/false | Active tween struct, auto-advanced by ~step-tweens~ | | ~#:anim-name~ | symbol | Current animation name | | ~#:anim-frame~ | integer | Current frame index | | ~#:anim-tick~ | integer | Ticks in current frame | @@ -1046,16 +1047,19 @@ Time-based interpolation of numeric entity properties. Library-only — call fro ** ~make-tween~ #+begin_src scheme -(make-tween entity #!key props duration (delay 0) ease (on-complete #f)) +(make-tween entity #!key props duration (delay 0) ease + (on-complete #f) (repeat 0) (yoyo? #f)) #+end_src | Keyword | Description | |---------+-------------| | ~props~ | Alist ~((#:key . target-number) ...)~ | | ~duration~ | Milliseconds of interpolation after ~delay~ | -| ~delay~ | Initial wait in ms (default 0) | +| ~delay~ | Initial wait in ms (default 0, first cycle only) | | ~ease~ | Symbol (e.g. ~quad-in-out~) or ~(lambda (t) ...)~ with ~t~ in [0,1] | -| ~on-complete~ | Optional ~(lambda (entity) ...)~ once at completion | +| ~on-complete~ | Optional ~(lambda (entity) ...)~ once at final completion (not called with ~repeat: -1~) | +| ~repeat~ | ~0~ = play once (default), ~N~ = replay N extra times, ~-1~ = loop forever | +| ~yoyo?~ | ~#f~ (default) = same direction, ~#t~ = reverse each cycle | ** ~tween-step~ @@ -1067,6 +1071,14 @@ Returns two values: updated tween struct and updated entity. ~dt~ is elapsed mil ** ~tween-finished?~ / ~tween-active?~ +** ~step-tweens~ + +#+begin_src scheme +(step-tweens entity dt) +#+end_src + +Pipeline step: auto-advances ~#:tween~ on an entity. No-op if ~#:tween~ is absent. Removes ~#:tween~ when the tween finishes. Skipped when ~'tweens~ is in ~#:skip-pipelines~. See ~docs/tweens.org~ for patterns. + ** Easing exports ~ease-linear~, ~ease-quad-in~, ~ease-quad-out~, ~ease-quad-in-out~, ~ease-cubic-in~, ~ease-cubic-out~, ~ease-cubic-in-out~, ~ease-sine-in-out~, ~ease-expo-in~, ~ease-expo-out~, ~ease-expo-in-out~, ~ease-back-out~, ~ease-named~, ~ease-resolve~. diff --git a/docs/entities.org b/docs/entities.org index 3cdae6e..048cd8e 100644 --- a/docs/entities.org +++ b/docs/entities.org @@ -114,7 +114,8 @@ The engine recognizes these standard keys. Use them to integrate with the physic | ~#:on-ground?~ | boolean | Whether the entity is supported from below (set by ~detect-on-solid~): solid tile under the feet and/or standing on another solid entity when you pass the scene entity list. Use this to gate jump input. | | ~#:solid?~ | boolean | Whether this entity participates in entity-entity collision. If ~#t~, ~resolve-entity-collisions~ will check it against other solid entities. | | ~#:immovable?~ | boolean | If ~#t~ with ~#:solid? #t~, entity–entity resolution only moves the *other* entity (static platforms). Two overlapping immovable solids are not separated. | -| ~#:skip-pipelines~ | list of symbols | Optional. Each symbol names a physics step to skip for this entity (e.g. ~gravity~, ~velocity-x~). See ~docs/physics.org~. | +| ~#:skip-pipelines~ | list of symbols | Optional. Each symbol names a pipeline step to skip (e.g. ~gravity~, ~velocity-x~, ~tweens~). See ~docs/physics.org~ and ~docs/tweens.org~. | +| ~#:tween~ | tween struct or ~#f~ | Optional. When present, ~step-tweens~ auto-advances the tween each frame. Removed automatically when the tween finishes. See ~docs/tweens.org~. | | ~#:tile-id~ | integer | Sprite index in the tileset (1-indexed). Used by ~render-scene!~ when the scene has a tileset texture and tile metadata (from the tilemap or ~scene-tileset~). Updated automatically by animation (~animate-entity~). | | ~#:color~ | list | Optional ~(r g b)~ or ~(r g b a)~ (0–255 each). When ~#:tile-id~ is not drawn as a sprite (missing ~#:tile-id~, or no tileset texture), ~render-scene!~ fills the entity rect with this color. | | ~#:facing~ | number | Horizontal flip direction: ~1~ = right (default), ~-1~ = left. Used by renderer to flip sprite horizontally. Update when changing direction. | diff --git a/docs/tweens.org b/docs/tweens.org index 9ac87cd..213b3ee 100644 --- a/docs/tweens.org +++ b/docs/tweens.org @@ -18,31 +18,79 @@ Durations and delays are in **milliseconds**, matching the =dt= argument to =upd ** ~make-tween~ #+begin_src scheme -(make-tween entity #!key props duration (delay 0) ease (on-complete #f)) +(make-tween entity #!key props duration (delay 0) ease + (on-complete #f) (repeat 0) (yoyo? #f)) #+end_src | Keyword | Meaning | |---------+---------| | ~props~ | Alist =((#:x . 200) (#:y . 40))= — keyword keys, numeric targets | | ~duration~ | Positive integer, milliseconds of interpolation (after ~delay~) | -| ~delay~ | Non-negative integer ms before interpolation starts | +| ~delay~ | Non-negative integer ms before interpolation starts (first cycle only) | | ~ease~ | Easing symbol (see table below) or ~(lambda (t) ...)= with ~t~ in $[0,1]$ | -| ~on-complete~ | Optional ~(lambda (entity) ...)=, called **once** when the tween reaches its targets | +| ~on-complete~ | Optional ~(lambda (entity) ...)=, called **once** when the tween fully ends (not called with ~repeat: -1~) | +| ~repeat~ | ~0~ = play once (default), ~N~ = replay N additional times, ~-1~ = loop forever | +| ~yoyo?~ | ~#f~ (default) = replay same direction, ~#t~ = reverse direction each cycle | Start values are captured from ~entity~ at construction time. While the tween runs, intermediate values may be **inexact** (flonums) even if starts and ends are integers. +*** Repeat and yoyo + +~repeat:~ controls how many extra times the tween replays after the initial play. ~yoyo?: #t~ swaps start and end values on each cycle, creating a ping-pong effect. + +| ~repeat~ | ~yoyo?~ | Behavior | +|------+-------+----------| +| ~0~ | either | Play once and finish (default) | +| ~1~ | ~#f~ | Play forward twice, then finish | +| ~1~ | ~#t~ | Play forward, then backward, then finish | +| ~-1~ | ~#f~ | Play forward forever | +| ~-1~ | ~#t~ | Ping-pong forever | + +~delay:~ only applies before the first cycle. ~on-complete~ fires once when the last repeat finishes; it never fires with ~repeat: -1~. Overflow time from a completed cycle carries into the next cycle for smooth transitions. + ** ~tween-step~ #+begin_src scheme (tween-step tween entity dt) #+end_src -Returns ~(values new-tween new-entity)~. Advance time by ~dt~ (ms). Before ~delay~ elapses, ~entity~ is unchanged. After completion, further steps return the same values (idempotent). When the tween completes, ~on-complete~ runs with the **final** entity (targets applied), then the callback slot is cleared. +Returns ~(values new-tween new-entity)~. Advance time by ~dt~ (ms). Before ~delay~ elapses, ~entity~ is unchanged. After completion, further steps return the same values (idempotent). When the tween completes, ~on-complete~ runs with the **final** entity (targets applied), then the callback slot is cleared. With ~repeat:~ / ~yoyo?:~, the tween automatically resets for the next cycle. ** ~tween-finished?~ / ~tween-active?~ Predicates on the tween struct. +** ~step-tweens~ (pipeline step) + +#+begin_src scheme +(step-tweens entity dt) +#+end_src + +Auto-advances ~#:tween~ on an entity. If the entity has no ~#:tween~ key, returns the entity unchanged. When the tween finishes (no more repeats), ~#:tween~ is removed from the entity. Respects ~#:skip-pipelines~: skipped when ~'tweens~ is in the list. + +This is the recommended way to run tweens in most games. Attach a tween to an entity and include ~step-tweens~ in your per-entity pipeline: + +#+begin_src scheme +(scene-update-entities scene + (lambda (e) (step-tweens e dt))) +#+end_src + +** Entity key: ~#:tween~ + +Attach a tween directly to an entity for automatic advancement by ~step-tweens~: + +#+begin_src scheme +(list #:type 'platform + #:x 100 #:y 300 #:width 48 #:height 16 + #:solid? #t #:immovable? #t #:gravity? #f + #:tween (make-tween (list #:x 100) + props: '((#:x . 300)) + duration: 3000 ease: 'sine-in-out + repeat: -1 yoyo?: #t)) +#+end_src + +The platform ping-pongs between x=100 and x=300 forever. No manual tween management needed. + * Easing Each ease maps normalized time ~t ∈ [0,1]~ to an interpolation factor (usually in ~[0,1]~; ~back-out~ may exceed ~1~ briefly). @@ -85,6 +133,5 @@ Example skip list for “kinematic shove” while keeping tile collisions: * Limitations (current version) -- Single segment per tween (no built-in chains or yoyo). +- Single segment per tween (no built-in chains or sequences). - Numeric properties only. -- No engine integration — you wire ~tween-step~ yourself. @@ -115,25 +115,59 @@ (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a))) (set! (sdl2:render-draw-color renderer) (sdl2:make-color 0 0 0 255))))) +;; ── game-run! helpers ───────────────────────────────────────────────────── + +(define (collect-sdl-events) + (sdl2:pump-events!) + (let collect ((lst '())) + (if (not (sdl2:has-events?)) + (reverse lst) + (let ((e (sdl2:make-event))) + (sdl2:poll-event! e) + (collect (cons e lst)))))) + +(define (resolve-hooks game) + (let* ((active (game-active-state game)) + (state (and active + (hash-table-ref/default (game-states game) active #f)))) + (values (or (and state (state-hook state #:update)) (game-update-hook game)) + (or (and state (state-hook state #:render)) (game-render-hook game))))) + +(define (update-camera-follow! game) + (when (game-scene game) + (let ((target-tag (scene-camera-target (game-scene game)))) + (when target-tag + (let ((target (scene-find-tagged (game-scene game) target-tag))) + (when target + (camera-follow! (scene-camera (game-scene game)) + target + (game-width game) + (game-height game)))))))) + +(define (game-render! game render-fn) + (renderer-set-clear-color! (game-renderer game) (game-scene game)) + (sdl2:render-clear! (game-renderer game)) + (when (game-scene game) + (render-scene! (game-renderer game) (game-scene game))) + (when (and (game-debug? game) (game-scene game)) + (render-debug-scene! (game-renderer game) (game-scene game))) + (when render-fn (render-fn game)) + (sdl2:render-present! (game-renderer game))) + ;; ── game-run! ────────────────────────────────────────────────────────────── -;; Main event loop and lifecycle orchestration (define (game-run! game) - ;; 1. SDL2 init (audio excluded — mixer.scm not yet extracted; - ;; user calls init-audio! in their preload: hook) (sdl2:set-main-ready!) (sdl2:init! '(video joystick game-controller)) (ttf:init!) (img:init! '(png)) - ;; Open any already-connected game controllers (let init-controllers ((i 0)) (when (< i (sdl2:num-joysticks)) (when (sdl2:is-game-controller? i) (sdl2:game-controller-open! i)) (init-controllers (+ i 1)))) - ;; 2. Create window + renderer (window size = logical size × scale) (let ((scale (game-scale game))) (game-window-set! game (sdl2:create-window! (game-title game) 'centered 'centered @@ -146,61 +180,23 @@ (game-renderer game) (list (game-width game) (game-height game))))) - ;; 3. preload: hook — user loads assets here - (when (game-preload-hook game) - ((game-preload-hook game) game)) - - ;; 4. create: hook — user builds initial scene here - (when (game-create-hook game) - ((game-create-hook game) game)) + (when (game-preload-hook game) ((game-preload-hook game) game)) + (when (game-create-hook game) ((game-create-hook game) game)) - ;; 5. Frame loop (let loop ((last-ticks (sdl2:get-ticks))) - (let* ((now (sdl2:get-ticks)) - (dt (- now last-ticks))) - ;; Collect all pending SDL2 events - (sdl2:pump-events!) - (let* ((events (let collect ((lst '())) - (if (not (sdl2:has-events?)) - (reverse lst) - (let ((e (sdl2:make-event))) - (sdl2:poll-event! e) - (collect (cons e lst)))))) - (input (input-state-update (game-input game) events - (game-input-config game)))) - (game-input-set! game input) - (unless (input-held? input 'quit) - ;; Dispatch to active state hooks, or fall back to game's own hooks - (let* ((active (game-active-state game)) - (state (and active - (hash-table-ref/default (game-states game) active #f))) - (update-fn (or (and state (state-hook state #:update)) - (game-update-hook game))) - (render-fn (or (and state (state-hook state #:render)) - (game-render-hook game)))) - (when update-fn (update-fn game dt)) - ;; Auto camera-follow: if scene has a camera-target tag, follow it - (when (game-scene game) - (let ((target-tag (scene-camera-target (game-scene game)))) - (when target-tag - (let ((target (scene-find-tagged (game-scene game) target-tag))) - (when target - (camera-follow! (scene-camera (game-scene game)) - target - (game-width game) - (game-height game))))))) - (renderer-set-clear-color! (game-renderer game) (game-scene game)) - (sdl2:render-clear! (game-renderer game)) - (when (game-scene game) - (render-scene! (game-renderer game) (game-scene game))) - (when (and (game-debug? game) (game-scene game)) - (render-debug-scene! (game-renderer game) (game-scene game))) - (when render-fn (render-fn game))) - (sdl2:render-present! (game-renderer game)) - (sdl2:delay! (game-frame-delay game)) - (loop now))))) - - ;; 6. Cleanup + (let* ((now (sdl2:get-ticks)) + (dt (- now last-ticks)) + (input (input-state-update (game-input game) (collect-sdl-events) + (game-input-config game)))) + (game-input-set! game input) + (unless (input-held? input 'quit) + (receive (update-fn render-fn) (resolve-hooks game) + (when update-fn (update-fn game dt)) + (update-camera-follow! game) + (game-render! game render-fn)) + (sdl2:delay! (game-frame-delay game)) + (loop now)))) + (sdl2:destroy-window! (game-window game)) (sdl2:quit!)) @@ -162,23 +162,21 @@ ((< vx 0) (entity-set entity #:facing -1)) (else entity))) +(define (compute-input-delta input-map held?) + (fold (lambda (entry acc) + (if (held? (car entry)) + (cons (+ (car acc) (cadr entry)) + (+ (cdr acc) (cddr entry))) + acc)) + '(0 . 0) + input-map)) + (define (apply-input-to-entity entity held?) (let ((input-map (entity-ref entity #:input-map #f))) (if (not input-map) entity - (let* ((delta (fold (lambda (entry acc) - (let* ((action (car entry)) - (d (cdr entry)) - (dvx (car d)) - (dvy (cdr d))) - (if (held? action) - (cons (+ (car acc) dvx) - (+ (cdr acc) dvy)) - acc))) - '(0 . 0) - input-map)) - (speed (entity-ref entity #:move-speed 1)) - (vx (* speed (car delta)))) + (let* ((delta (compute-input-delta input-map held?)) + (vx (* (entity-ref entity #:move-speed 1) (car delta)))) (set-facing-from-vx (entity-set entity #:vx vx) vx))))) ) ;; end module diff --git a/physics.scm b/physics.scm index 083046d..56966c2 100644 --- a/physics.scm +++ b/physics.scm @@ -163,33 +163,28 @@ (<= (abs (- bottom oy)) *entity-ground-contact-tolerance*))))) others)))) - ;; Standing on ground = solid tile 1px below feet and/or feet on top of another solid. - ;; Optional ~other-entities~: when non-#f, must be a list of scene entities (include movers). - ;; Call after tile and entity-entity collision so positions and ~#:vy~ are settled. - ;; Name ends in ~?~ for call-site readability; it still returns an updated entity (not a boolean). + (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* ((tile-ground? - (and 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))))))) - (entity-ground? - (and other-entities - (entity-solid-support-below? entity other-entities))) - (on-ground? (or tile-ground? entity-ground?))) - (entity-set entity #:on-ground? on-ground?)))) + (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?) @@ -262,27 +257,24 @@ ;; 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)) - (m-cy (entity-center-on-axis m #:y)) - (s-cy (entity-center-on-axis s #:y)) - (land-on-top? (and (< m-cy s-cy) (> ovy 0)))) - (if land-on-top? - (let* ((dir (if (< m-cy s-cy) -1 1)) - (my (entity-ref m #:y 0))) - (entity-set (entity-set m #:y (+ my (* dir ovy))) #:vy 0)) - (if (<= ovx ovy) - (let* ((mc (entity-center-on-axis m #:x)) - (sc (entity-center-on-axis s #:x)) - (dir (if (< mc sc) -1 1)) - (mx (entity-ref m #:x 0))) - (entity-set (entity-set m #:x (+ mx (* dir ovx))) #:vx 0)) - (let* ((mc (entity-center-on-axis m #:y)) - (sc (entity-center-on-axis s #:y)) - (dir (if (< mc sc) -1 1)) - (my (entity-ref m #:y 0))) - (entity-set (entity-set m #:y (+ my (* dir ovy))) #:vy 0)))))) + (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). diff --git a/renderer.scm b/renderer.scm index 48698f7..b6ba238 100644 --- a/renderer.scm +++ b/renderer.scm @@ -209,6 +209,18 @@ (row-loop (cdr rows) (+ row 1))))) (tilemap-layers tilemap)))) + (define (draw-attack-hitbox renderer e tw cx cy) + (when (> (entity-ref e #:attack-timer 0) 0) + (let* ((ex (inexact->exact (floor (entity-ref e #:x 0)))) + (ey (inexact->exact (floor (entity-ref e #:y 0)))) + (ew (inexact->exact (floor (entity-ref e #:width 0)))) + (eh (inexact->exact (floor (entity-ref e #:height 0)))) + (facing (entity-ref e #:facing 1)) + (ax (if (> facing 0) (+ ex ew) (- ex tw)))) + (set! (sdl2:render-draw-color renderer) +debug-attack-color+) + (sdl2:render-fill-rect! renderer + (sdl2:make-rect (- ax cx) (- ey cy) tw eh))))) + (define (draw-debug-entities renderer camera scene) (let* ((tilemap (scene-tilemap scene)) (tw (tilemap-tilewidth tilemap)) @@ -222,28 +234,11 @@ ((eq? type 'player) (set! (sdl2:render-draw-color renderer) +debug-player-color+) (sdl2:render-fill-rect! renderer rect) - (when (> (entity-ref e #:attack-timer 0) 0) - (let* ((px (inexact->exact (floor (entity-ref e #:x 0)))) - (py (inexact->exact (floor (entity-ref e #:y 0)))) - (pw (inexact->exact (floor (entity-ref e #:width 0)))) - (ph (inexact->exact (floor (entity-ref e #:height 0)))) - (facing (entity-ref e #:facing 1)) - (ax (if (> facing 0) (+ px pw) (- px tw)))) - (set! (sdl2:render-draw-color renderer) +debug-attack-color+) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect (- ax cx) (- py cy) tw ph))))) + (draw-attack-hitbox renderer e tw cx cy)) ((eq? type 'enemy) (set! (sdl2:render-draw-color renderer) +debug-enemy-color+) (sdl2:render-fill-rect! renderer rect) - (when (> (entity-ref e #:attack-timer 0) 0) - (let* ((ex (inexact->exact (floor (entity-ref e #:x 0)))) - (ey (inexact->exact (floor (entity-ref e #:y 0)))) - (eh (inexact->exact (floor (entity-ref e #:height 0)))) - (facing (entity-ref e #:facing 1)) - (ax (if (> facing 0) (+ ex tw) (- ex tw)))) - (set! (sdl2:render-draw-color renderer) +debug-attack-color+) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect (- ax cx) (- ey cy) tw eh)))))))) + (draw-attack-hitbox renderer e tw cx cy))))) (scene-entities scene)))) (define (render-debug-scene! renderer scene) diff --git a/tests/tween-test.scm b/tests/tween-test.scm index ebe62e0..4420c94 100644 --- a/tests/tween-test.scm +++ b/tests/tween-test.scm @@ -79,4 +79,140 @@ (test-assert (tween-finished? tw3)) (test-equal "x stays" 20.0 (entity-ref e3 #:x))))))) +(test-group "repeat" + (test-group "repeat: 1 plays twice" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 + ease: 'linear repeat: 1))) + (receive (tw2 e2) (tween-step tw ent 100) + (test-assert "not finished after first play" (not (tween-finished? tw2))) + (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + (receive (tw3 e3) (tween-step tw2 e2 100) + (test-assert "finished after second play" (tween-finished? tw3)) + (test-equal "x at target again" 100.0 (entity-ref e3 #:x)))))) + + (test-group "repeat: -1 never finishes" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 10)) duration: 10 + ease: 'linear repeat: -1))) + (let loop ((tw tw) (ent ent) (i 0)) + (if (>= i 5) (test-assert "still active after 5 cycles" (tween-active? tw)) + (receive (tw2 e2) (tween-step tw ent 10) + (test-assert "not finished" (not (tween-finished? tw2))) + (loop tw2 e2 (+ i 1))))))) + + (test-group "repeat: 0 is default (no repeat)" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 50)) duration: 50 ease: 'linear))) + (receive (tw2 _e2) (tween-step tw ent 50) + (test-assert "finished immediately" (tween-finished? tw2))))) + + (test-group "on-complete fires after last repeat" + (let ((calls 0)) + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 10)) duration: 10 + ease: 'linear repeat: 1 + on-complete: (lambda (_) (set! calls (+ calls 1)))))) + (receive (tw2 e2) (tween-step tw ent 10) + (test-equal "no call after first play" 0 calls) + (receive (tw3 e3) (tween-step tw2 e2 10) + (test-equal "one call after last repeat" 1 calls)))))) + + (test-group "on-complete does not fire with repeat: -1" + (let ((calls 0)) + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 10)) duration: 10 + ease: 'linear repeat: -1 + on-complete: (lambda (_) (set! calls (+ calls 1)))))) + (let loop ((tw tw) (ent ent) (i 0)) + (if (>= i 5) (test-equal "never called" 0 calls) + (receive (tw2 e2) (tween-step tw ent 10) + (loop tw2 e2 (+ i 1))))))))) + +(test-group "yoyo" + (test-group "yoyo: #t with repeat: 1 reverses" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 + ease: 'linear repeat: 1 yoyo?: #t))) + (receive (tw2 e2) (tween-step tw ent 100) + (test-equal "x at target after forward" 100.0 (entity-ref e2 #:x)) + (receive (tw3 e3) (tween-step tw2 e2 50) + (test-equal "x halfway back" 50.0 (entity-ref e3 #:x)) + (receive (tw4 e4) (tween-step tw3 e3 50) + (test-assert "finished after reverse" (tween-finished? tw4)) + (test-equal "x back to start" 0.0 (entity-ref e4 #:x))))))) + + (test-group "yoyo: #t with repeat: -1 ping-pongs forever" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 + ease: 'linear repeat: -1 yoyo?: #t))) + ;; Forward + (receive (tw2 e2) (tween-step tw ent 100) + (test-equal "at target" 100.0 (entity-ref e2 #:x)) + ;; Reverse + (receive (tw3 e3) (tween-step tw2 e2 100) + (test-equal "back to start" 0.0 (entity-ref e3 #:x)) + ;; Forward again + (receive (tw4 e4) (tween-step tw3 e3 100) + (test-equal "at target again" 100.0 (entity-ref e4 #:x)) + (test-assert "still active" (tween-active? tw4))))))) + + (test-group "yoyo: #f with repeat: 1 replays same direction" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 + ease: 'linear repeat: 1 yoyo?: #f))) + (receive (tw2 e2) (tween-step tw ent 100) + (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + ;; Second play starts from same starts (0→100), but entity is at 100 + ;; The tween replays 0→100 using original start values + (receive (tw3 e3) (tween-step tw2 e2 50) + (test-assert "not finished mid-repeat" (not (tween-finished? tw3))))))) + + (test-group "yoyo: #t without repeat has no effect" + (let* ((ent (list #:type 'a #:x 0)) + (tw (make-tween ent props: '((#:x . 100)) duration: 100 + ease: 'linear repeat: 0 yoyo?: #t))) + (receive (tw2 e2) (tween-step tw ent 100) + (test-assert "finishes normally" (tween-finished? tw2)) + (test-equal "x at target" 100.0 (entity-ref e2 #:x)))))) + +(test-group "step-tweens pipeline" + (test-group "advances #:tween on entity" + (let* ((ent (list #:type 'a #:x 0 + #:tween (make-tween (list #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear))) + (e2 (step-tweens ent 50))) + (test-equal "x moved to midpoint" 50.0 (entity-ref e2 #:x)) + (test-assert "tween still attached" (entity-ref e2 #:tween #f)))) + + (test-group "removes #:tween when finished" + (let* ((ent (list #:type 'a #:x 0 + #:tween (make-tween (list #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear))) + (e2 (step-tweens ent 100))) + (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + (test-equal "tween removed" #f (entity-ref e2 #:tween #f)))) + + (test-group "no-op without #:tween" + (let* ((ent (list #:type 'a #:x 42)) + (e2 (step-tweens ent 100))) + (test-equal "x unchanged" 42 (entity-ref e2 #:x)))) + + (test-group "keeps repeating tween attached" + (let* ((ent (list #:type 'a #:x 0 + #:tween (make-tween (list #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) + (e2 (step-tweens ent 100))) + (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + (test-assert "tween still attached (repeating)" (entity-ref e2 #:tween #f)))) + + (test-group "respects #:skip-pipelines" + (let* ((ent (list #:type 'a #:x 0 + #:skip-pipelines '(tweens) + #:tween (make-tween (list #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear))) + (e2 (step-tweens ent 100))) + (test-equal "x unchanged (skipped)" 0 (entity-ref e2 #:x)) + (test-assert "tween still there" (entity-ref e2 #:tween #f))))) + (test-end "tween") @@ -86,7 +86,9 @@ ease-fn ;; number → number elapsed ;; ms since tween started (includes delay period) done? ;; boolean - callback) ;; (entity → unspecified) or #f; invoked once at completion + callback ;; (entity → unspecified) or #f; invoked once at completion + repeat ;; -1 = infinite, 0 = no more repeats, N = N repeats remaining + yoyo?) ;; swap starts/ends on each repeat cycle ;; ── Public API ──────────────────────────────────────────────────────────── @@ -96,13 +98,15 @@ ;; props: alist of (keyword . target-number), e.g. ((#:x . 200) (#:y . 40)) (define (make-tween entity #!key props (duration 500) (delay 0) (ease 'linear) - (on-complete #f)) + (on-complete #f) (repeat 0) (yoyo? #f)) (unless (and (integer? duration) (> duration 0)) (error "make-tween: duration must be a positive integer (ms)" duration)) (unless (and (integer? delay) (>= delay 0)) (error "make-tween: delay must be a non-negative integer (ms)" delay)) (unless (pair? props) (error "make-tween: props must be a non-empty alist" props)) + (unless (and (integer? repeat) (>= repeat -1)) + (error "make-tween: repeat must be -1 (infinite) or a non-negative integer" repeat)) (let ((ease-fn (ease-resolve ease)) (starts (map (lambda (p) (let ((k (car p))) @@ -117,7 +121,9 @@ ease-fn: ease-fn elapsed: 0 done?: #f - callback: on-complete))) + callback: on-complete + repeat: repeat + yoyo?: yoyo?))) ;; Linear interpolation with eased factor u in [0,1] (define (lerp a b u) @@ -132,37 +138,71 @@ entity ends)) + (define (tw-with-elapsed tw elapsed) + (make-tw starts: (tw-starts tw) ends: (tw-ends tw) + duration: (tw-duration tw) delay: (tw-delay tw) + ease-fn: (tw-ease-fn tw) elapsed: elapsed + done?: #f callback: (tw-callback tw) + repeat: (tw-repeat tw) yoyo?: (tw-yoyo? tw))) + + (define (tw-finish tw elapsed) + (make-tw starts: (tw-starts tw) ends: (tw-ends tw) + duration: (tw-duration tw) delay: (tw-delay tw) + ease-fn: (tw-ease-fn tw) elapsed: elapsed + done?: #t callback: #f + repeat: 0 yoyo?: (tw-yoyo? tw))) + + (define (tw-next-cycle tw overflow) + (let* ((yoyo? (tw-yoyo? tw)) + (starts (tw-starts tw)) + (ends (tw-ends tw))) + (make-tw starts: (if yoyo? ends starts) + ends: (if yoyo? starts ends) + duration: (tw-duration tw) delay: 0 + ease-fn: (tw-ease-fn tw) elapsed: overflow + done?: #f callback: (tw-callback tw) + repeat: (let ((r (tw-repeat tw))) (if (= r -1) -1 (- r 1))) + yoyo?: yoyo?))) + + (define (tween-complete tw entity elapsed) + (let ((final (apply-props entity (tw-starts tw) (tw-ends tw) 1.0))) + (if (zero? (tw-repeat tw)) + (begin + (when (tw-callback tw) ((tw-callback tw) final)) + (values (tw-finish tw elapsed) final)) + (let ((overflow (- (- elapsed (tw-delay tw)) (tw-duration tw)))) + (values (tw-next-cycle tw overflow) final))))) + + (define (tween-interpolate tw entity elapsed) + (let* ((t0 (- elapsed (tw-delay tw))) + (u (min 1.0 (max 0.0 (/ t0 (tw-duration tw))))) + (eased ((tw-ease-fn tw) u)) + (ent2 (apply-props entity (tw-starts tw) (tw-ends tw) eased))) + (if (>= u 1.0) + (tween-complete tw entity elapsed) + (values (tw-with-elapsed tw elapsed) ent2)))) + (define (tween-step tw entity dt) (unless (tw? tw) (error "tween-step: expected tween struct" tw)) (if (tw-done? tw) (values tw entity) - (let* ((elapsed (+ (tw-elapsed tw) dt)) - (delay (tw-delay tw)) - (duration (tw-duration tw)) - (ease-fn (tw-ease-fn tw)) - (starts (tw-starts tw)) - (ends (tw-ends tw))) - (cond ((< elapsed delay) - (values (make-tw starts: starts ends: ends duration: duration - delay: delay ease-fn: ease-fn - elapsed: elapsed done?: #f callback: (tw-callback tw)) - entity)) - (else - (let* ((t0 (- elapsed delay)) - (u-raw (/ t0 duration)) - (u (min 1.0 (max 0.0 u-raw))) - (eased (ease-fn u)) - (ent2 (apply-props entity starts ends eased))) - (if (>= u 1.0) - (let* ((final (apply-props entity starts ends 1.0)) - (cb (tw-callback tw)) - (_ (when cb (cb final))) - (tw2 (make-tw starts: starts ends: ends duration: duration - delay: delay ease-fn: ease-fn - elapsed: elapsed done?: #t callback: #f))) - (values tw2 final)) - (values (make-tw starts: starts ends: ends duration: duration - delay: delay ease-fn: ease-fn - elapsed: elapsed done?: #f callback: (tw-callback tw)) - ent2)))))))) + (let ((elapsed (+ (tw-elapsed tw) dt))) + (if (< elapsed (tw-delay tw)) + (values (tw-with-elapsed tw elapsed) entity) + (tween-interpolate tw entity elapsed))))) + + ;; ── Pipeline step ────────────────────────────────────────────────────────── + ;; Auto-advance #:tween on an entity. Call from update: as part of the + ;; per-entity pipeline, e.g. (step-tweens entity dt). Removes #:tween + ;; when the tween finishes. + + (define-pipeline (step-tweens tweens) (entity dt) + (let ((tw (entity-ref entity #:tween #f))) + (if (not tw) + entity + (receive (tw2 ent2) (tween-step tw entity dt) + (if (tween-finished? tw2) + (entity-set ent2 #:tween #f) + (entity-set ent2 #:tween tw2)))))) + ) ;; end module @@ -95,24 +95,23 @@ (loop (cdr es) (cons (cons gid e) acc)))) (loop (cdr es) acc)))))) + (define (sync-member-to-origin e origins) + (let* ((gid (entity-ref e #:group-id #f)) + (o (and gid (not (entity-ref e #:group-origin? #f)) + (assq gid origins)))) + (if o + (let ((origin (cdr o))) + (entity-set (entity-set e #:x (+ (entity-ref origin #:x 0) + (entity-ref e #:group-local-x 0))) + #:y (+ (entity-ref origin #:y 0) + (entity-ref e #:group-local-y 0)))) + e))) + ;; Snap member #:x/#:y to origin + #:group-local-x/y. Call after moving origins (tweens, etc.). (define (scene-sync-groups! scene) - (let* ((ents (scene-entities scene)) - (origins (group-origin-alist ents))) + (let ((origins (group-origin-alist (scene-entities scene)))) (scene-entities-set! scene - (map (lambda (e) - (if (and (entity-ref e #:group-id #f) - (not (entity-ref e #:group-origin? #f))) - (let* ((gid (entity-ref e #:group-id)) - (o (assq gid origins))) - (if o - (let ((origin (cdr o))) - (entity-set (entity-set e #:x (+ (entity-ref origin #:x 0) - (entity-ref e #:group-local-x 0))) - #:y (+ (entity-ref origin #:y 0) - (entity-ref e #:group-local-y 0)))) - e)) - e)) - ents)) + (map (lambda (e) (sync-member-to-origin e origins)) + (scene-entities scene))) scene)) ) |