From ba7b9ea9d88e9aa86fa3386d4e0102da1d93b434 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Tue, 21 May 2024 14:10:57 -0400
Subject: [PATCH] Add gems and the start of floor switches.

---
 game.scm                        |  46 ++++++++++----
 modules/game/actors.scm         | 108 ++++++++++++++++++++++++++------
 modules/game/level.scm          |   9 ++-
 modules/game/levels/level-1.tmx |   4 +-
 scripts/compile-map.scm         |  11 +++-
 5 files changed, 142 insertions(+), 36 deletions(-)

diff --git a/game.scm b/game.scm
index 9a35851..f202a49 100644
--- a/game.scm
+++ b/game.scm
@@ -67,6 +67,7 @@
 (define audio:undo (load-sound-effect "undo"))
 (define audio:no (load-sound-effect "no"))
 (define audio:exit (load-sound-effect "exit"))
+(define audio:pickup (load-sound-effect "pickup"))
 
 ;; Game state
 (define *state* #f)
@@ -83,6 +84,7 @@
    load-level-2
    load-level-3))
 (define *level-idx* #f)
+(define *gems* #f)
 (define *level* #f)
 ;; Latest representation of all actors in level
 (define *objects* #f)
@@ -113,7 +115,7 @@
   (set! *actormap* (make-whactormap))
   (clear-snapshots!)
   (with-goblins
-   (set! *level* ((vector-ref levels idx)))
+   (set! *level* ((vector-ref levels idx) (not (memq idx *gems*))))
    (update-objects!)))
 
 (define (next-level!)
@@ -129,15 +131,22 @@
 ;; Auto-save/load to local storage.
 (define (save-game!)
   (pk 'save)
-  (local-storage-set! "cirkoban-level" (number->string *level-idx*)))
+  (local-storage-set! "cirkoban-save"
+                      (call-with-output-string
+                        (lambda (port)
+                          (write (list *level-idx* *gems*) port)))))
 
 (define (load-game!)
-  (set! *level-idx*
-        (match (local-storage-ref "cirkoban-level")
-          ("" 0)
-          (str (string->number str))))
-  (pk 'load *level-idx*)
-  (load-level! *level-idx*))
+  (let ((saved
+         (match (local-storage-ref "cirkoban-save")
+           ("" '(0 ())) ; initial save state
+           (str (call-with-input-string str read)))))
+    (match saved
+      ((idx gems)
+       (set! *level-idx* idx)
+       (set! *gems* gems)
+       (pk 'load *level-idx*)
+       (load-level! *level-idx*)))))
 
 (define (reset-game!)
   (set! *level-idx* 0)
@@ -151,7 +160,7 @@
      ($ (level-player *level*) 'move dir)
      ($ (level-actor *level*) 'tick)
      (define result
-       (match (pk 'event ($ (level-player *level*) 'event))
+       (match ($ (level-player *level*) 'event)
          (('bump)
           (media-play audio:bump)
           #f)
@@ -161,6 +170,10 @@
          (('exit)
           (media-play audio:exit)
           'next-level)
+         (('gem)
+          (media-play audio:pickup)
+          (set! *gems* (cons *level-idx* *gems*))
+          #f)
          (_ #f)))
      (update-objects!)
      result))
@@ -220,6 +233,12 @@
 (define (draw-clock-emitter pos)
   (draw-tile context tileset 48 (vec2-x pos) (vec2-y pos)))
 
+(define (draw-floor-switch pos on?)
+  (draw-tile context tileset (if on? 25 24) (vec2-x pos) (vec2-y pos)))
+
+(define (draw-gem pos)
+  (draw-tile context tileset 28 (vec2-x pos) (vec2-y pos)))
+
 (define (draw-object obj)
   (match obj
     (#f #f)
@@ -227,7 +246,9 @@
     (('exit pos) (draw-exit pos))
     (('wall pos type) (draw-wall type pos))
     (('block pos type) (draw-block type pos))
-    (('clock-emitter pos) (draw-clock-emitter pos))))
+    (('clock-emitter pos) (draw-clock-emitter pos))
+    (('floor-switch pos on?) (draw-floor-switch pos on?))
+    (('gem pos) (draw-gem pos))))
 
 (define (draw-background)
   (let* ((bv (level-background *level*))
@@ -282,7 +303,10 @@
          (move-player 'down))
         ((string=? key key:undo)
          (rollback-snapshot!)
-         (with-goblins (update-objects!)))))
+         (with-goblins (update-objects!)))
+        ;; REMOVE BEFORE RELEASE!!!!
+        ((string=? key key:confirm)
+         (next-level!))))
       ('win
        (cond
         ((string=? key key:confirm)
diff --git a/modules/game/actors.scm b/modules/game/actors.scm
index 8bb9d33..c7e0abb 100644
--- a/modules/game/actors.scm
+++ b/modules/game/actors.scm
@@ -6,6 +6,8 @@
             ^wall
             ^block
             ^clock-emitter
+            ^floor-switch
+            ^gem
             ^player
             ^level))
 
@@ -24,8 +26,11 @@
   (match-lambda*
     (('type) 'exit)
     (('position) position)
-    (('tick) #f)
+    (('tick grid-info) #f)
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
     (('wire-state) #f)
+    (('alive?) #t)
     (('set-wire-state) #f)
     (('describe) `(exit ,position))
     (('collide other offset grid-info) #f)))
@@ -36,7 +41,9 @@
   (match-lambda*
     (('type) 'wall)
     (('position) position)
-    (('tick) #f)
+    (('tick grid-info) #f)
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
     (('wire-state)
      (match type
        ((or 'copper 'electron-head 'electron-tail)
@@ -44,6 +51,7 @@
        (_ #f)))
     (('set-wire-state type)
      (bcom (^wall bcom x y type)))
+    (('alive?) #t)
     (('describe) `(wall ,position ,type))
     (('collide other offset grid-info) #f)))
 
@@ -54,7 +62,9 @@
   (match-lambda*
     (('type) 'block)
     (('position) ($ position))
-    (('tick) ($ pushed? #f))
+    (('tick grid-info) ($ pushed? #f))
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
     (('wire-state)
      (match type
        ((or 'copper 'electron-head 'electron-tail)
@@ -64,6 +74,7 @@
      (match ($ position)
        (#(x y)
         (bcom (^block bcom x y type)))))
+    (('alive?) #t)
     (('describe) `(block ,($ position) ,type))
     (('collide other offset grid-info)
      (match ($ position)
@@ -83,7 +94,9 @@
   (match-lambda*
     (('type) 'emitter)
     (('position) position)
-    (('tick) ($ timer (+ ($ timer) 1)))
+    (('tick grid-info) ($ timer (+ ($ timer) 1)))
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
     (('wire-state)
      (let ((t ($ timer)))
        (cond
@@ -93,10 +106,47 @@
          'electron-tail)
         (else
          'copper))))
+    (('alive?) #t)
     (('set-wire-state type) #f)
     (('describe) `(clock-emitter ,position))
     (('collide other offset grid-info) #f)))
 
+(define (^floor-switch bcom x y)
+  (define position (vector x y))
+  (define on? (spawn ^cell))
+  (match-lambda*
+    (('type) 'switch)
+    (('position) position)
+    (('tick grid-info) #f)
+    (('enter obj grid-info)
+     ($ on? #t))
+    (('exit obj grid-info)
+     (when (= (length ($ grid-info 'occupants x y)) 1)
+       (pk 'OFF)
+       ($ on? #f)))
+    (('wire-state) #f)
+    (('alive?) #t)
+    (('describe) `(floor-switch ,position ,($ on?)))
+    (('collide other offset grid-info)
+     (pk 'ON)
+     ($ on? #t))))
+
+(define (^gem bcom x y)
+  (define position (vector x y))
+  (define picked-up? (spawn ^cell))
+  (match-lambda*
+    (('type) 'gem)
+    (('position) position)
+    (('tick grid-info) #f)
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
+    (('wire-state) #f)
+    (('alive?) (not ($ picked-up?)))
+    (('describe) `(gem ,position))
+    (('collide other offset grid-info)
+     (when (eq? ($ other 'type) 'player)
+       ($ picked-up? #t)))))
+
 (define (^player bcom x y)
   (define position (spawn ^cell (vector x y)))
   (define velocity (spawn ^cell #(0 0)))
@@ -112,7 +162,7 @@
           ('up #(0 -1))
           ('down #(0 1))
           (_ (error "invalid direction" dir)))))
-    (('tick)
+    (('tick grid-info)
      ($ event #f)
      (match ($ position)
        (#(x y)
@@ -120,7 +170,10 @@
           (#(dx dy)
            ($ position (vector (+ x dx) (+ y dy)))
            ($ velocity #(0 0)))))))
+    (('enter obj grid-info) #f)
+    (('exit obj grid-info) #f)
     (('wire-state) #f)
+    (('alive?) #t)
     (('describe) `(player ,($ position)))
     (('collide other offset grid-info)
      (define (reverse-move)
@@ -137,6 +190,8 @@
             (begin
               (reverse-move)
               ($ event '(bump)))))
+       ('switch ($ event '(switch)))
+       ('gem ($ event '(gem)))
        (_
         (reverse-move)
         ($ event '(bump)))))
@@ -172,7 +227,9 @@
   (define (^grid-info bcom)
     (match-lambda*
       (('occupied? x y)
-       (not (null? ($ (grid-ref grid x y)))))))
+       (not (null? ($ (grid-ref grid x y)))))
+      (('occupants x y)
+       ($ (grid-ref grid x y)))))
   (define grid-info (spawn ^grid-info))
 
   (define (delq item lst)
@@ -187,12 +244,20 @@
     (unless (equal? prev-pos resolved-pos)
       (match prev-pos
         (#(x y)
-         (let ((cell (grid-ref grid x y)))
-           ($ cell (delq obj ($ cell))))))
+         (let* ((cell (grid-ref grid x y))
+                (remaining (delq obj ($ cell))))
+           ($ cell remaining)
+           (for-each (lambda (other)
+                       ($ other 'exit obj grid-info))
+                     remaining))))
       (match resolved-pos
         (#(x y)
-         (let ((cell (grid-ref grid x y)))
-           ($ cell (cons obj ($ cell))))))))
+         (let* ((cell (grid-ref grid x y))
+                (occupants ($ cell)))
+           ($ cell (cons obj occupants))
+           (for-each (lambda (other)
+                       ($ other 'enter obj grid-info))
+                     occupants))))))
   (define (collide obj pos prev-pos)
     (match pos
       (#(x y)
@@ -230,14 +295,21 @@
          (check (- x 1) (+ y 1))
          (check (- x 1) y)))
     ;; Tick each object and check for collisions.
-    (for-each (lambda (obj)
-                (let ((prev-pos ($ obj 'position)))
-                  ($ obj 'tick)
-                  ;; Only check collisions for movable objects.
-                  (let ((desired-pos ($ obj 'position)))
-                    (unless (equal? prev-pos desired-pos)
-                      (collide obj desired-pos prev-pos)))))
-              ($ objects))
+    ($ objects
+       (let lp ((objs ($ objects)))
+         (match objs
+           (() '())
+           ((obj . rest)
+            (let ((prev-pos ($ obj 'position)))
+              ($ obj 'tick grid-info)
+              ;; Only check collisions for movable objects.
+              (let ((desired-pos ($ obj 'position)))
+                (unless (equal? prev-pos desired-pos)
+                  (collide obj desired-pos prev-pos)))
+              ;; Cull dead objects.
+              (if ($ obj 'alive?)
+                  (cons obj (lp rest))
+                  (lp rest)))))))
     ;; Advance Wirewold simulation.
     (for-each (match-lambda
                 ((refr . wire-state)
diff --git a/modules/game/level.scm b/modules/game/level.scm
index 50c9710..1e91c10 100644
--- a/modules/game/level.scm
+++ b/modules/game/level.scm
@@ -19,7 +19,7 @@
   (actor level-actor)
   (player level-player))
 
-(define (make-level width height background objects)
+(define (make-level width height background objects spawn-gem?)
   (let ((level* (spawn ^level width height))
         (len (bytevector-length objects)))
     ;; Parsed packed object data and spawn objects, making special
@@ -37,9 +37,12 @@
                        (5 (spawn ^block x y 'copper))
                        (6 (spawn ^block x y 'crate))
                        (7 (spawn ^clock-emitter x y 4))
+                       (8 (spawn ^floor-switch x y))
+                       (9 (and spawn-gem? (spawn ^gem x y)))
                        (id (error "invalid level object" id)))))
-            ($ level* 'add-object obj)
-            (if (= id 3) ; player-spawn
+            (when obj
+              ($ level* 'add-object obj))
+            (if (= id 3)               ; player-spawn
                 (lp (+ i 3) obj)
                 (lp (+ i 3) player)))
           (%make-level background level* player)))))
diff --git a/modules/game/levels/level-1.tmx b/modules/game/levels/level-1.tmx
index 3aaeb6b..56386cc 100644
--- a/modules/game/levels/level-1.tmx
+++ b/modules/game/levels/level-1.tmx
@@ -1,5 +1,5 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="6">
+<map version="1.8" tiledversion="1.8.6" orientation="orthogonal" renderorder="right-down" width="20" height="15" tilewidth="16" tileheight="16" infinite="0" nextlayerid="3" nextobjectid="8">
  <tileset firstgid="1" source="tiles.tsx"/>
  <layer id="1" name="background" width="20" height="15">
   <data encoding="csv">
@@ -22,5 +22,7 @@
  </layer>
  <objectgroup id="2" name="objects">
   <object id="1" type="player-spawn" gid="1" x="96" y="112" width="16" height="16"/>
+  <object id="6" type="floor-switch" gid="25" x="128" y="112" width="16" height="16"/>
+  <object id="7" type="gem" gid="29" x="32" y="112" width="16" height="16"/>
  </objectgroup>
 </map>
diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm
index dfeb85d..c51b041 100644
--- a/scripts/compile-map.scm
+++ b/scripts/compile-map.scm
@@ -552,6 +552,8 @@ the default ORIENTATION value of 'orthogonal' is supported."
 (define obj:block:copper 5)
 (define obj:block:crate 6)
 (define obj:clock-emitter 7)
+(define obj:floor-switch 8)
+(define obj:gem 9)
 
 (define (compile-environment-layer tile-map layer-name)
   (let ((tw (tile-map-tile-width tile-map))
@@ -583,7 +585,7 @@ the default ORIENTATION value of 'orthogonal' is supported."
     (append-map (lambda (obj)
                   (let* ((type (map-object-type obj))
                          (properties (map-object-properties obj))
-                         (r (pk 'obj type (map-object-shape obj)))
+                         (r (map-object-shape obj))
                          (x (/ (rect-x r) tw))
                          (y (/ (rect-y r) th)))
                     (match type
@@ -593,6 +595,8 @@ the default ORIENTATION value of 'orthogonal' is supported."
                          ("crate" (list x y obj:block:crate))
                          ("copper" (list x y obj:block:copper))
                          (kind (error "unsupported block kind" kind))))
+                      ('floor-switch (list x y obj:floor-switch))
+                      ('gem (list x y obj:gem))
                       (_ (error "unsupported object type" type)))))
                 (object-layer-objects layer))))
 
@@ -611,12 +615,13 @@ the default ORIENTATION value of 'orthogonal' is supported."
                `((define-module ,module-name
                    #:use-module (game level)
                    #:export (,proc-name))
-                 (define (,proc-name)
+                 (define (,proc-name spawn-gem?)
                    (make-level ,(tile-map-width tile-map)
                                ,(tile-map-height tile-map)
                                ,(compile-tile-layer tile-map "background")
                                ,(u8-list->bytevector
                                  (append
                                   (compile-environment-layer tile-map "background")
-                                  (compile-object-layer tile-map "objects")))))))))
+                                  (compile-object-layer tile-map "objects")))
+                               spawn-gem?))))))
   (_ (error "file name expected")))