From ba7b9ea9d88e9aa86fa3386d4e0102da1d93b434 Mon Sep 17 00:00:00 2001 From: David Thompson 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 @@ - + @@ -22,5 +22,7 @@ + + 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")))