From 1381c10d9379c488cfe5728d76da3a0e1d2a6f34 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sat, 2 Mar 2019 20:03:34 -0500 Subject: [PATCH] Entity event handling Jorth DSL --- game.jor | 79 +++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 52 insertions(+), 27 deletions(-) diff --git a/game.jor b/game.jor index 4a68fe5..bd1e3c2 100755 --- a/game.jor +++ b/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 mapsize ( b x y w h ) + 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 ) - 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 ; + check-player-touch not if move-player then ; -: tick-player +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