Reimplement wireworld update; add stubs for new object types.
This commit is contained in:
David Thompson
parent
4c12ccc559
commit
984ea4df67
4 changed files with 125 additions and 92 deletions
33
game.scm
33
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?))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -1,31 +1,40 @@
|
|||
<?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="5">
|
||||
<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="12">
|
||||
<tileset firstgid="1" source="tiles.tsx"/>
|
||||
<layer id="1" name="background" width="20" height="15">
|
||||
<data encoding="csv">
|
||||
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
|
||||
</data>
|
||||
</layer>
|
||||
<objectgroup id="2" name="objects">
|
||||
<object id="1" type="player-spawn" gid="1" x="128" y="144" width="16" height="16"/>
|
||||
<object id="4" type="block" gid="4" x="96" y="80" width="16" height="16">
|
||||
<object id="1" type="player-spawn" gid="1" x="80" y="144" width="16" height="16"/>
|
||||
<object id="4" type="block" gid="4" x="80" y="128" width="16" height="16">
|
||||
<properties>
|
||||
<property name="kind" value="copper"/>
|
||||
</properties>
|
||||
</object>
|
||||
<object id="7" type="floor-switch" gid="25" x="80" y="96" width="16" height="16">
|
||||
<properties>
|
||||
<property name="target-x" type="int" value="11"/>
|
||||
<property name="target-y" type="int" value="7"/>
|
||||
</properties>
|
||||
</object>
|
||||
<object id="8" type="electric-switch" gid="8" x="224" y="80" width="16" height="16"/>
|
||||
<object id="9" type="gate" gid="46" x="240" y="96" width="16" height="16"/>
|
||||
<object id="10" type="and-gate" gid="43" x="192" y="80" width="16" height="16"/>
|
||||
</objectgroup>
|
||||
</map>
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue