diff --git a/game.scm b/game.scm index 68283d7..4cd58e6 100644 --- a/game.scm +++ b/game.scm @@ -127,18 +127,13 @@ (define (update-objects!) (set! *objects* - ;; Filter out the objects that are baked into the background - ;; and thus do not need to be rendered repeatedly. Then, - ;; z-sort the list so we render in the correct order. - ;; Finally, convert positions to vec2s for more efficient - ;; rendering. + ;; z-sort the list so we render in the correct order. Then + ;; convert tile positions to vec2s of pixel coordinates for + ;; more efficient rendering. (map (match-lambda ((type #(x y _) . properties) - (pk 'obj `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties)))) - (sort (filter-map (match-lambda - (((or 'wall 'exit) . _) #f) - (desc desc)) - ($ (level-actor *level*) 'describe)) + `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))) + (sort ($ (level-actor *level*) 'describe) (lambda (a b) (match a ((_ #(_ _ az) . _) @@ -243,14 +238,9 @@ (define (draw-exit pos) (draw-tile context tileset 27 (vec2-x pos) (vec2-y pos))) -(define (draw-wall type pos) +(define (draw-wall pos type) (let ((x (vec2-x pos)) (y (vec2-y pos))) - (match type - ('brick - (draw-tile context tileset 22 x y)) - (_ - (draw-tile context tileset 2 x y))) (match type ('electron-head (draw-tile context tileset 4 x y)) @@ -258,7 +248,7 @@ (draw-tile context tileset 5 x y)) (_ #f)))) -(define (draw-block type pos) +(define (draw-block pos type) (let ((x (vec2-x pos)) (y (vec2-y pos))) (match type @@ -287,11 +277,10 @@ (match obj (#f #f) (('player pos) (draw-player pos)) - ;; Wall and exit tiles are baked into the background layer. - (('exit pos) #t) - (('wall pos type) #t) - (('block pos type) (draw-block type pos)) - (('clock-emitter pos) (draw-clock-emitter pos)) + (('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 (('floor-switch pos on?) (draw-floor-switch pos on?)) (('gem pos) (draw-gem pos)) (('gate pos open?) (draw-gate pos open?)))) diff --git a/modules/game/actors.scm b/modules/game/actors.scm index 02b554d..48ad02f 100644 --- a/modules/game/actors.scm +++ b/modules/game/actors.scm @@ -12,6 +12,15 @@ ^player ^level)) +;; The default wireworld rules. Actors are free to use this or +;; implement their own rule for themselves. +(define (wireworld-next wire-state neighbors) + (match wire-state + (#f #f) + ('copper (if (<= 1 neighbors 2) 'electron-head 'copper)) + ('electron-head 'electron-tail) + ('electron-tail 'copper))) + (define* (^cell bcom #:optional val) (case-lambda (() val) @@ -31,8 +40,8 @@ (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) + (('update-wire-state grid-info) #f) (('alive?) #t) - (('set-wire-state) #f) (('describe) `(exit ,position)) (('collide other offset grid-info) #f))) @@ -50,8 +59,13 @@ ((or 'copper 'electron-head 'electron-tail) type) (_ #f))) - (('set-wire-state type) - (bcom (^wall bcom x y type))) + (('update-wire-state grid-info) + (match type + ((or 'copper 'electron-head 'electron-tail) + (let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y)) + (type (wireworld-next type neighbors))) + (bcom (^wall bcom x y type)))) + (_ #f))) (('alive?) #t) (('describe) `(wall ,position ,type)) (('collide other offset grid-info) #f))) @@ -71,10 +85,15 @@ ((or 'copper 'electron-head 'electron-tail) type) (_ #f))) - (('set-wire-state type) - (match ($ position) - (#(x y _) - (bcom (^block bcom x y type))))) + (('update-wire-state grid-info) + (match type + ((or 'copper 'electron-head 'electron-tail) + (match ($ position) + (#(x y z) + (let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y)) + (type (wireworld-next type neighbors))) + (bcom (^block bcom x y type)))))) + (_ #f))) (('alive?) #t) (('describe) `(block ,($ position) ,type)) (('collide other offset grid-info) @@ -96,7 +115,7 @@ (('pushed?) ($ pushed?)))) (define (^clock-emitter bcom x y interval) - (define timer (spawn ^cell 1)) + (define timer (spawn ^cell 0)) (define position (vector x y 0)) (match-lambda* (('type) 'emitter) @@ -113,6 +132,7 @@ 'electron-tail) (else 'copper)))) + (('update-wire-state grid-info) #f) (('alive?) #t) (('set-wire-state type) #f) (('describe) `(clock-emitter ,position)) @@ -129,18 +149,17 @@ ($ on? #t)) (('exit obj grid-info) (when (= (length ($ grid-info 'occupants x y)) 1) - (pk 'OFF) - ($ on? #f) + ($ on? #f) (match ($ grid-info 'occupants target-x target-y) (() (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) - (pk 'ON) - ($ on? #t) + ($ on? #t) (match ($ grid-info 'occupants target-x target-y) (() (pk "no switch target!")) ((target . _) @@ -156,6 +175,7 @@ (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) + (('update-wire-state grid-info) #f) (('alive?) (not ($ picked-up?))) (('describe) `(gem ,position)) (('collide other offset grid-info) @@ -174,6 +194,7 @@ (('activate) ($ open? #t)) (('deactivate) ($ open? #f)) (('wire-state) #f) + (('update-wire-state grid-info) #f) (('alive?) #t) (('open?) ($ open?)) (('describe) `(gate ,position ,($ open?))) @@ -205,6 +226,7 @@ (('enter obj grid-info) #f) (('exit obj grid-info) #f) (('wire-state) #f) + (('update-wire-state grid-info) #f) (('alive?) #t) (('describe) `(player ,($ position))) (('collide other offset grid-info) @@ -259,13 +281,60 @@ (vector-set! grid (+ (* y width) x) val)) (define grid (make-grid '())) + (define wire-grid (make-grid #f)) + (define (refresh-wire-grid) + (for-each-coord + (lambda (x y) + (let ((obj-cell (grid-ref grid x y)) + (wire-cell (grid-ref wire-grid x y))) + (match ($ obj-cell) + (() #f) + ;; TODO: Handle tiles with many occupants. Might not be + ;; necessary in practice. + ((refr . _) + ($ wire-cell ($ refr 'wire-state)))))))) + (define (wire-state-at x y) + ($ (grid-ref/wrap wire-grid x y))) + (define (neighbor-count x y) + (define (check x y) + (match (wire-state-at x y) + ('electron-head 1) + (_ 0))) + (+ (check (- x 1) (- y 1)) + (check x (- y 1)) + (check (+ x 1) (- y 1)) + (check (- x 1) y) + (check (+ x 1) y) + (check (- x 1) (+ y 1)) + (check x (+ y 1)) + (check (+ x 1) (+ y 1)))) + ;; flattened 3x3 grid of neighbor states. '_' used to mark the + ;; center. + (define (neighbor-grid x y) + (vector (wire-state-at (- x 1) (- y 1)) + (wire-state-at x (- y 1)) + (wire-state-at (+ x 1) (- y 1)) + + (wire-state-at (- x 1) y) + '_ + (wire-state-at (+ x 1) y) + + (wire-state-at (- x 1) (+ y 1)) + (wire-state-at x (+ y 1)) + (wire-state-at (+ x 1) (+ y 1)))) + ;; Read-only access to query the grid. (define (^grid-info bcom) (match-lambda* (('occupied? x y) (not (null? ($ (grid-ref grid x y))))) (('occupants x y) - ($ (grid-ref grid x y))))) + ($ (grid-ref grid x y))) + ;; How many electron heads around (x, y)? + (('wireworld-neighbor-count x y) + (neighbor-count x y)) + (('wireworld-neighbor-grid x y) + (neighbor-grid x y)))) (define grid-info (spawn ^grid-info)) (define (delq item lst) @@ -318,23 +387,6 @@ (collide other other-pos other-prev-pos))) (lp rest)))))))))))) (define (tick) - (define (neighbors x y) - (define (check x y) - (match ($ (grid-ref/wrap grid x y)) - (() 0) - ;; TODO: Handle tiles with many occupants. - ((refr . _) - (match ($ refr 'wire-state) - ('electron-head 1) - (_ 0))))) - (+ (check (- x 1) (- y 1)) - (check x (- y 1)) - (check (+ x 1) (- y 1)) - (check (+ x 1) y) - (check (+ x 1) (+ y 1)) - (check x (+ y 1)) - (check (- x 1) (+ y 1)) - (check (- x 1) y))) ;; Tick each object and check for collisions. ($ objects (let lp ((objs ($ objects))) @@ -352,30 +404,10 @@ (cons obj (lp rest)) (lp rest))))))) ;; Advance Wirewold simulation. - (for-each (match-lambda - ((refr . wire-state) - ($ refr 'set-wire-state wire-state))) - (let y-loop ((y 0) (updates '())) - (if (< y height) - (y-loop (1+ y) - (let x-loop ((x 0) (updates updates)) - (if (< x width) - (match ($ (grid-ref grid x y)) - (() (x-loop (1+ x) updates)) - ;; TODO: Handle many occupants - ((refr . _) - (match ($ refr 'wire-state) - (#f (x-loop (1+ x) updates)) - ('copper - (if (<= 1 (neighbors x y) 2) - (x-loop (1+ x) (cons `(,refr . electron-head) updates)) - (x-loop (1+ x) updates))) - ('electron-head - (x-loop (1+ x) (cons `(,refr . electron-tail) updates))) - ('electron-tail - (x-loop (1+ x) (cons `(,refr . copper) updates)))))) - updates))) - updates)))) + (refresh-wire-grid) + (for-each (lambda (obj) + ($ obj 'update-wire-state grid-info)) + ($ objects))) (match-lambda* (('tick) (tick)) diff --git a/modules/game/levels/level-3.tmx b/modules/game/levels/level-3.tmx index d3b3bc1..3ecf9a6 100644 --- a/modules/game/levels/level-3.tmx +++ b/modules/game/levels/level-3.tmx @@ -1,31 +1,40 @@ - + 23,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,24,24,23,23,23, -23,23,24,24,24,24,24,24,24,28,24,24,24,24,24,24,24,24,23,23, -23,24,24,24,24,24,24,24,24,24,24,24,3,3,24,24,24,24,24,23, -23,49,3,3,3,3,24,3,3,3,3,3,3,24,3,3,3,3,3,23, -23,24,24,24,24,24,24,24,24,24,24,24,3,3,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23, -23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23, -23,23,23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,23, +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,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, +23,24,24,24,24,24,24,24,24,24,24,24,24,24,24,23,24,28,24,23, +23,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,24,24,24,23, +23,24,24,24,24,24,24,24,24,24,24,24,24,24,23,23,24,24,24,23, +23,23,24,24,24,24,24,24,24,24,24,24,24,23,23,23,23,23,23,23, +23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, +23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23 - - + + + + + + + + + + + diff --git a/scripts/compile-map.scm b/scripts/compile-map.scm index a4d5cf4..d794d02 100644 --- a/scripts/compile-map.scm +++ b/scripts/compile-map.scm @@ -601,6 +601,9 @@ 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)) (_ (error "unsupported object type" type))))) (object-layer-objects layer))))