Entity event handling Jorth DSL

This commit is contained in:
Jeremy Penner 2019-03-02 20:03:34 -05:00
parent 4fe42403be
commit 1381c10d93

View file

@ -35,13 +35,27 @@ REPL start-repl
defer tick defer tick
defer draw defer draw
: defentity ( x y dir anim do -- ) array , , , 4 << , 4 << , ; 0 const EVTICK
1 const EVTOUCH
: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ;
: entity.x 4 cells + ; : entity.x 4 cells + ;
: entity.y 3 cells + ; : entity.y 3 cells + ;
: entity.dir 2 cells + ; : entity.dir 2 cells + ;
: entity>sprite cell + @ execute ; : entity>sprite cell + @ execute ;
: entity>do ( entity event ) swap @ execute ; : entity>do ( entity event ) swap @ execute ;
var entity-defstate
: entitydo-ev ( [cp ifhere] ev -- )
entity-defstate @ if swap [ ' then , ]
else 1 entity-defstate ! :noname swap then
' dup , lit ' = , [ ' if , ] ;
: :touch EVTOUCH entitydo-ev ; immediate
: :tick EVTICK entitydo-ev ; immediate
: ;entity ( entity cp ifhere -- )
[ ' then , ] ' drop , [ ' ; , ]
0 entity-defstate ! swap ! ; immediate
0 const W 0 const W
1 const E 1 const E
2 const N 2 const N
@ -91,7 +105,7 @@ array frames
: triggered ( duration timer -- b ) : triggered ( duration timer -- b )
dup r> @ ticks udelta ( duration delta ) dup r> @ ticks udelta ( duration delta )
2dup <= if drop r< +! 1 else drop drop 0 then ; 2dup <= if drop r< +! 1 else drop drop rdrop 0 then ;
: now! ( timer -- ) ticks swap ! ; : now! ( timer -- ) ticks swap ! ;
@ -255,9 +269,6 @@ JOB listen-for-jobs
( T I C K ) ( T I C K )
defer entities defer entities
0 const EVTICK
1 const EVTOUCH
: entity-at ( x y -- entity|0 ) : entity-at ( x y -- entity|0 )
0 >rot 0 >rot
entities each r> 2dup ( 0 x y x y r:e ) entities each r> 2dup ( 0 x y x y r:e )
@ -281,6 +292,8 @@ defer player
: player.canmove? ( x y -- ) : player.canmove? ( x y -- )
player.state DRIVING f@ if DRIVABLE else WALKABLE then mapflag? ; player.state DRIVING f@ if DRIVABLE else WALKABLE then mapflag? ;
12 9 N ' {player} defentity player
: move-entity ( e -- ) : move-entity ( e -- )
dup entity.dir @ dir>pos ( e dx dy ) dup entity.dir @ dir>pos ( e dx dy )
dup if swap drop swap entity.y dup if swap drop swap entity.y
@ -288,32 +301,37 @@ defer player
swap 16 * over @ + 4 <rot move-to ; swap 16 * over @ + 4 <rot move-to ;
: move-player : move-player
1 player.state MOVING f!
player move-entity
0 player.state MOVING f! ;
: out-of-bounds ( x y -- b )
2dup 0 < swap 0 < or >rot mapsize ( b x y w h )
<rot <= >rot ( b b x w )
>= or or ;
: no-touch drop drop 0 ;
defer player-touch ( x y -- b )
' no-touch ' player-touch redefine
: check-player-touch ( x y -- b )
2dup entity-at dup if EVTOUCH entity>do drop drop 1 else drop
2dup player-touch if drop drop 1 else
2dup out-of-bounds if drop drop 1 else
player.canmove? if 0 else 1 then then then then ;
: try-move-player
player entity.dir @ dir>pos player entity.dir @ dir>pos
player entity.x @ player entity.y @ world>tile +pos ( x y ) player entity.x @ player entity.y @ world>tile +pos ( x y )
2dup entity-at r> player.canmove? if r< ( entity ) check-player-touch not if move-player then ;
( touch entity if exists )
dup if
EVTOUCH entity>do
else drop
( move the player )
1 player.state MOVING f!
player move-entity
0 player.state MOVING f!
then
else rdrop then ;
: tick-player player :tick
0 ^LEFT key-down if drop 1 W player entity.dir ! then 0 ^LEFT key-down if drop 1 W player entity.dir ! then
^RIGHT key-down if drop 1 E player entity.dir ! then ^RIGHT key-down if drop 1 E player entity.dir ! then
^UP key-down if drop 1 N player entity.dir ! then ^UP key-down if drop 1 N player entity.dir ! then
^DOWN key-down if drop 1 S player entity.dir ! then ^DOWN key-down if drop 1 S player entity.dir ! then
if ' move-player JOB send then ; if ' try-move-player JOB send then
;entity
: think-player
EVTICK = if tick-player then ;
12 9 N ' {player} ' think-player defentity _player
' _player ' player redefine
( S T U F F ) ( S T U F F )
: hello-world : hello-world
@ -352,9 +370,16 @@ MODE-MOVE @ ' tick redefine
( P E T E ) ( P E T E )
8 8 E ' {car} 8 8 E ' {car} defentity car
:noname EVTOUCH = if pete s" What an old rustbucket." say1 then ;
defentity car var cartimer
cartimer now!
car :tick 60 cartimer triggered if
:| car entity.dir @ E = if W else E then car entity.dir !
car move-entity |; JOB send
then
:touch pete s" What an old rustbucket." say1
;entity
:noname :noname
player yield player yield