Entity event handling Jorth DSL

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
+  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.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