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

Add gems and the start of floor switches.

Browse source
This commit is contained in:
David Thompson 2024-05-21 14:10:57 -04:00
parent 5fb33112d8
commit ba7b9ea9d8
5 changed files with 142 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

108
modules/game/actors.scm
View file

@ -6,6 +6,8 @@
^wall
^block
^clock-emitter
^floor-switch
^gem
^player
^level))
@ -24,8 +26,11 @@
(match-lambda*
(('type) 'exit)
(('position) position)
(('tick) #f)
(('tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state) #f)
(('alive?) #t)
(('set-wire-state) #f)
(('describe) `(exit ,position))
(('collide other offset grid-info) #f)))
@ -36,7 +41,9 @@
(match-lambda*
(('type) 'wall)
(('position) position)
(('tick) #f)
(('tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state)
(match type
((or 'copper 'electron-head 'electron-tail)
@ -44,6 +51,7 @@
(_ #f)))
(('set-wire-state type)
(bcom (^wall bcom x y type)))
(('alive?) #t)
(('describe) `(wall ,position ,type))
(('collide other offset grid-info) #f)))
@ -54,7 +62,9 @@
(match-lambda*
(('type) 'block)
(('position) ($ position))
(('tick) ($ pushed? #f))
(('tick grid-info) ($ pushed? #f))
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state)
(match type
((or 'copper 'electron-head 'electron-tail)
@ -64,6 +74,7 @@
(match ($ position)
(#(x y)
(bcom (^block bcom x y type)))))
(('alive?) #t)
(('describe) `(block ,($ position) ,type))
(('collide other offset grid-info)
(match ($ position)
@ -83,7 +94,9 @@
(match-lambda*
(('type) 'emitter)
(('position) position)
(('tick) ($ timer (+ ($ timer) 1)))
(('tick grid-info) ($ timer (+ ($ timer) 1)))
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state)
(let ((t ($ timer)))
(cond
@ -93,10 +106,47 @@
'electron-tail)
(else
'copper))))
(('alive?) #t)
(('set-wire-state type) #f)
(('describe) `(clock-emitter ,position))
(('collide other offset grid-info) #f)))
(define (^floor-switch bcom x y)
(define position (vector x y))
(define on? (spawn ^cell))
(match-lambda*
(('type) 'switch)
(('position) position)
(('tick grid-info) #f)
(('enter obj grid-info)
($ on? #t))
(('exit obj grid-info)
(when (= (length ($ grid-info 'occupants x y)) 1)
(pk 'OFF)
($ on? #f)))
(('wire-state) #f)
(('alive?) #t)
(('describe) `(floor-switch ,position ,($ on?)))
(('collide other offset grid-info)
(pk 'ON)
($ on? #t))))
(define (^gem bcom x y)
(define position (vector x y))
(define picked-up? (spawn ^cell))
(match-lambda*
(('type) 'gem)
(('position) position)
(('tick grid-info) #f)
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state) #f)
(('alive?) (not ($ picked-up?)))
(('describe) `(gem ,position))
(('collide other offset grid-info)
(when (eq? ($ other 'type) 'player)
($ picked-up? #t)))))
(define (^player bcom x y)
(define position (spawn ^cell (vector x y)))
(define velocity (spawn ^cell #(0 0)))
@ -112,7 +162,7 @@
('up #(0 -1))
('down #(0 1))
(_ (error "invalid direction" dir)))))
(('tick)
(('tick grid-info)
($ event #f)
(match ($ position)
(#(x y)
@ -120,7 +170,10 @@
(#(dx dy)
($ position (vector (+ x dx) (+ y dy)))
($ velocity #(0 0)))))))
(('enter obj grid-info) #f)
(('exit obj grid-info) #f)
(('wire-state) #f)
(('alive?) #t)
(('describe) `(player ,($ position)))
(('collide other offset grid-info)
(define (reverse-move)
@ -137,6 +190,8 @@
(begin
(reverse-move)
($ event '(bump)))))
('switch ($ event '(switch)))
('gem ($ event '(gem)))
(_
(reverse-move)
($ event '(bump)))))
@ -172,7 +227,9 @@
(define (^grid-info bcom)
(match-lambda*
(('occupied? x y)
(not (null? ($ (grid-ref grid x y)))))))
(not (null? ($ (grid-ref grid x y)))))
(('occupants x y)
($ (grid-ref grid x y)))))
(define grid-info (spawn ^grid-info))
(define (delq item lst)
@ -187,12 +244,20 @@
(unless (equal? prev-pos resolved-pos)
(match prev-pos
(#(x y)
(let ((cell (grid-ref grid x y)))
($ cell (delq obj ($ cell))))))
(let* ((cell (grid-ref grid x y))
(remaining (delq obj ($ cell))))
($ cell remaining)
(for-each (lambda (other)
($ other 'exit obj grid-info))
remaining))))
(match resolved-pos
(#(x y)
(let ((cell (grid-ref grid x y)))
($ cell (cons obj ($ cell))))))))
(let* ((cell (grid-ref grid x y))
(occupants ($ cell)))
($ cell (cons obj occupants))
(for-each (lambda (other)
($ other 'enter obj grid-info))
occupants))))))
(define (collide obj pos prev-pos)
(match pos
(#(x y)
@ -230,14 +295,21 @@
(check (- x 1) (+ y 1))
(check (- x 1) y)))
;; Tick each object and check for collisions.
(for-each (lambda (obj)
(let ((prev-pos ($ obj 'position)))
($ obj 'tick)
;; Only check collisions for movable objects.
(let ((desired-pos ($ obj 'position)))
(unless (equal? prev-pos desired-pos)
(collide obj desired-pos prev-pos)))))
($ objects))
($ objects
(let lp ((objs ($ objects)))
(match objs
(() '())
((obj . rest)
(let ((prev-pos ($ obj 'position)))
($ obj 'tick grid-info)
;; Only check collisions for movable objects.
(let ((desired-pos ($ obj 'position)))
(unless (equal? prev-pos desired-pos)
(collide obj desired-pos prev-pos)))
;; Cull dead objects.
(if ($ obj 'alive?)
(cons obj (lp rest))
(lp rest)))))))
;; Advance Wirewold simulation.
(for-each (match-lambda
((refr . wire-state)

9
modules/game/level.scm
View file

@ -19,7 +19,7 @@
(actor level-actor)
(player level-player))
(define (make-level width height background objects)
(define (make-level width height background objects spawn-gem?)
(let ((level* (spawn ^level width height))
(len (bytevector-length objects)))
;; Parsed packed object data and spawn objects, making special
@ -37,9 +37,12 @@
(5 (spawn ^block x y 'copper))
(6 (spawn ^block x y 'crate))
(7 (spawn ^clock-emitter x y 4))
(8 (spawn ^floor-switch x y))
(9 (and spawn-gem? (spawn ^gem x y)))
(id (error "invalid level object" id)))))
($ level* 'add-object obj)
(if (= id 3) ; player-spawn
(when obj
($ level* 'add-object obj))
(if (= id 3) ; player-spawn
(lp (+ i 3) obj)
(lp (+ i 3) player)))
(%make-level background level* player)))))

4
modules/game/levels/level-1.tmx
View file

@ -1,5 +1,5 @@
<?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="6">
<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="8">
<tileset firstgid="1" source="tiles.tsx"/>
<layer id="1" name="background" width="20" height="15">
<data encoding="csv">
@ -22,5 +22,7 @@
</layer>
<objectgroup id="2" name="objects">
<object id="1" type="player-spawn" gid="1" x="96" y="112" width="16" height="16"/>
<object id="6" type="floor-switch" gid="25" x="128" y="112" width="16" height="16"/>
<object id="7" type="gem" gid="29" x="32" y="112" width="16" height="16"/>
</objectgroup>
</map>