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 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
|
||||||
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!
|
1 player.state MOVING f!
|
||||||
player move-entity
|
player move-entity
|
||||||
0 player.state MOVING f!
|
0 player.state MOVING f! ;
|
||||||
then
|
|
||||||
else rdrop then ;
|
|
||||||
|
|
||||||
: 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
|
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
|
||||||
|
|
Loading…
Reference in a new issue