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

Prepare to support drawing rotated tiles

Browse source
This commit is contained in:
Juliana Sims 2024-05-23 16:36:05 -04:00
parent d68b5d0491
commit 1e91411687
5 changed files with 54 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
game.scm
View file

@ -359,7 +359,7 @@
(define (draw-gate pos open?) (define (draw-gate pos open?)
(draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos))) (draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos)))
(define (draw-logic-gate pos state id) (define (draw-logic-gate pos direction state id)
(let ((x (vec2-x pos)) (let ((x (vec2-x pos))
(y (vec2-y pos))) (y (vec2-y pos)))
(draw-tile context tileset 2 x y) (draw-tile context tileset 2 x y)
@ -386,9 +386,9 @@
(('gem pos) (draw-gem pos)) (('gem pos) (draw-gem pos))
(('ghost-gem pos) (draw-ghost-gem pos)) (('ghost-gem pos) (draw-ghost-gem pos))
(('gate pos open?) (draw-gate pos open?)) (('gate pos open?) (draw-gate pos open?))
(('and-gate pos state) (draw-logic-gate pos state 42)) (('and-gate pos direction state) (draw-logic-gate pos direction state 42))
(('or-gate pos state) (draw-logic-gate pos state 43)) (('or-gate pos direction state) (draw-logic-gate pos direction state 43))
(('xor-gate pos state) (draw-logic-gate pos state 44)) (('xor-gate pos direction state) (draw-logic-gate pos direction state 44))
(('electric-switch pos on?) (draw-electric-switch pos on?)) (('electric-switch pos on?) (draw-electric-switch pos on?))
(('electron-warp pos state) (draw-electron-warp pos state)))) (('electron-warp pos state) (draw-electron-warp pos state))))

39
modules/game/actors.scm
View file

@ -354,7 +354,7 @@
(('describe) `(gate ,position ,($ open?))) (('describe) `(gate ,position ,($ open?)))
(('collide other offset grid-info) #f))) (('collide other offset grid-info) #f)))
(define (^logic-gate bcom x y name update-wire-state) (define (^logic-gate bcom x y name direction update-wire-state)
(define position (vector x y 0)) (define position (vector x y 0))
(define state (spawn ^cell 'copper)) (define state (spawn ^cell 'copper))
(match-lambda* (match-lambda*
@ -372,51 +372,46 @@
('copper ('copper
(update-wire-state state ($ grid-info 'wireworld-neighbor-grid x y))))) (update-wire-state state ($ grid-info 'wireworld-neighbor-grid x y)))))
(('alive?) #t) (('alive?) #t)
(('describe) `(,name ,position ,($ state))) (('describe) `(,name ,position ,direction ,($ state)))
(('collide other offset grid-info) #f))) (('collide other offset grid-info) #f)))
(define direction:right 1)
(define direction:left 2)
(define direction:up 3)
(define direction:down 4)
(define (^and-gate bcom x y direction) (define (^and-gate bcom x y direction)
(define (update-wire-state state neighbor-grid) (define (update-wire-state state neighbor-grid)
(match direction (match direction
(direction:right ('right
(match neighbor-grid (match neighbor-grid
(#('electron-head #f #f (#('electron-head #f #f
#f _ 'copper #f _ 'copper
'electron-head #f #f) 'electron-head #f #f)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:left ('left
(match neighbor-grid (match neighbor-grid
(#(#f #f 'electron-head (#(#f #f 'electron-head
'copper _ #f 'copper _ #f
#f #f 'electron-head) #f #f 'electron-head)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:up ('up
(match neighbor-grid (match neighbor-grid
(#(#f 'copper #f (#(#f 'copper #f
#f _ #f #f _ #f
'electron-head #f 'electron-head) 'electron-head #f 'electron-head)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:down ('down
(match neighbor-grid (match neighbor-grid
(#('electron-head #f 'electron-head (#('electron-head #f 'electron-head
#f _ #f #f _ #f
#f 'copper #f) #f 'copper #f)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))))) (_ ($ state 'copper))))))
(^logic-gate bcom x y 'and-gate update-wire-state)) (^logic-gate bcom x y 'and-gate direction update-wire-state))
(define (^xor-gate bcom x y direction) (define (^xor-gate bcom x y direction)
(define (update-wire-state state neighbor-grid) (define (update-wire-state state neighbor-grid)
(match direction (match direction
(direction:right ('right
(match neighbor-grid (match neighbor-grid
(#('electron-head #f #f (#('electron-head #f #f
#f _ 'copper #f _ 'copper
@ -435,7 +430,7 @@
'electron-head #f #f) 'electron-head #f #f)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:left ('left
(match neighbor-grid (match neighbor-grid
(#(#f #f 'electron-head (#(#f #f 'electron-head
'copper _ #f 'copper _ #f
@ -454,7 +449,7 @@
#f #f 'electron-head) #f #f 'electron-head)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:up ('up
(match neighbor-grid (match neighbor-grid
(#(#f 'copper #f (#(#f 'copper #f
#f _ #f #f _ #f
@ -473,7 +468,7 @@
'copper #f 'electron-head) 'copper #f 'electron-head)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:down ('down
(match neighbor-grid (match neighbor-grid
(#('electron-head #f #f (#('electron-head #f #f
#f _ #f #f _ #f
@ -492,12 +487,12 @@
#f 'copper #f) #f 'copper #f)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))))) (_ ($ state 'copper))))))
(^logic-gate bcom x y 'xor-gate update-wire-state)) (^logic-gate bcom x y 'xor-gate direction update-wire-state))
(define (^or-gate bcom x y direction) (define (^or-gate bcom x y direction)
(define (update-wire-state state neighbor-grid) (define (update-wire-state state neighbor-grid)
(match direction (match direction
(direction:right ('right
(match neighbor-grid (match neighbor-grid
(#('electron-head #f #f (#('electron-head #f #f
#f _ 'copper #f _ 'copper
@ -520,7 +515,7 @@
'electron-head #f #f) 'electron-head #f #f)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:left ('left
(match neighbor-grid (match neighbor-grid
(#(#f #f 'electron-head (#(#f #f 'electron-head
'copper _ #f 'copper _ #f
@ -543,7 +538,7 @@
#f #f 'electron-head) #f #f 'electron-head)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:up ('up
(match neighbor-grid (match neighbor-grid
(#(#f 'copper #f (#(#f 'copper #f
#f _ #f #f _ #f
@ -566,7 +561,7 @@
'electron-head #f 'electron-head) 'electron-head #f 'electron-head)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))) (_ ($ state 'copper))))
(direction:down ('down
(match neighbor-grid (match neighbor-grid
(#('electron-head #f #f (#('electron-head #f #f
#f _ #f #f _ #f
@ -589,7 +584,7 @@
#f 'copper #f) #f 'copper #f)
($ state 'electron-head)) ($ state 'electron-head))
(_ ($ state 'copper)))))) (_ ($ state 'copper))))))
(^logic-gate bcom x y 'or-gate update-wire-state)) (^logic-gate bcom x y 'or-gate direction update-wire-state))
(define (^player bcom x y) (define (^player bcom x y)
(define position (spawn ^cell (vector x y 2))) (define position (spawn ^cell (vector x y 2)))

17
modules/game/level.scm
View file

@ -39,7 +39,13 @@
(define (make-level width height background objects collected-gem?) (define (make-level width height background objects collected-gem?)
(let ((level* (spawn ^level width height)) (let ((level* (spawn ^level width height))
(background* (make-vector (* width height)))) (background* (make-vector (* width height)))
(direction->symbol
(match-lambda
(1 'right)
(2 'left)
(3 'up)
(4 'down))))
;; Unpack background tile data. ;; Unpack background tile data.
(let y-loop ((y 0)) (let y-loop ((y 0))
(when (< y height) (when (< y height)
@ -76,17 +82,20 @@
(spawn ^gem x y))) (spawn ^gem x y)))
(10 (spawn ^gate x y)) (10 (spawn ^gate x y))
(11 (spawn ^and-gate x y (11 (spawn ^and-gate x y
(bytevector-u8-ref objects (+ i 3)))) (direction->symbol
(bytevector-u8-ref objects (+ i 3)))))
(12 (let ((target-x (bytevector-u8-ref objects (+ i 3))) (12 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
(target-y (bytevector-u8-ref objects (+ i 4)))) (target-y (bytevector-u8-ref objects (+ i 4))))
(spawn ^electric-switch x y target-x target-y))) (spawn ^electric-switch x y target-x target-y)))
(13 (spawn ^xor-gate x y (13 (spawn ^xor-gate x y
(bytevector-u8-ref objects (+ i 3)))) (direction->symbol
(bytevector-u8-ref objects (+ i 3)))))
(14 (let ((target-x (bytevector-u8-ref objects (+ i 3))) (14 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
(target-y (bytevector-u8-ref objects (+ i 4)))) (target-y (bytevector-u8-ref objects (+ i 4))))
(spawn ^electron-warp x y target-x target-y))) (spawn ^electron-warp x y target-x target-y)))
(15 (spawn ^or-gate x y (15 (spawn ^or-gate x y
(bytevector-u8-ref objects (+ i 3)))) (direction->symbol
(bytevector-u8-ref objects (+ i 3)))))
(16 (spawn ^switched-emitter x y (16 (spawn ^switched-emitter x y
(bytevector-u8-ref objects (+ i 3)))) (bytevector-u8-ref objects (+ i 3))))
(id (error "invalid level object" id)))) (id (error "invalid level object" id))))

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

@ -1,5 +1,5 @@
<?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="24"> <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="27">
<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">
@ -70,5 +70,20 @@
<property name="interval" type="int" value="4"/> <property name="interval" type="int" value="4"/>
</properties> </properties>
</object> </object>
<object id="24" gid="43" x="128" y="176" width="16" height="16">
<properties>
<property name="direction" value="left"/>
</properties>
</object>
<object id="25" gid="44" x="144" y="176" width="16" height="16">
<properties>
<property name="direction" value="up"/>
</properties>
</object>
<object id="26" gid="45" x="160" y="176" width="16" height="16">
<properties>
<property name="direction" value="down"/>
</properties>
</object>
</objectgroup> </objectgroup>
</map> </map>

13
scripts/compile-map.scm
View file

@ -564,11 +564,6 @@ the default ORIENTATION value of 'orthogonal' is supported."
(define obj:or-gate 15) (define obj:or-gate 15)
(define obj:switched-emitter 16) (define obj:switched-emitter 16)
(define direction:right 1)
(define direction:left 2)
(define direction:up 3)
(define direction:down 4)
(define (compile-environment-layer tile-map layer-name) (define (compile-environment-layer tile-map layer-name)
(let ((tw (tile-map-tile-width tile-map)) (let ((tw (tile-map-tile-width tile-map))
(th (tile-map-tile-height tile-map)) (th (tile-map-tile-height tile-map))
@ -595,10 +590,10 @@ the default ORIENTATION value of 'orthogonal' is supported."
(define (compile-object-layer tile-map layer-name) (define (compile-object-layer tile-map layer-name)
(define parse-direction (define parse-direction
(match-lambda (match-lambda
("right" direction:right) ("right" 1)
("left" direction:left) ("left" 2)
("up" direction:up) ("up" 3)
("down" direction:down))) ("down" 4)))
(let ((tw (tile-map-tile-width tile-map)) (let ((tw (tile-map-tile-width tile-map))
(th (tile-map-tile-height tile-map)) (th (tile-map-tile-height tile-map))
(layer (tile-map-layer-ref tile-map layer-name))) (layer (tile-map-layer-ref tile-map layer-name)))