Support entity groups

1 files changed, 104 insertions, 82 deletions

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*)