Work on demos

1 files changed, 126 insertions, 33 deletions

diff --git a/demo/sandbox.scm b/demo/sandbox.scm
index f585a6a..2feb69e 100644
--- a/demo/sandbox.scm
+++ b/demo/sandbox.scm
@@ -1,60 +1,153 @@
 (import scheme
         (chicken base)
         (chicken random)
+        (only srfi-1 drop iota take)
         (prefix sdl2 "sdl2:")
         (prefix sdl2-ttf "ttf:")
         (prefix sdl2-image "img:")
         downstroke-engine
         downstroke-world
         downstroke-tilemap
-        downstroke-renderer
-        downstroke-input
         downstroke-physics
         downstroke-assets
         downstroke-entity
         downstroke-scene-loader)
 
-(define *elapsed* 0)
-(define *respawn-interval* 10000)
-
-(define (spawn-entities)
-  (let loop ((i 0) (acc '()))
-    (if (= i 10)
-        acc
-        (loop (+ i 1)
-              (cons (list #:type 'box
-                          #:x (+ 30 (* i 55))
-                          #:y (+ 10 (* (pseudo-random-integer 4) 20))
-                          #:width 16 #:height 16
-                          #:vx 0 #:vy 0
-                          #:gravity? #t
-                          #:on-ground? #f
-                          #:solid? #t
-                          #:tile-id 1)
-                    acc)))))
+(define *demo-t* 0.0)
+
+;; Programmatic level: same geometry as the old static-tile floor + mid shelf,
+;; but as a real tile layer so tile collisions and detect-on-solid work.
+(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)
+         (shelf-tile 20)
+         (air (map (lambda (_) (map (lambda (_) 0) (iota ncols))) (iota nrows)))
+         (floor-row (map (lambda (_) floor-tile) (iota ncols)))
+         (with-floor (append (take air (- nrows 1)) (list floor-row)))
+         ;; Shelf top at same Y as before: gh - 6*th pixels from top
+         (shelf-r (inexact->exact (floor (/ (- gh (* 6 th)) th))))
+         (shelf-c0 10)
+         (shelf-n 10)
+         (row-before (list-ref with-floor shelf-r))
+         (shelf-row
+           (map (lambda (c)
+                  (if (and (>= c shelf-c0) (< c (+ shelf-c0 shelf-n)))
+                      shelf-tile
+                      (list-ref row-before c)))
+                (iota ncols)))
+         (map-data (append (take with-floor shelf-r)
+                           (list shelf-row)
+                           (drop with-floor (+ shelf-r 1))))
+         (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: '())))
+
+(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))
+       (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
+        #:vx 0 #:vy 0
+        #:gravity? #t #:on-ground? #f
+        #:solid? #t #:immovable? #f
+        #:tile-id 1
+        #:demo-id id
+        #:demo-since-jump 0))
+
+(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))
 
 (define *game*
   (make-game
     title: "Demo: Physics Sandbox" width: 600 height: 400
 
     create: (lambda (game)
-      (let ((scene (game-load-scene! game "demo/assets/level-0.tmx")))
-        (scene-entities-set! scene (spawn-entities))))
+      (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))
+             (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 (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)))
 
     update: (lambda (game dt)
+      (set! *demo-t* (+ *demo-t* dt))
       (let* ((scene (game-scene game))
              (tm    (scene-tilemap scene)))
-        (set! *elapsed* (+ *elapsed* dt))
-        (when (>= *elapsed* *respawn-interval*)
-          (set! *elapsed* 0)
-          (scene-entities-set! scene (spawn-entities)))
         (scene-update-entities scene
-          apply-gravity
-          apply-velocity-x
-          (lambda (e) (resolve-tile-collisions-x e tm))
-          apply-velocity-y
-          (lambda (e) (resolve-tile-collisions-y e tm))
-          (lambda (e) (detect-ground e tm)))
-        (scene-resolve-collisions 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))))))))
 
 (game-run! *game*)