SuperKamiGuru/foss-mmo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Reimplement wireworld update; add stubs for new object types.

Browse source
This commit is contained in:
David Thompson 2024-05-21 22:12:21 -04:00
parent 4c12ccc559
commit 984ea4df67
4 changed files with 125 additions and 92 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
game.scm
View file

@ -127,18 +127,13 @@
(define (update-objects!) (define (update-objects!)
(set! *objects* (set! *objects*
;; Filter out the objects that are baked into the background ;; z-sort the list so we render in the correct order. Then
;; and thus do not need to be rendered repeatedly. Then, ;; convert tile positions to vec2s of pixel coordinates for
;; z-sort the list so we render in the correct order. ;; more efficient rendering.
;; Finally, convert positions to vec2s for more efficient
;; rendering.
(map (match-lambda (map (match-lambda
((type #(x y _) . properties) ((type #(x y _) . properties)
(pk 'obj `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties)))) `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties)))
(sort (filter-map (match-lambda (sort ($ (level-actor *level*) 'describe)
(((or 'wall 'exit) . _) #f)
(desc desc))
($ (level-actor *level*) 'describe))
(lambda (a b) (lambda (a b)
(match a (match a
((_ #(_ _ az) . _) ((_ #(_ _ az) . _)
@ -243,14 +238,9 @@
(define (draw-exit pos) (define (draw-exit pos)
(draw-tile context tileset 27 (vec2-x pos) (vec2-y 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)) (let ((x (vec2-x pos))
(y (vec2-y pos))) (y (vec2-y pos)))
(match type
('brick
(draw-tile context tileset 22 x y))
(_
(draw-tile context tileset 2 x y)))
(match type (match type
('electron-head ('electron-head
(draw-tile context tileset 4 x y)) (draw-tile context tileset 4 x y))
@ -258,7 +248,7 @@
(draw-tile context tileset 5 x y)) (draw-tile context tileset 5 x y))
(_ #f)))) (_ #f))))
(define (draw-block type pos) (define (draw-block pos type)
(let ((x (vec2-x pos)) (let ((x (vec2-x pos))
(y (vec2-y pos))) (y (vec2-y pos)))
(match type (match type
@ -287,11 +277,10 @@
(match obj (match obj
(#f #f) (#f #f)
(('player pos) (draw-player pos)) (('player pos) (draw-player pos))
;; Wall and exit tiles are baked into the background layer. (('exit pos) #t) ; drawn via background
(('exit pos) #t) (('wall pos type) (draw-wall pos type))
(('wall pos type) #t) (('block pos type) (draw-block pos type))
(('block pos type) (draw-block type pos)) (('clock-emitter pos) #t) ; drawn via background
(('clock-emitter pos) (draw-clock-emitter pos))
(('floor-switch pos on?) (draw-floor-switch pos on?)) (('floor-switch pos on?) (draw-floor-switch pos on?))
(('gem pos) (draw-gem pos)) (('gem pos) (draw-gem pos))
(('gate pos open?) (draw-gate pos open?)))) (('gate pos open?) (draw-gate pos open?))))

134
modules/game/actors.scm
View file

@ -12,6 +12,15 @@
^player ^player
^level)) ^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) (define* (^cell bcom #:optional val)
(case-lambda (case-lambda
(() val) (() val)
@ -31,8 +40,8 @@
(('enter obj grid-info) #f) (('enter obj grid-info) #f)
(('exit obj grid-info) #f) (('exit obj grid-info) #f)
(('wire-state) #f) (('wire-state) #f)
(('update-wire-state grid-info) #f)
(('alive?) #t) (('alive?) #t)
(('set-wire-state) #f)
(('describe) `(exit ,position)) (('describe) `(exit ,position))
(('collide other offset grid-info) #f))) (('collide other offset grid-info) #f)))
@ -50,8 +59,13 @@
((or 'copper 'electron-head 'electron-tail) ((or 'copper 'electron-head 'electron-tail)
type) type)
(_ #f))) (_ #f)))
(('set-wire-state type) (('update-wire-state grid-info)
(bcom (^wall bcom x y type))) (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) (('alive?) #t)
(('describe) `(wall ,position ,type)) (('describe) `(wall ,position ,type))
(('collide other offset grid-info) #f))) (('collide other offset grid-info) #f)))
@ -71,10 +85,15 @@
((or 'copper 'electron-head 'electron-tail) ((or 'copper 'electron-head 'electron-tail)
type) type)
(_ #f))) (_ #f)))
(('set-wire-state type) (('update-wire-state grid-info)
(match type
((or 'copper 'electron-head 'electron-tail)
(match ($ position) (match ($ position)
(#(x y _) (#(x y z)
(bcom (^block bcom x y type))))) (let* ((neighbors ($ grid-info 'wireworld-neighbor-count x y))
(type (wireworld-next type neighbors)))
(bcom (^block bcom x y type))))))
(_ #f)))
(('alive?) #t) (('alive?) #t)
(('describe) `(block ,($ position) ,type)) (('describe) `(block ,($ position) ,type))
(('collide other offset grid-info) (('collide other offset grid-info)
@ -96,7 +115,7 @@
(('pushed?) ($ pushed?)))) (('pushed?) ($ pushed?))))
(define (^clock-emitter bcom x y interval) (define (^clock-emitter bcom x y interval)
(define timer (spawn ^cell 1)) (define timer (spawn ^cell 0))
(define position (vector x y 0)) (define position (vector x y 0))
(match-lambda* (match-lambda*
(('type) 'emitter) (('type) 'emitter)
@ -113,6 +132,7 @@
'electron-tail) 'electron-tail)
(else (else
'copper)))) 'copper))))
(('update-wire-state grid-info) #f)
(('alive?) #t) (('alive?) #t)
(('set-wire-state type) #f) (('set-wire-state type) #f)
(('describe) `(clock-emitter ,position)) (('describe) `(clock-emitter ,position))
@ -129,17 +149,16 @@
($ on? #t)) ($ on? #t))
(('exit obj grid-info) (('exit obj grid-info)
(when (= (length ($ grid-info 'occupants x y)) 1) (when (= (length ($ grid-info 'occupants x y)) 1)
(pk 'OFF)
($ on? #f) ($ on? #f)
(match ($ grid-info 'occupants target-x target-y) (match ($ grid-info 'occupants target-x target-y)
(() (pk "no switch target!")) (() (pk "no switch target!"))
((target . _) ((target . _)
($ target 'deactivate))))) ($ target 'deactivate)))))
(('wire-state) #f) (('wire-state) #f)
(('update-wire-state grid-info) #f)
(('alive?) #t) (('alive?) #t)
(('describe) `(floor-switch ,position ,($ on?))) (('describe) `(floor-switch ,position ,($ on?)))
(('collide other offset grid-info) (('collide other offset grid-info)
(pk 'ON)
($ on? #t) ($ on? #t)
(match ($ grid-info 'occupants target-x target-y) (match ($ grid-info 'occupants target-x target-y)
(() (pk "no switch target!")) (() (pk "no switch target!"))
@ -156,6 +175,7 @@
(('enter obj grid-info) #f) (('enter obj grid-info) #f)
(('exit obj grid-info) #f) (('exit obj grid-info) #f)
(('wire-state) #f) (('wire-state) #f)
(('update-wire-state grid-info) #f)
(('alive?) (not ($ picked-up?))) (('alive?) (not ($ picked-up?)))
(('describe) `(gem ,position)) (('describe) `(gem ,position))
(('collide other offset grid-info) (('collide other offset grid-info)
@ -174,6 +194,7 @@
(('activate) ($ open? #t)) (('activate) ($ open? #t))
(('deactivate) ($ open? #f)) (('deactivate) ($ open? #f))
(('wire-state) #f) (('wire-state) #f)
(('update-wire-state grid-info) #f)
(('alive?) #t) (('alive?) #t)
(('open?) ($ open?)) (('open?) ($ open?))
(('describe) `(gate ,position ,($ open?))) (('describe) `(gate ,position ,($ open?)))
@ -205,6 +226,7 @@
(('enter obj grid-info) #f) (('enter obj grid-info) #f)
(('exit obj grid-info) #f) (('exit obj grid-info) #f)
(('wire-state) #f) (('wire-state) #f)
(('update-wire-state grid-info) #f)
(('alive?) #t) (('alive?) #t)
(('describe) `(player ,($ position))) (('describe) `(player ,($ position)))
(('collide other offset grid-info) (('collide other offset grid-info)
@ -259,13 +281,60 @@
(vector-set! grid (+ (* y width) x) val)) (vector-set! grid (+ (* y width) x) val))
(define grid (make-grid '())) (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. ;; Read-only access to query the grid.
(define (^grid-info bcom) (define (^grid-info bcom)
(match-lambda* (match-lambda*
(('occupied? x y) (('occupied? x y)
(not (null? ($ (grid-ref grid x y))))) (not (null? ($ (grid-ref grid x y)))))
(('occupants 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 grid-info (spawn ^grid-info))
(define (delq item lst) (define (delq item lst)
@ -318,23 +387,6 @@
(collide other other-pos other-prev-pos))) (collide other other-pos other-prev-pos)))
(lp rest)))))))))))) (lp rest))))))))))))
(define (tick) (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. ;; Tick each object and check for collisions.
($ objects ($ objects
(let lp ((objs ($ objects))) (let lp ((objs ($ objects)))
@ -352,30 +404,10 @@
(cons obj (lp rest)) (cons obj (lp rest))
(lp rest))))))) (lp rest)))))))
;; Advance Wirewold simulation. ;; Advance Wirewold simulation.
(for-each (match-lambda (refresh-wire-grid)
((refr . wire-state) (for-each (lambda (obj)
($ refr 'set-wire-state wire-state))) ($ obj 'update-wire-state grid-info))
(let y-loop ((y 0) (updates '())) ($ objects)))
(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))))
(match-lambda* (match-lambda*
(('tick) (tick)) (('tick) (tick))

41
modules/game/levels/level-3.tmx
View file

@ -1,31 +1,40 @@
<?xml version="1.0" encoding="UTF-8"?> <?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"/> <tileset firstgid="1" source="tiles.tsx"/>
<layer id="1" name="background" width="20" height="15"> <layer id="1" name="background" width="20" height="15">
<data encoding="csv"> <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,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,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,28,24,24,24,24,24,24,24,24,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,3,3,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,49,3,3,3,3,24,3,3,3,3,3,3,24,3,3,3,3,3,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,3,3,24,24,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,24,24,24,24,24,24,24,24,24,24,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,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,24,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,24,24,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,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,23,23,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,23,23,23,23,23,23,23,
23,23,24,24,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,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
</data> </data>
</layer> </layer>
<objectgroup id="2" name="objects"> <objectgroup id="2" name="objects">
<object id="1" type="player-spawn" gid="1" x="128" y="144" 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="96" y="80" width="16" height="16"> <object id="4" type="block" gid="4" x="80" y="128" width="16" height="16">
<properties> <properties>
<property name="kind" value="copper"/> <property name="kind" value="copper"/>
</properties> </properties>
</object> </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> </objectgroup>
</map> </map>

3
scripts/compile-map.scm
View file

@ -601,6 +601,9 @@ the default ORIENTATION value of 'orthogonal' is supported."
(assq-ref properties 'target-y))) (assq-ref properties 'target-y)))
('gem (list x y obj:gem)) ('gem (list x y obj:gem))
('gate (list x y obj:gate)) ('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))))) (_ (error "unsupported object type" type)))))
(object-layer-objects layer)))) (object-layer-objects layer))))