Entity event handling Jorth DSL
This commit is contained in:
parent
4fe42403be
commit
1381c10d93
79
game.jor
79
game.jor
|
@ -35,13 +35,27 @@ REPL start-repl
|
|||
defer tick
|
||||
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.y 3 cells + ;
|
||||
: entity.dir 2 cells + ;
|
||||
: entity>sprite cell + @ 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
|
||||
1 const E
|
||||
2 const N
|
||||
|
@ -91,7 +105,7 @@ array frames
|
|||
|
||||
: triggered ( duration timer -- b )
|
||||
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 ! ;
|
||||
|
||||
|
@ -255,9 +269,6 @@ JOB listen-for-jobs
|
|||
( T I C K )
|
||||
defer entities
|
||||
|
||||
0 const EVTICK
|
||||
1 const EVTOUCH
|
||||
|
||||
: entity-at ( x y -- entity|0 )
|
||||
0 >rot
|
||||
entities each r> 2dup ( 0 x y x y r:e )
|
||||
|
@ -281,6 +292,8 @@ defer player
|
|||
: player.canmove? ( x y -- )
|
||||
player.state DRIVING f@ if DRIVABLE else WALKABLE then mapflag? ;
|
||||
|
||||
12 9 N ' {player} defentity player
|
||||
|
||||
: move-entity ( e -- )
|
||||
dup entity.dir @ dir>pos ( e dx dy )
|
||||
dup if swap drop swap entity.y
|
||||
|
@ -288,32 +301,37 @@ defer player
|
|||
swap 16 * over @ + 4 <rot move-to ;
|
||||
|
||||
: move-player
|
||||
player entity.dir @ dir>pos
|
||||
player entity.x @ player entity.y @ world>tile +pos ( x y )
|
||||
2dup entity-at r> player.canmove? if r< ( entity )
|
||||
( 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 ;
|
||||
0 player.state MOVING f! ;
|
||||
|
||||
: tick-player
|
||||
: 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.x @ player entity.y @ world>tile +pos ( x y )
|
||||
check-player-touch not if move-player then ;
|
||||
|
||||
player :tick
|
||||
0 ^LEFT key-down if drop 1 W 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
|
||||
^DOWN key-down if drop 1 S player entity.dir ! then
|
||||
if ' move-player JOB send then ;
|
||||
|
||||
: think-player
|
||||
EVTICK = if tick-player then ;
|
||||
|
||||
12 9 N ' {player} ' think-player defentity _player
|
||||
' _player ' player redefine
|
||||
if ' try-move-player JOB send then
|
||||
;entity
|
||||
|
||||
( S T U F F )
|
||||
: hello-world
|
||||
|
@ -352,9 +370,16 @@ MODE-MOVE @ ' tick redefine
|
|||
|
||||
( P E T E )
|
||||
|
||||
8 8 E ' {car}
|
||||
:noname EVTOUCH = if pete s" What an old rustbucket." say1 then ;
|
||||
defentity car
|
||||
8 8 E ' {car} 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
|
||||
player yield
|
||||
|
|
Loading…
Reference in a new issue