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
|
|
@ -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>
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue