diff options
| -rw-r--r-- | demo/assets/sandbox-groups.scm | 30 | ||||
| -rw-r--r-- | demo/audio.scm | 24 | ||||
| -rw-r--r-- | demo/menu.scm | 92 | ||||
| -rw-r--r-- | demo/platformer.scm | 62 | ||||
| -rw-r--r-- | demo/sandbox.scm | 281 | ||||
| -rw-r--r-- | demo/shmup.scm | 186 | ||||
| -rw-r--r-- | demo/spritefont.scm | 43 | ||||
| -rw-r--r-- | demo/topdown.scm | 49 | ||||
| -rw-r--r-- | demo/tweens.scm | 268 | ||||
| -rw-r--r-- | docs/api.org | 18 | ||||
| -rw-r--r-- | docs/entities.org | 15 | ||||
| -rw-r--r-- | prefabs.scm | 86 | ||||
| -rw-r--r-- | renderer.scm | 24 | ||||
| -rw-r--r-- | tests/prefabs-test.scm | 40 | ||||
| -rw-r--r-- | tests/world-test.scm | 17 | ||||
| -rw-r--r-- | world.scm | 35 |
16 files changed, 797 insertions, 473 deletions
diff --git a/demo/assets/sandbox-groups.scm b/demo/assets/sandbox-groups.scm new file mode 100644 index 0000000..1e9aca9 --- /dev/null +++ b/demo/assets/sandbox-groups.scm @@ -0,0 +1,30 @@ +((mixins) + (prefabs) + (group-prefabs + (shelf-platform + #:pose-only-origin? #t + #:static-parts? #t + #:type-members shelf-segment + #:parts + ((#:local-x 0 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 16 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 32 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 48 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 64 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 80 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 96 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 112 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 128 #:local-y 0 #:width 16 #:height 16 #:tile-id 20) + (#:local-x 144 #:local-y 0 #:width 16 #:height 16 #:tile-id 20))) + (collision-raft + ;; Match full AABB so tile physics (runs on the origin) lands the raft on the floor, + ;; not a 0×0 point at the top-left (which overlaps the floor row). + #:origin-width 48 + #:origin-height 16 + #:pose-only-origin? #f + #:static-parts? #t + #:type-members raft-segment + #:parts + ((#:local-x 0 #:local-y 0 #:width 16 #:height 16 #:tile-id 21) + (#:local-x 16 #:local-y 0 #:width 16 #:height 16 #:tile-id 21) + (#:local-x 32 #:local-y 0 #:width 16 #:height 16 #:tile-id 21))))) diff --git a/demo/audio.scm b/demo/audio.scm index 2cf5665..62bebf4 100644 --- a/demo/audio.scm +++ b/demo/audio.scm @@ -11,6 +11,8 @@ (define *music-on?* #f) +(define +bg-color+ (sdl2:make-color 30 30 60 255)) + (define *game* (make-game title: "Demo: Audio" width: 600 height: 400 @@ -24,24 +26,26 @@ update: (lambda (game dt) (let ((input (game-input game))) - (when (input-pressed? input 'a) - (play-sound 'jump)) + (when (input-pressed? input 'a) (play-sound 'jump)) (when (input-pressed? input 'b) (if *music-on?* (begin (stop-music!) (set! *music-on?* #f)) (begin (play-music! 0.5) (set! *music-on?* #t)))))) render: (lambda (game) - (let* ((renderer (game-renderer game)) - (font (game-asset game 'font)) - (white (sdl2:make-color 255 255 255 255)) - (gray (sdl2:make-color 180 180 180 255))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color 30 30 60 255)) + (let ((renderer (game-renderer game)) + (font (game-asset game 'font)) + (white (sdl2:make-color 255 255 255 255)) + (gray (sdl2:make-color 180 180 180 255))) + (set! (sdl2:render-draw-color renderer) +bg-color+) (sdl2:render-fill-rect! renderer (sdl2:make-rect 0 0 600 400)) (draw-ui-text renderer font "Audio Demo" white 220 80) - (draw-ui-text renderer font "J / Z -- play sound effect" gray 160 160) - (draw-ui-text renderer font "K / X -- toggle music on/off" gray 160 200) - (draw-ui-text renderer font "Escape -- quit" gray 160 240) + (for-each + (lambda (entry) + (draw-ui-text renderer font (car entry) gray (cadr entry) (caddr entry))) + '(("J / Z -- play sound effect" 160 160) + ("K / X -- toggle music on/off" 160 200) + ("Escape -- quit" 160 240))) (draw-ui-text renderer font (if *music-on?* "Music: ON" "Music: OFF") (if *music-on?* diff --git a/demo/menu.scm b/demo/menu.scm index 2564bd0..322e046 100644 --- a/demo/menu.scm +++ b/demo/menu.scm @@ -6,11 +6,49 @@ downstroke-renderer downstroke-input) -;; Global state for menu cursor (define *menu-cursor* 0) -(define *menu-items* '("Play" "Quit")) -(define *title-font* #f) -(define *menu-font* #f) +(define *menu-items* '("Play" "Quit")) +(define *title-font* #f) +(define *menu-font* #f) + +(define +bg-color+ (sdl2:make-color 0 0 0 255)) +(define +text-color+ (sdl2:make-color 255 255 255 255)) + +(define (clear-screen! renderer) + (set! (sdl2:render-draw-color renderer) +bg-color+) + (sdl2:render-fill-rect! renderer (sdl2:make-rect 0 0 600 400))) + +;; ── States ─────────────────────────────────────────────────────────────────── + +(define (main-menu-update game _dt) + (let ((input (game-input game))) + (when (input-pressed? input 'up) + (set! *menu-cursor* (max 0 (- *menu-cursor* 1)))) + (when (input-pressed? input 'down) + (set! *menu-cursor* (min (- (length *menu-items*) 1) (+ *menu-cursor* 1)))) + (when (input-pressed? input 'a) + (case *menu-cursor* + ((0) (game-start-state! game 'playing)) + ((1) (sdl2:quit!) (exit)))))) + +(define (main-menu-render game) + (let ((renderer (game-renderer game))) + (clear-screen! renderer) + (draw-ui-text renderer *title-font* "MENU DEMO" +text-color+ 200 80) + (draw-menu-items renderer *menu-font* *menu-items* *menu-cursor* 150 150 50))) + +(define (playing-update game _dt) + (when (input-pressed? (game-input game) 'quit) + (set! *menu-cursor* 0) + (game-start-state! game 'main-menu))) + +(define (playing-render game) + (let ((renderer (game-renderer game))) + (clear-screen! renderer) + (draw-ui-text renderer *menu-font* + "PLAYING! PRESS ESC TO RETURN" +text-color+ 120 150))) + +;; ── Game ───────────────────────────────────────────────────────────────────── (define *game* (make-game @@ -18,53 +56,13 @@ preload: (lambda (game) (set! *title-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 24)) - (set! *menu-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 16))) + (set! *menu-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 16))) create: (lambda (game) - ;; Register the main-menu state (game-add-state! game 'main-menu - (make-game-state - #:update (lambda (game dt) - (let ((input (game-input game))) - ;; Navigate menu with up/down - (when (input-pressed? input 'up) - (set! *menu-cursor* (max 0 (- *menu-cursor* 1)))) - (when (input-pressed? input 'down) - (set! *menu-cursor* (min (- (length *menu-items*) 1) (+ *menu-cursor* 1)))) - ;; Confirm selection - (when (input-pressed? input 'a) - (case *menu-cursor* - ((0) ; Play - (game-start-state! game 'playing)) - ((1) ; Quit - (sdl2:quit!) - (exit)))))) - #:render (lambda (game) - (let ((renderer (game-renderer game))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color 0 0 0 255)) - (sdl2:render-fill-rect! renderer (sdl2:make-rect 0 0 600 400)) - (let ((white (sdl2:make-color 255 255 255 255))) - (draw-ui-text renderer *title-font* "MENU DEMO" white 200 80) - (draw-menu-items renderer *menu-font* *menu-items* *menu-cursor* - 150 150 50)))))) - - ;; Register the playing state + (make-game-state #:update main-menu-update #:render main-menu-render)) (game-add-state! game 'playing - (make-game-state - #:update (lambda (game dt) - (let ((input (game-input game))) - ;; Return to menu on quit (Escape) - (when (input-pressed? input 'quit) - (set! *menu-cursor* 0) - (game-start-state! game 'main-menu)))) - #:render (lambda (game) - (let ((renderer (game-renderer game))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color 0 0 0 255)) - (sdl2:render-fill-rect! renderer (sdl2:make-rect 0 0 600 400)) - (let ((white (sdl2:make-color 255 255 255 255))) - (draw-ui-text renderer *menu-font* "PLAYING! PRESS ESC TO RETURN" white 120 150)))))) - - ;; Start with the main menu + (make-game-state #:update playing-update #:render playing-render)) (game-start-state! game 'main-menu)))) (game-run! *game*) diff --git a/demo/platformer.scm b/demo/platformer.scm index 7d289f6..ff5caf7 100644 --- a/demo/platformer.scm +++ b/demo/platformer.scm @@ -1,6 +1,7 @@ (import scheme (chicken base) (chicken process-context) + (only srfi-197 chain) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -15,51 +16,54 @@ downstroke-sound downstroke-scene-loader) -(define +debug?+ (member "--debug" (command-line-arguments))) +(define +debug?+ (and (member "--debug" (command-line-arguments)) #t)) + +(define (make-player) + (list #:type 'player + #:x 100 #:y 50 + #:width 16 #:height 16 + #:vx 0 #:vy 0 + #:gravity? #t #:on-ground? #f + #:tile-id 1 #:tags '(player))) + +(define (player-vx input) + (cond ((input-held? input 'left) -3) + ((input-held? input 'right) 3) + (else 0))) + +(define (update-player player input tm) + (let ((jump? (input-pressed? input 'a))) + (when (and jump? (entity-ref player #:on-ground? #f)) + (play-sound 'jump)) + (chain (entity-set player #:vx (player-vx input)) + (apply-jump _ jump?) + (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 *game* (make-game title: "Demo: Platformer" width: 600 height: 400 - debug?: (and +debug?+ #t) + debug?: +debug?+ preload: (lambda (game) (init-audio!) (load-sounds! '((jump . "demo/assets/jump.wav")))) create: (lambda (game) - (let* ((scene (game-load-scene! game "demo/assets/level-0.tmx")) - (player (list #:type 'player - #:x 100 #:y 50 - #:width 16 #:height 16 - #:vx 0 #:vy 0 - #:gravity? #t - #:on-ground? #f - #:tile-id 1 - #:tags '(player))) - (_ (scene-add-entity scene player))) + (let ((scene (game-load-scene! game "demo/assets/level-0.tmx"))) + (scene-add-entity scene (make-player)) (scene-camera-target-set! scene 'player))) update: (lambda (game dt) (let* ((input (game-input game)) (scene (game-scene game)) (tm (scene-tilemap scene)) - (player (car (scene-entities scene))) - (player (entity-set player #:vx - (cond - ((input-held? input 'left) -3) - ((input-held? input 'right) 3) - (else 0)))) - (_ (when (and (input-pressed? input 'a) - (entity-ref player #:on-ground? #f)) - (play-sound 'jump))) - (player (apply-jump player (input-pressed? input 'a))) - (player (apply-acceleration player)) - (player (apply-gravity player)) - (player (apply-velocity-x player)) - (player (resolve-tile-collisions-x player tm)) - (player (apply-velocity-y player)) - (player (resolve-tile-collisions-y player tm)) - (player (detect-on-solid player tm))) + (player (update-player (car (scene-entities scene)) input tm))) (scene-entities-set! scene (list player)))))) (game-run! *game*) 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*) diff --git a/demo/shmup.scm b/demo/shmup.scm index 8610d4d..e9fec5e 100644 --- a/demo/shmup.scm +++ b/demo/shmup.scm @@ -1,7 +1,8 @@ (import scheme (chicken base) (chicken random) - (only srfi-1 filter) + (only srfi-1 filter any) + (only srfi-197 chain) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -13,16 +14,31 @@ downstroke-assets downstroke-sound) -(define *frame-count* 0) +;; ── Constants ──────────────────────────────────────────────────────────────── + +(define +screen-width+ 600) +(define +screen-height+ 400) +(define +spawn-interval+ 60) -(define (make-bullet px py) - (list #:type 'bullet #:x px #:y py #:width 4 #:height 8 #:vx 0 #:vy -6)) +;; ── State ──────────────────────────────────────────────────────────────────── -(define (make-enemy rx) - (list #:type 'enemy #:x rx #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 2)) +(define *frame-count* 0) + +;; ── Entity factories ───────────────────────────────────────────────────────── (define (make-player) - (list #:type 'player #:x 280 #:y 360 #:width 16 #:height 16 #:vx 0 #:vy 0)) + (list #:type 'player #:x 280 #:y 360 + #:width 16 #:height 16 #:vx 0 #:vy 0)) + +(define (make-bullet x y) + (list #:type 'bullet #:x x #:y y + #:width 4 #:height 8 #:vx 0 #:vy -6)) + +(define (make-enemy x) + (list #:type 'enemy #:x x #:y 0 + #:width 16 #:height 16 #:vx 0 #:vy 2)) + +;; ── Collision ──────────────────────────────────────────────────────────────── (define (entities-overlap? a b) (aabb-overlap? @@ -32,22 +48,74 @@ (entity-ref b #:width 0) (entity-ref b #:height 0))) (define (find-dead entities) - (let ((bullets (filter (lambda (e) (eq? (entity-ref e #:type) 'bullet)) entities)) - (enemies (filter (lambda (e) (eq? (entity-ref e #:type) 'enemy)) entities)) - (dead '())) - (for-each - (lambda (b) - (for-each - (lambda (en) - (when (entities-overlap? b en) - (set! dead (cons b (cons en dead))))) - enemies)) - bullets) - dead)) + (let ((bullets (filter (lambda (e) (eq? (entity-type e) 'bullet)) entities)) + (enemies (filter (lambda (e) (eq? (entity-type e) 'enemy)) entities))) + (filter (lambda (e) + (case (entity-type e) + ((bullet) (any (lambda (en) (entities-overlap? e en)) enemies)) + ((enemy) (any (lambda (b) (entities-overlap? e b)) bullets)) + (else #f))) + entities))) + +(define (in-bounds? e) + (let ((y (entity-ref e #:y 0))) + (and (> y -20) (< y (+ +screen-height+ 20))))) + +;; ── Update helpers ─────────────────────────────────────────────────────────── + +(define (player-vx input) + (cond ((input-held? input 'left) -4) + ((input-held? input 'right) 4) + (else 0))) + +(define (clamp-player-x player) + (entity-set player #:x + (max 0 (min (- +screen-width+ 16) (entity-ref player #:x 0))))) + +(define (update-player player input scene) + (let ((updated (chain player + (entity-set _ #:vx (player-vx input)) + (apply-velocity-x _) + (clamp-player-x _)))) + (when (input-pressed? input 'a) + (play-sound 'shoot) + (scene-add-entity scene + (make-bullet (+ (entity-ref updated #:x 0) 6) 340))) + updated)) + +(define (move-projectile e) + (chain e + (entity-set _ #:x (+ (entity-ref e #:x 0) (entity-ref e #:vx 0))) + (entity-set _ #:y (+ (entity-ref e #:y 0) (entity-ref e #:vy 0))))) + +(define (maybe-spawn-enemy! scene) + (when (zero? (modulo *frame-count* +spawn-interval+)) + (scene-add-entity scene + (make-enemy (+ 20 (* (pseudo-random-integer 28) 20)))))) + +;; ── Render ─────────────────────────────────────────────────────────────────── + +(define (entity-color type) + (case type + ((player) (sdl2:make-color 255 255 255 255)) + ((bullet) (sdl2:make-color 255 255 0 255)) + ((enemy) (sdl2:make-color 255 50 50 255)) + (else (sdl2:make-color 100 100 100 255)))) + +(define (draw-shmup-entity renderer e) + (let ((x (inexact->exact (floor (entity-ref e #:x 0)))) + (y (inexact->exact (floor (entity-ref e #:y 0)))) + (w (entity-ref e #:width 16)) + (h (entity-ref e #:height 16))) + (set! (sdl2:render-draw-color renderer) (entity-color (entity-type e))) + (sdl2:render-fill-rect! renderer (sdl2:make-rect x y w h)))) + +;; ── Game ───────────────────────────────────────────────────────────────────── (define *game* (make-game - title: "Demo: Shoot-em-up" width: 600 height: 400 + title: "Demo: Shoot-em-up" + width: +screen-width+ height: +screen-height+ preload: (lambda (game) (init-audio!) @@ -63,72 +131,26 @@ camera-target: #f))) update: (lambda (game dt) - (let* ((input (game-input game)) - (scene (game-scene game)) - (entities (scene-entities scene)) - (player (car (filter (lambda (e) (eq? (entity-ref e #:type) 'player)) - entities)))) - (set! *frame-count* (+ *frame-count* 1)) - ;; Move player - (let* ((player (entity-set player #:vx - (cond ((input-held? input 'left) -4) - ((input-held? input 'right) 4) - (else 0)))) - (player (apply-velocity-x player)) - (player (entity-set player #:x - (max 0 (min 584 (entity-ref player #:x 0)))))) - ;; Fire bullet - (when (input-pressed? input 'a) - (play-sound 'shoot) - (scene-add-entity scene - (make-bullet (+ (entity-ref player #:x 0) 6) 340))) - ;; Spawn enemy every 60 frames - (when (zero? (modulo *frame-count* 60)) - (scene-add-entity scene - (make-enemy (+ 20 (* (pseudo-random-integer 28) 20))))) - ;; Update player in scene - (scene-entities-set! scene - (cons player - (filter (lambda (e) (not (eq? (entity-ref e #:type) 'player))) - (scene-entities scene))))) - ;; Move non-player entities + (set! *frame-count* (+ *frame-count* 1)) + (let* ((input (game-input game)) + (scene (game-scene game)) + (player (car (scene-entities scene))) + (player (update-player player input scene))) + (maybe-spawn-enemy! scene) + ;; Replace player, then move all projectiles + (scene-entities-set! scene + (cons player (filter (lambda (e) (not (eq? (entity-type e) 'player))) + (scene-entities scene)))) (scene-update-entities scene - (lambda (e) - (if (eq? (entity-ref e #:type) 'player) - e - (entity-set - (entity-set e #:x (+ (entity-ref e #:x 0) (entity-ref e #:vx 0))) - #:y (+ (entity-ref e #:y 0) (entity-ref e #:vy 0)))))) - ;; Remove collisions + (lambda (e) (if (eq? (entity-type e) 'player) e (move-projectile e)))) + ;; Remove bullet/enemy collisions, then out-of-bounds (let ((dead (find-dead (scene-entities scene)))) - (scene-filter-entities scene - (lambda (e) (not (memq e dead))))) - ;; Remove out-of-bounds + (scene-filter-entities scene (lambda (e) (not (memq e dead))))) (scene-filter-entities scene - (lambda (e) - (let ((y (entity-ref e #:y 0))) - (or (eq? (entity-ref e #:type) 'player) - (and (> y -20) (< y 420)))))))) + (lambda (e) (or (eq? (entity-type e) 'player) (in-bounds? e)))))) render: (lambda (game) - (let* ((renderer (game-renderer game)) - (scene (game-scene game)) - (entities (scene-entities scene))) - (for-each - (lambda (e) - (let ((type (entity-ref e #:type 'unknown)) - (x (inexact->exact (floor (entity-ref e #:x 0)))) - (y (inexact->exact (floor (entity-ref e #:y 0)))) - (w (entity-ref e #:width 16)) - (h (entity-ref e #:height 16))) - (set! (sdl2:render-draw-color renderer) - (case type - ((player) (sdl2:make-color 255 255 255 255)) - ((bullet) (sdl2:make-color 255 255 0 255)) - ((enemy) (sdl2:make-color 255 50 50 255)) - (else (sdl2:make-color 100 100 100 255)))) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect x y w h)))) - entities))))) + (for-each (lambda (e) (draw-shmup-entity (game-renderer game) e)) + (scene-entities (game-scene game)))))) (game-run! *game*) diff --git a/demo/spritefont.scm b/demo/spritefont.scm index 8895d3c..2abc07a 100644 --- a/demo/spritefont.scm +++ b/demo/spritefont.scm @@ -17,35 +17,26 @@ title: "Demo: Sprite Font" width: 600 height: 400 create: (lambda (game) - (let* ((scene (game-load-scene! game "demo/assets/level-0.tmx")) - (tileset (tilemap-tileset (scene-tilemap scene)))) - ;; Create sprite font with character ranges - ;; A-M: tiles 917-929, N-Z: tiles 966-978, 0-9: tiles 868-877 - (set! *sprite-font* - (make-sprite-font* - #:tile-size 16 - #:spacing 1 - #:ranges '((#\A #\M 918) - (#\N #\Z 967) - (#\0 #\9 869)))))) + (game-load-scene! game "demo/assets/level-0.tmx") + (set! *sprite-font* + (make-sprite-font* + #:tile-size 16 #:spacing 1 + #:ranges '((#\A #\M 918) (#\N #\Z 967) (#\0 #\9 869))))) render: (lambda (game) - (let* ((renderer (game-renderer game)) - (scene (game-scene game)) - (tileset (tilemap-tileset (scene-tilemap scene))) - (tileset-texture (scene-tileset-texture scene))) - ;; Clear background + (let* ((scene (game-scene game)) + (renderer (game-renderer game)) + (tileset (tilemap-tileset (scene-tilemap scene))) + (texture (scene-tileset-texture scene))) (set! (sdl2:render-draw-color renderer) (sdl2:make-color 30 30 60 255)) (sdl2:render-fill-rect! renderer (sdl2:make-rect 0 0 600 400)) - - ;; Draw sprite text at various positions - (draw-sprite-text renderer tileset-texture tileset *sprite-font* - "HELLO WORLD" 50 50) - (draw-sprite-text renderer tileset-texture tileset *sprite-font* - "DOWNSTROKE" 100 120) - (draw-sprite-text renderer tileset-texture tileset *sprite-font* - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 20 200) - (draw-sprite-text renderer tileset-texture tileset *sprite-font* - "0123456789" 150 280))))) + (for-each + (lambda (entry) + (draw-sprite-text renderer texture tileset *sprite-font* + (car entry) (cadr entry) (caddr entry))) + '(("HELLO WORLD" 50 50) + ("DOWNSTROKE" 100 120) + ("ABCDEFGHIJKLMNOPQRSTUVWXYZ" 20 200) + ("0123456789" 150 280))))))) (game-run! *game*) diff --git a/demo/topdown.scm b/demo/topdown.scm index 2b3c208..7e5bd62 100644 --- a/demo/topdown.scm +++ b/demo/topdown.scm @@ -1,5 +1,6 @@ (import scheme (chicken base) + (only srfi-197 chain) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -13,36 +14,44 @@ downstroke-entity downstroke-scene-loader) +(define (make-player) + (list #:type 'player + #:x 100 #:y 100 + #:width 16 #:height 16 + #:vx 0 #:vy 0 + #:gravity? #f + #:tile-id 1 #:tags '(player))) + +(define (input->velocity input) + (values (+ (if (input-held? input 'left) -3 0) + (if (input-held? input 'right) 3 0)) + (+ (if (input-held? input 'up) -3 0) + (if (input-held? input 'down) 3 0)))) + +(define (update-player player input tm) + (receive (dx dy) (input->velocity input) + (chain player + (entity-set _ #:vx dx) + (entity-set _ #:vy dy) + (apply-velocity-x _) + (resolve-tile-collisions-x _ tm) + (apply-velocity-y _) + (resolve-tile-collisions-y _ tm)))) + (define *game* (make-game title: "Demo: Top-down Explorer" width: 600 height: 400 create: (lambda (game) - (let* ((scene (game-load-scene! game "demo/assets/level-0.tmx")) - (player (list #:type 'player - #:x 100 #:y 100 - #:width 16 #:height 16 - #:vx 0 #:vy 0 - #:gravity? #f - #:tile-id 1 - #:tags '(player))) - (_ (scene-add-entity scene player))) + (let ((scene (game-load-scene! game "demo/assets/level-0.tmx"))) + (scene-add-entity scene (make-player)) (scene-camera-target-set! scene 'player))) update: (lambda (game dt) (let* ((input (game-input game)) (scene (game-scene game)) - (tm (scene-tilemap scene)) - (player (car (scene-entities scene))) - (dx (+ (if (input-held? input 'left) -3 0) - (if (input-held? input 'right) 3 0))) - (dy (+ (if (input-held? input 'up) -3 0) - (if (input-held? input 'down) 3 0))) - (player (entity-set (entity-set player #:vx dx) #:vy dy)) - (player (apply-velocity-x player)) - (player (resolve-tile-collisions-x player tm)) - (player (apply-velocity-y player)) - (player (resolve-tile-collisions-y player tm))) + (player (update-player (car (scene-entities scene)) + input (scene-tilemap scene)))) (scene-entities-set! scene (list player)))))) (game-run! *game*) 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*) diff --git a/docs/api.org b/docs/api.org index 1f15945..45593e4 100644 --- a/docs/api.org +++ b/docs/api.org @@ -237,6 +237,14 @@ Example: ; Each entity is passed through increment-x, then through apply-gravity #+end_src +** ~scene-sync-groups!~ + +#+begin_src scheme +(scene-sync-groups! scene) +#+end_src + +For every entity with ~#:group-id~ that is not an origin (~#:group-origin?~ is false), sets ~#:x~ and ~#:y~ to the corresponding origin’s position plus that entity’s ~#:group-local-x~ and ~#:group-local-y~. Origins are read from ~scene-entities~, so after a tween or other motion that returns a *new* origin plist, replace that origin in the scene’s list (match on ~#:group-id~ / ~#:group-origin?~) before calling ~scene-sync-groups!~. Call after updating origin positions and before per-entity physics so platforms and collisions see a consistent pose. Returns the scene. + ** ~scene-filter-entities~ #+begin_src scheme @@ -1233,7 +1241,7 @@ Creates an SDL2 texture from the tileset image embedded in a tilemap struct. Use (load-prefabs filename engine-mixin-table user-hooks) #+end_src -Loads a prefab definition file and returns a ~prefab-registry~ struct. The file must contain a Scheme expression with ~mixins~ and ~prefabs~ sections (see ~docs/entities.org~). +Loads a prefab definition file and returns a ~prefab-registry~ struct. The file must contain a Scheme expression with ~mixins~ and ~prefabs~ sections; an optional ~group-prefabs~ section defines multi-entity assemblies (see ~docs/entities.org~). | Parameter | Type | Description | |-----------|------|-------------| @@ -1263,6 +1271,14 @@ Reloads the prefab file that the registry was originally loaded from. Returns a Looks up a prefab by type symbol in the registry and returns a fresh entity plist at the given position and size. Returns ~#f~ if the type is not registered. If the resulting entity has an ~#:on-instantiate~ hook, it is called with the entity before returning. +** ~instantiate-group-prefab~ + +#+begin_src scheme +(instantiate-group-prefab registry type origin-x origin-y) +#+end_src + +Looks up a *group prefab* by type symbol and returns a list ~(origin member ...)~: one origin entity plus one entity per part. Optional group-level flags ~#:pose-only-origin?~ and ~#:static-parts?~ select origin/part profiles (see ~docs/entities.org~); defaults are ~#f~ (physics-driving origin, non-static parts). Each instance receives a fresh gensym ~#:group-id~ shared by the origin and all members. Returns ~#f~ if the type is not in ~group-prefabs~. After moving origins (tween and/or physics), ensure updated origins are stored in the scene’s entity list, then call ~scene-sync-groups!~ so member ~#:x~ / ~#:y~ match ~origin + #:group-local-x/y~. + ** ~tilemap-objects->entities~ #+begin_src scheme diff --git a/docs/entities.org b/docs/entities.org index a29ebf6..3cdae6e 100644 --- a/docs/entities.org +++ b/docs/entities.org @@ -123,6 +123,21 @@ The engine recognizes these standard keys. Use them to integrate with the physic | ~#:anim-name~ | symbol | Currently active animation name, e.g., ~'walk~, ~'jump~. Set with ~set-animation~; reset by ~animate-entity~. | | ~#:anim-frame~ | integer | Current frame index within the animation (0-indexed). Updated automatically by ~animate-entity~. | | ~#:anim-tick~ | integer | Tick counter for frame timing (0 to ~#:duration - 1~). Incremented by ~animate-entity~; resets when frame advances. | +| ~#:group-id~ | symbol | Shared id for one rigid assembly (from ~instantiate-group-prefab~). All parts and the origin share the same symbol. | +| ~#:group-origin?~ | boolean | When ~#t~, this entity is the assembly’s pose origin; world ~#:x~ / ~#:y~ drive the group. Members should not set this. | +| ~#:group-local-x~, ~#:group-local-y~ | number | Offset from the origin’s top-left corner; members’ world position is origin + local (updated by ~scene-sync-groups!~). | +| ~#:skip-render~ | boolean | When ~#t~, ~render-scene!~ skips drawing this entity (used for invisible origins). | + +* Entity groups (prefab assemblies) + +A **group prefab** describes one *origin* entity plus several *parts* with local offsets. Data lives in the optional ~group-prefabs~ section of the prefab file (alongside ~mixins~ and ~prefabs~). Each group entry has the shape ~(name #:type-members SYMBOL #:parts (part ...) ...)~ with two optional flags: + +- ~#:pose-only-origin?~ — when ~#t~ (typical for tweened platforms), the origin is invisible, does not run physics pipelines, and is driven by tweens or scripts. When ~#f~ (default), the origin uses a small *physics-driving* profile (~#:gravity? #t~, no ~#:skip-pipelines~): integrate the origin like a mover, then call ~scene-sync-groups!~ so parts stay glued as a rigid body. For that case, set ~#:origin-width~ and ~#:origin-height~ to the full assembly size (same box as the combined parts); otherwise the origin stays 0×0 and tile collision only sees a point at the reference corner, which can leave the raft overlapping solid floor tiles. +- ~#:static-parts?~ — when ~#t~, each part gets static rigid-body defaults (no gravity on parts; pose comes from the origin). When ~#f~ (default), parts only have what you put in each part plist. + +Each ~part~ is a plist using ~#:local-x~ / ~#:local-y~ (or ~#:group-local-x~ / ~#:group-local-y~) and the usual ~#:width~, ~#:height~, ~#:tile-id~, physics keys, etc. + +Use ~(instantiate-group-prefab registry 'name origin-x origin-y)~ from ~downstroke-prefabs~ to obtain ~(origin member ...)~. Append all of them to the scene. After moving origins (tweens and/or physics), ensure updated origins are in ~scene-entities~, then call ~(scene-sync-groups! scene)~ so every part’s ~#:x~ / ~#:y~ matches the origin plus local offsets (see ~docs/api.org~ for ordering). * Entities in Scenes diff --git a/prefabs.scm b/prefabs.scm index 56bc60a..eda75ad 100644 --- a/prefabs.scm +++ b/prefabs.scm @@ -9,7 +9,7 @@ ;; Registry struct to hold prefab data (defstruct prefab-registry - prefabs file engine-mixin-table user-hooks hook-table) + prefabs group-prefabs file engine-mixin-table user-hooks hook-table) ;; Return engine's built-in mixin table (define (engine-mixins) @@ -49,19 +49,54 @@ (cdr entry) (error "Unknown prefab hook" hook-sym)))) + ;; Group prefab entry: (name . plist) with #:parts = list of part plists. + ;; Part offsets may use #:local-x / #:local-y or #:group-local-x / #:group-local-y. + (define (compose-group-prefab entry) + (cons (car entry) (cdr entry))) + + ;; Optional profiles (enabled per group via #:pose-only-origin? / #:static-parts? in data). + ;; Pose-only origin: tweened or scripted leader, invisible, does not run physics pipelines. + (define +pose-only-group-origin-defaults+ + (list #:solid? #f #:gravity? #f #:skip-render #t + #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y + tile-collisions-x tile-collisions-y on-solid entity-collisions))) + + ;; Physics-driving origin: invisible point mass; members follow via scene-sync-groups!. + (define +physics-group-origin-defaults+ + (list #:solid? #f #:gravity? #t #:skip-render #t + #:vx 0 #:vy 0 #:on-ground? #f)) + + ;; Static rigid parts: no integration; world pose comes from the origin each frame. + (define +static-group-member-defaults+ + (list #:gravity? #f #:vx 0 #:vy 0 #:on-ground? #f + #:solid? #t #:immovable? #t + #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y + tile-collisions-x tile-collisions-y on-solid))) + + (define (part-with-group-locals part) + (let* ((p part) + (p (if (entity-ref p #:group-local-x #f) p + (entity-set p #:group-local-x (entity-ref p #:local-x 0)))) + (p (if (entity-ref p #:group-local-y #f) p + (entity-set p #:group-local-y (entity-ref p #:local-y 0))))) + p)) + (define (load-prefabs file engine-mixin-table user-hooks) (let* ((data (with-input-from-file file read)) (mixin-section (cdr (assq 'mixins data))) (prefab-section (cdr (assq 'prefabs data))) + (group-section (cond ((assq 'group-prefabs data) => cdr) (else '()))) ;; user mixins first → user wins on assq lookup (overrides engine mixin by name) (user-mixin-table (map (lambda (m) (cons (car m) (cdr m))) mixin-section)) (merged-mixin-table (append user-mixin-table engine-mixin-table)) ;; user-hooks first → user wins on assq lookup (overrides engine hooks by name) (hook-table (append user-hooks *engine-hooks*)) (prefab-table (map (lambda (entry) (compose-prefab entry merged-mixin-table)) - prefab-section))) + prefab-section)) + (group-table (map compose-group-prefab group-section))) (make-prefab-registry prefabs: prefab-table + group-prefabs: group-table file: file engine-mixin-table: engine-mixin-table user-hooks: user-hooks @@ -88,4 +123,49 @@ ((symbol? hook-val) (lookup-hook (prefab-registry-hook-table registry) hook-val)) (else #f)))) - (if handler (handler base) base))))))) + (if handler (handler base) base)))))) + + (define (instantiate-group-member part ox oy gid type-members static-parts?) + (let* ((p0 (part-with-group-locals part)) + (merged (append p0 (if static-parts? +static-group-member-defaults+ '()))) + (lx (entity-ref merged #:group-local-x 0)) + (ly (entity-ref merged #:group-local-y 0)) + (typ (entity-ref merged #:type type-members)) + (with-type (entity-set merged #:type typ)) + (g1 (entity-set with-type #:group-id gid)) + (g2 (entity-set g1 #:group-local-x lx)) + (g3 (entity-set g2 #:group-local-y ly)) + (g4 (entity-set g3 #:x (+ ox lx)))) + (entity-set g4 #:y (+ oy ly)))) + + ;; Instantiate a group prefab: one origin entity (pose) + members with #:group-local-x/y. + ;; Returns (origin member ...) or #f. Each instance gets a fresh gensym #:group-id. + (define (instantiate-group-prefab registry type ox oy) + (if (not registry) + #f + (let ((entry (assq type (prefab-registry-group-prefabs registry)))) + (if (not entry) + #f + (let* ((spec (cdr entry)) + (gid (gensym (symbol->string type))) + (parts (entity-ref spec #:parts '())) + (type-members (entity-ref spec #:type-members 'group-part)) + (pose-only? (entity-ref spec #:pose-only-origin? #f)) + (static-parts? (entity-ref spec #:static-parts? #f)) + (ow (entity-ref spec #:origin-width 0)) + (oh (entity-ref spec #:origin-height 0)) + (ot (entity-ref spec #:origin-type 'group-origin)) + (origin-fields + (append + (list #:type ot #:group-id gid #:group-origin? #t + #:x ox #:y oy #:width ow #:height oh) + (if pose-only? + +pose-only-group-origin-defaults+ + +physics-group-origin-defaults+))) + (origin origin-fields) + (members + (map (lambda (part) + (instantiate-group-member + part ox oy gid type-members static-parts?)) + parts))) + (cons origin members))))))) diff --git a/renderer.scm b/renderer.scm index b048bad..48698f7 100644 --- a/renderer.scm +++ b/renderer.scm @@ -121,9 +121,11 @@ ;; #:color is (r g b) or (r g b a); used when no tile sprite is drawn. (define (draw-entity renderer camera tileset tileset-texture entity) - (let ((tile-id (entity-ref entity #:tile-id #f)) - (color (entity-ref entity #:color #f))) - (cond + (if (entity-ref entity #:skip-render #f) + (void) + (let ((tile-id (entity-ref entity #:tile-id #f)) + (color (entity-ref entity #:color #f))) + (cond ((and tile-id tileset tileset-texture) (sdl2:render-copy-ex! renderer tileset-texture (tile-rect (tileset-tile tileset tile-id)) @@ -131,14 +133,14 @@ 0.0 #f (entity-flip entity))) - ((and (list? color) (>= (length color) 3)) - (let ((r (list-ref color 0)) - (g (list-ref color 1)) - (b (list-ref color 2)) - (a (if (>= (length color) 4) (list-ref color 3) 255))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a)) - (sdl2:render-fill-rect! renderer (entity->screen-rect entity camera)))) - (else #f)))) + ((and (list? color) (>= (length color) 3)) + (let ((r (list-ref color 0)) + (g (list-ref color 1)) + (b (list-ref color 2)) + (a (if (>= (length color) 4) (list-ref color 3) 255))) + (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a)) + (sdl2:render-fill-rect! renderer (entity->screen-rect entity camera)))) + (else #f))))) (define (draw-entities renderer camera tileset tileset-texture entities) (for-each diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm index 6ccc473..8a1e5b0 100644 --- a/tests/prefabs-test.scm +++ b/tests/prefabs-test.scm @@ -152,6 +152,7 @@ prefabs: (list (cons 'proc-hooked (list #:type 'proc-hooked #:on-instantiate hook-proc))) + group-prefabs: '() file: "/dev/null" engine-mixin-table: '() user-hooks: '() @@ -215,4 +216,43 @@ (test-equal "reloaded registry has #:value 42" 42 (entity-ref e2 #:value)) (test-equal "original registry unchanged after reload" 1 (entity-ref e1 #:value)))) +(test-group "group-prefabs" + (define (with-group-prefab-data str thunk) + (let ((tmp "/tmp/test-group-prefabs.scm")) + (with-output-to-file tmp (lambda () (display str))) + (thunk (load-prefabs tmp (engine-mixins) '())))) + + (with-group-prefab-data + "((mixins) (prefabs) + (group-prefabs + (two-block #:pose-only-origin? #t #:static-parts? #t #:type-members segment + #:parts ((#:local-x 0 #:local-y 0 #:width 10 #:height 8 #:tile-id 1) + (#:local-x 10 #:local-y 0 #:width 10 #:height 8 #:tile-id 2)))))" + (lambda (reg) + (test-assert "instantiate-group-prefab unknown → #f" + (not (instantiate-group-prefab reg 'nope 0 0))) + (let ((lst (instantiate-group-prefab reg 'two-block 100 50))) + (test-equal "returns list of origin + 2 members" 3 (length lst)) + (let ((origin (car lst)) + (a (cadr lst)) + (b (caddr lst))) + (test-equal "pose-only origin skip-render" #t (entity-ref origin #:skip-render)) + (test-equal "origin group-origin?" #t (entity-ref origin #:group-origin?)) + (test-equal "member a world x" 100 (entity-ref a #:x)) + (test-equal "member b world x" 110 (entity-ref b #:x)) + (test-equal "member a local x" 0 (entity-ref a #:group-local-x)) + (test-equal "member b local x" 10 (entity-ref b #:group-local-x)) + (test-equal "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id)))))) + + (with-group-prefab-data + "((mixins) (prefabs) + (group-prefabs + (falling-asm #:pose-only-origin? #f #:static-parts? #t #:type-members part + #:parts ((#:local-x 0 #:local-y 0 #:width 4 #:height 4 #:tile-id 1)))))" + (lambda (reg) + (let ((origin (car (instantiate-group-prefab reg 'falling-asm 0 0)))) + (test-equal "physics origin has gravity" #t (entity-ref origin #:gravity?)) + (test-assert "physics origin has no #:skip-pipelines (pipelines run)" + (eq? 'absent (entity-ref origin #:skip-pipelines 'absent))))))) + (test-end "prefabs") diff --git a/tests/world-test.scm b/tests/world-test.scm index b8c1a98..dbae9d9 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -277,4 +277,21 @@ (test-equal "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) (test-equal "returns empty list when none match" '() (scene-find-all-tagged s 'boss)))) + (test-group "scene-sync-groups!" + (let* ((gid 'g1) + (origin (list #:type 'group-origin #:group-origin? #t #:group-id gid + #:x 100 #:y 200 #:width 0 #:height 0)) + (m1 (list #:type 'part #:group-id gid #:group-local-x 5 #:group-local-y 0 + #:x 0 #:y 0 #:width 8 #:height 8)) + (m2 (list #:type 'part #:group-id gid #:group-local-x 0 #:group-local-y 7 + #:x 0 #:y 0 #:width 8 #:height 8)) + (s (make-scene entities: (list origin m1 m2) tilemap: #f + camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) + (scene-sync-groups! s) + (let ((es (scene-entities s))) + (test-equal "member 1 follows origin" 105 (entity-ref (list-ref es 1) #:x)) + (test-equal "member 1 y" 200 (entity-ref (list-ref es 1) #:y)) + (test-equal "member 2 x" 100 (entity-ref (list-ref es 2) #:x)) + (test-equal "member 2 y" 207 (entity-ref (list-ref es 2) #:y))))) + (test-end "world-module") @@ -80,4 +80,39 @@ (define (scene-find-all-tagged scene tag) (filter (lambda (e) (member tag (entity-ref e #:tags '()))) (scene-entities scene))) + + ;; First wins: one origin entity per #:group-id (for lookup). + (define (group-origin-alist entities) + (let loop ((es entities) (acc '())) + (if (null? es) + acc + (let ((e (car es))) + (if (and (entity-ref e #:group-origin? #f) + (entity-ref e #:group-id #f)) + (let ((gid (entity-ref e #:group-id))) + (if (assq gid acc) + (loop (cdr es) acc) + (loop (cdr es) (cons (cons gid e) acc)))) + (loop (cdr es) acc)))))) + + ;; 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))) + (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)) + scene)) ) |