From 5756844161a860106363855aa3881a68c725f919 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 22 May 2024 08:00:39 -0400 Subject: [PATCH] Add basic AND gate and electric switch. --- game.scm | 14 ++++-- modules/game/actors.scm | 89 +++++++++++++++++++++++++++++---- modules/game/level.scm | 7 ++- modules/game/levels/level-3.tmx | 9 ++-- scripts/compile-map.scm | 9 ++-- 5 files changed, 105 insertions(+), 23 deletions(-) diff --git a/game.scm b/game.scm index eb158b2..d3de151 100644 --- a/game.scm +++ b/game.scm @@ -280,17 +280,25 @@ (define (draw-gate pos open?) (draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos))) +(define (draw-and-gate pos) + (draw-tile context tileset 42 (vec2-x pos) (vec2-y pos))) + +(define (draw-electric-switch pos on?) + (draw-tile context tileset (if on? 7 6) (vec2-x pos) (vec2-y pos))) + (define (draw-object obj) (match obj (#f #f) (('player pos) (draw-player pos)) - (('exit pos) #t) ; drawn via background + (('exit pos) #t) ; drawn via background (('wall pos type) (draw-wall pos type)) (('block pos type) (draw-block pos type)) - (('clock-emitter pos) #t) ; drawn via background + (('clock-emitter pos) #t) ; drawn via background (('floor-switch pos on?) (draw-floor-switch pos on?)) (('gem pos) (draw-gem pos)) - (('gate pos open?) (draw-gate pos open?)))) + (('gate pos open?) (draw-gate pos open?)) + (('and-gate pos) (draw-and-gate pos)) + (('electric-switch pos on?) (draw-electric-switch pos on?)))) (define (draw-background) (let* ((bv (level-background *level*)) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index e11bd60..8a8d9c1 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -9,6 +9,8 @@ ^floor-switch ^gate ^gem + ^and-gate + ^electric-switch ^player ^level)) @@ -134,10 +136,18 @@ 'copper)))) (('update-wire-state grid-info) #f) (('alive?) #t) - (('set-wire-state type) #f) (('describe) `(clock-emitter ,position)) (('collide other offset grid-info) #f))) +(define (first-non-player-occupant grid-info x y) + (let lp ((objs ($ grid-info 'occupants x y))) + (match objs + (() #f) + ((obj . rest) + (if (eq? ($ obj 'type) 'player) + (lp rest) + obj))))) + (define (^floor-switch bcom x y target-x target-y) (define position (vector x y 0)) (define on? (spawn ^cell)) @@ -149,21 +159,49 @@ ($ on? #t)) (('exit obj grid-info) (when (= (length ($ grid-info 'occupants x y)) 1) - ($ on? #f) - (match ($ grid-info 'occupants target-x target-y) - (() (pk "no switch target!")) - ((target . _) - ($ target 'deactivate))))) + ($ on? #f) + (match (first-non-player-occupant grid-info target-x target-y) + (#f (pk "no switch target!")) + (target ($ target 'deactivate))))) (('wire-state) #f) (('update-wire-state grid-info) #f) (('alive?) #t) (('describe) `(floor-switch ,position ,($ on?))) (('collide other offset grid-info) - ($ on? #t) - (match ($ grid-info 'occupants target-x target-y) - (() (pk "no switch target!")) - ((target . _) - ($ target 'activate)))))) + ($ on? #t) + (match (first-non-player-occupant grid-info target-x target-y) + (#f (pk "no switch target!")) + (target ($ target 'activate)))))) + +(define (^electric-switch bcom x y target-x target-y) + (define position (vector x y 0)) + (define on? (spawn ^cell)) + (define timer (spawn ^cell)) + (match-lambda* + (('type) 'switch) + (('position) position) + (('tick grid-info) #f) + (('enter obj grid-info) #f) + (('exit obj grid-info) #f) + (('wire-state) #f) + (('update-wire-state grid-info) + (if ($ on?) + (let ((t (1- ($ timer)))) + ($ timer t) + (when (= t 0) + ($ on? #f) + (match (first-non-player-occupant grid-info target-x target-y) + (#f (pk "no switch target!")) + (target ($ target 'deactivate))))) + (when (>= ($ grid-info 'wireworld-neighbor-count x y) 1) + ($ on? #t) + ($ timer 2) + (match (first-non-player-occupant grid-info target-x target-y) + (#f (pk "no switch target!")) + (target ($ target 'activate)))))) + (('alive?) #t) + (('describe) `(electric-switch ,position ,($ on?))) + (('collide other offset grid-info) #f))) (define (^gem bcom x y) (define position (vector x y 1)) @@ -200,6 +238,35 @@ (('describe) `(gate ,position ,($ open?))) (('collide other offset grid-info) #f))) +(define (^and-gate bcom x y) + (define position (vector x y 0)) + (define state (spawn ^cell 'copper)) + (match-lambda* + (('type) 'emitter) + (('position) position) + (('tick grid-info) #f) + (('enter obj grid-info) #f) + (('exit obj grid-info) #f) + (('wire-state) ($ state)) + (('update-wire-state grid-info) + (match ($ state) + ('electron-head ($ state 'electron-tail)) + ('electron-tail ($ state 'copper)) + ('copper + ;; TODO: Match other shapes? This only allows left-to-right + ;; circuit flow. + (match (pk 'GRID ($ grid-info 'wireworld-neighbor-grid x y)) + (#('electron-head #f #f + #f _ 'copper + 'electron-head #f #f) + (pk 'COOL) + ($ state 'electron-head)) + (_ ($ state 'copper))))) + (pk 'NEW-STATE ($ state))) + (('alive?) #t) + (('describe) `(and-gate ,position)) + (('collide other offset grid-info) #f))) + (define (^player bcom x y) (define position (spawn ^cell (vector x y 2))) (define velocity (spawn ^cell #(0 0))) diff --git a/modules/game/level.scm b/modules/game/level.scm index c7f2f2e..c3b30f3 100644 --- a/modules/game/level.scm +++ b/modules/game/level.scm @@ -42,9 +42,14 @@ (spawn ^floor-switch x y target-x target-y))) (9 (and spawn-gem? (spawn ^gem x y))) (10 (spawn ^gate x y)) + (11 (spawn ^and-gate x y)) + (12 (let ((target-x (bytevector-u8-ref objects (+ i 3))) + (target-y (bytevector-u8-ref objects (+ i 4)))) + (spawn ^electric-switch x y target-x target-y))) (id (error "invalid level object" id)))) (i* (+ i (match id - (8 5) ; floor-switch + ;; floor-switch or electric-switch + ((or 8 12) 5) (_ 3))))) (when obj ($ level* 'add-object obj)) diff --git a/modules/game/levels/level-3.tmx b/modules/game/levels/level-3.tmx index 3ecf9a6..cfaacb2 100644 --- a/modules/game/levels/level-3.tmx +++ b/modules/game/levels/level-3.tmx @@ -7,7 +7,7 @@ 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23,23,23,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,24,24,24,23, -23,49,3,3,3,24,3,3,3,3,3,3,24,24,24,23,24,24,24,23, +23,24,49,3,3,24,3,3,3,3,3,3,24,24,24,23,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,3,24,23,24,24,24,23, 23,24,24,24,24,24,49,3,3,3,3,3,24,24,24,24,24,24,24,23, 23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,24,24,24,23, @@ -27,13 +27,12 @@ - + - - + + - diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm index d794d02..62b25d2 100644 --- a/scripts/compile-map.scm +++ b/scripts/compile-map.scm @@ -555,6 +555,8 @@ the default ORIENTATION value of 'orthogonal' is supported." (define obj:floor-switch 8) (define obj:gem 9) (define obj:gate 10) +(define obj:and-gate 11) +(define obj:electric-switch 12) (define (compile-environment-layer tile-map layer-name) (let ((tw (tile-map-tile-width tile-map)) @@ -601,9 +603,10 @@ the default ORIENTATION value of 'orthogonal' is supported." (assq-ref properties 'target-y))) ('gem (list x y obj:gem)) ('gate (list x y obj:gate)) - ;; TODO: Implement these - ('and-gate (list x y obj:block:copper)) - ('electric-switch (list x y obj:wall:copper)) + ('and-gate (list x y obj:and-gate)) + ('electric-switch (list x y obj:electric-switch + (assq-ref properties 'target-x) + (assq-ref properties 'target-y))) (_ (error "unsupported object type" type))))) (object-layer-objects layer))))