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