Prepare to support drawing rotated tiles
This commit is contained in:
parent
d68b5d0491
commit
1e91411687
5 changed files with 54 additions and 40 deletions
8
game.scm
8
game.scm
|
@ -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))))
|
||||||
|
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
Loading…
Add table
Reference in a new issue