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