From 73ffad19f0376710f36f3d03f9e41f6b7bc032a7 Mon Sep 17 00:00:00 2001 From: Juliana Sims Date: Thu, 23 May 2024 14:00:55 -0400 Subject: [PATCH] Implement orientation for logic gates Note that orientation is called "direction" because it's named according to the direction of electron flow. --- modules/game/actors.scm | 200 +++++++++++++++++++++++++++----- modules/game/level.scm | 10 +- modules/game/levels/level-3.tmx | 6 +- modules/game/levels/level-4.tmx | 18 ++- scripts/compile-map.scm | 23 +++- 5 files changed, 219 insertions(+), 38 deletions(-) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index 8bd0ca5..b65b653 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -365,36 +365,58 @@ (('exit obj grid-info) #f) (('wire-state grid-info) ($ state)) (('update-wire-state grid-info) - (update-wire-state state grid-info)) + (match ($ state) + ('electron-head ($ state 'electron-tail)) + ('electron-tail ($ state 'copper)) + ('copper + (update-wire-state state ($ grid-info 'wireworld-neighbor-grid x y))))) (('alive?) #t) (('describe) `(,name ,position ,($ state))) (('collide other offset grid-info) #f))) -(define (^and-gate bcom x y) - (define (update-wire-state 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 ($ grid-info 'wireworld-neighbor-grid x y) +(define direction:right 1) +(define direction:left 2) +(define direction:up 3) +(define direction:down 4) + +(define (^and-gate bcom x y direction) + (define (update-wire-state state neighbor-grid) + (match direction + (direction:right + (match neighbor-grid (#('electron-head #f #f #f _ 'copper 'electron-head #f #f) ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:left + (match neighbor-grid + (#(#f #f 'electron-head + 'copper _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:up + (match neighbor-grid + (#(#f 'copper #f + #f _ #f + 'electron-head #f 'electron-head) + ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:down + (match neighbor-grid + (#('electron-head #f 'electron-head + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) (_ ($ state 'copper)))))) (^logic-gate bcom x y 'and-gate update-wire-state)) -(define (^xor-gate bcom x y) - (define (update-wire-state 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 ($ grid-info 'wireworld-neighbor-grid x y) +(define (^xor-gate bcom x y direction) + (define (update-wire-state state neighbor-grid) + (match direction + (direction:right + (match neighbor-grid (#('electron-head #f #f #f _ 'copper #f #f #f) @@ -411,18 +433,71 @@ #f _ 'copper 'electron-head #f #f) ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:left + (match neighbor-grid + (#(#f #f 'electron-head + 'copper _ #f + #f #f #f) + ($ state 'electron-head)) + (#(#f #f 'electron-head + 'copper _ #f + #f #f 'copper) + ($ state 'electron-head)) + (#(#f #f #f + 'copper _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (#(#f #f 'copper + 'copper _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:up + (match neighbor-grid + (#(#f 'copper #f + #f _ #f + 'electron-head #f #f) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + 'electron-head #f 'copper) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + 'copper #f 'electron-head) + ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:down + (match neighbor-grid + (#('electron-head #f #f + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#('electron-head #f 'copper + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#(#f #f 'electron-head + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#('copper #f 'electron-head + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) (_ ($ state 'copper)))))) (^logic-gate bcom x y 'xor-gate update-wire-state)) -(define (^or-gate bcom x y) - (define (update-wire-state 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 ($ grid-info 'wireworld-neighbor-grid x y) +(define (^or-gate bcom x y direction) + (define (update-wire-state state neighbor-grid) + (match direction + (direction:right + (match neighbor-grid (#('electron-head #f #f #f _ 'copper #f #f #f) @@ -443,6 +518,75 @@ #f _ 'copper 'electron-head #f #f) ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:left + (match neighbor-grid + (#(#f #f 'electron-head + 'copper _ #f + #f #f #f) + ($ state 'electron-head)) + (#(#f #f 'electron-head + 'copper _ #f + #f #f 'copper) + ($ state 'electron-head)) + (#(#f #f #f + 'copper _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (#(#f #f 'copper + 'copper _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (#(#f #f 'electron-head + 'copper _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:up + (match neighbor-grid + (#(#f 'copper #f + #f _ #f + 'electron-head #f #f) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + 'electron-head #f 'copper) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + #f #f 'electron-head) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + 'copper #f 'electron-head) + ($ state 'electron-head)) + (#(#f 'copper #f + #f _ #f + 'electron-head #f 'electron-head) + ($ state 'electron-head)) + (_ ($ state 'copper)))) + (direction:down + (match neighbor-grid + (#('electron-head #f #f + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#('electron-head #f 'copper + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#(#f #f 'electron-head + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#('copper #f 'electron-head + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) + (#('electron-head #f 'electron-head + #f _ #f + #f 'copper #f) + ($ state 'electron-head)) (_ ($ state 'copper)))))) (^logic-gate bcom x y 'or-gate update-wire-state)) diff --git a/modules/game/level.scm b/modules/game/level.scm index 75f93b3..5990a0d 100644 --- a/modules/game/level.scm +++ b/modules/game/level.scm @@ -74,15 +74,18 @@ (spawn ^ghost-gem x y) (spawn ^gem x y))) (10 (spawn ^gate x y)) - (11 (spawn ^and-gate x y)) + (11 (spawn ^and-gate x y + (bytevector-u8-ref objects (+ i 3)))) (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))) - (13 (spawn ^xor-gate x y)) + (13 (spawn ^xor-gate x y + (bytevector-u8-ref objects (+ i 3)))) (14 (let ((target-x (bytevector-u8-ref objects (+ i 3))) (target-y (bytevector-u8-ref objects (+ i 4)))) (spawn ^electron-warp x y target-x target-y))) - (15 (spawn ^or-gate x y)) + (15 (spawn ^or-gate x y + (bytevector-u8-ref objects (+ i 3)))) (16 (spawn ^switched-emitter x y 4)) (id (error "invalid level object" id)))) (i* (+ i (match id @@ -90,6 +93,7 @@ ;; electric-switch ;; electron-warp ((or 8 12 14) 5) + ((or 11 13 15) 4) (_ 3))))) (when obj ($ level* 'add-object obj)) diff --git a/modules/game/levels/level-3.tmx b/modules/game/levels/level-3.tmx index f44c48b..cc1d396 100644 --- a/modules/game/levels/level-3.tmx +++ b/modules/game/levels/level-3.tmx @@ -34,7 +34,11 @@ - + + + + + diff --git a/modules/game/levels/level-4.tmx b/modules/game/levels/level-4.tmx index ad44008..c27cef9 100644 --- a/modules/game/levels/level-4.tmx +++ b/modules/game/levels/level-4.tmx @@ -34,9 +34,21 @@ - - - + + + + + + + + + + + + + + + diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm index 0c5d197..cb93e62 100644 --- a/scripts/compile-map.scm +++ b/scripts/compile-map.scm @@ -564,6 +564,11 @@ the default ORIENTATION value of 'orthogonal' is supported." (define obj:or-gate 15) (define obj:switched-emitter 16) +(define direction:right 1) +(define direction:left 2) +(define direction:up 3) +(define direction:down 4) + (define (compile-environment-layer tile-map layer-name) (let ((tw (tile-map-tile-width tile-map)) (th (tile-map-tile-height tile-map)) @@ -589,6 +594,12 @@ the default ORIENTATION value of 'orthogonal' is supported." (iota (tile-layer-height layer))))) (define (compile-object-layer tile-map layer-name) + (define parse-direction + (match-lambda + ("right" direction:right) + ("left" direction:left) + ("up" direction:up) + ("down" direction:down))) (let ((tw (tile-map-tile-width tile-map)) (th (tile-map-tile-height tile-map)) (layer (tile-map-layer-ref tile-map layer-name))) @@ -610,9 +621,15 @@ 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)) - ('and-gate (list x y obj:and-gate)) - ('xor-gate (list x y obj:xor-gate)) - ('or-gate (list x y obj:or-gate)) + ('and-gate (list x y obj:and-gate + (parse-direction + (assq-ref properties 'direction)))) + ('xor-gate (list x y obj:xor-gate + (parse-direction + (assq-ref properties 'direction)))) + ('or-gate (list x y obj:or-gate + (parse-direction + (assq-ref properties 'direction)))) ('electric-switch (list x y obj:electric-switch (assq-ref properties 'target-x) (assq-ref properties 'target-y)))