dynamic entity list, entity-based touch events, Jorth coroutine jump

defs.jor

@@ -8,15 +8,25 @@ s" jorth.log" open seekend deactivate const LOGFILE
 : 3dup r> 2dup r@ >rot r< ;
 : 4dup r> r> 2dup r@ >rot rswap r@ >rot r< r< swap ;
 
+: 2= ( a b c d -- a=c&b=d )
+  r> <rot = swap r< = and ;
+
 : noop ;
 
+: ~ -1 ^ ;
+: f! ( b v flag -- )
+  r> dup @ ( b v val r: flag )
+  <rot if r< | else r< ~ & then ( v newval )
+  swap ! ;
+: f@ ( v flag -- ) swap @ & ;
+
 ' cells @ const $DOCOLON ( get the colon execution token )
 : :noname here $DOCOLON , ] ;
 
 : :| inline| $DOCOLON , ; immediate
 : |; ' ret , |inline ; immediate
 
-: defer word new-word $DOCOLON , ' noop , ' ret , ;
+: defer word new-word $DODEFERRED , ' noop , ;
 : redefine ( cp cpdeferred ) cell + ! ;
 
 : array word new-word $DOVAR , ;
@@ -37,6 +47,13 @@ s" jorth.log" open seekend deactivate const LOGFILE
        ' dup , ' r@ , ' = , ' BZ_ , ,
        ' rdrop , ' drop , ; immediate
 
+: yield rswap ;
+: each [ ' begin , ] ' dup , [ ' while , ] ; immediate
+: more ' yield , [ ' repeat , ] ' drop , ] ; immediate
+: dobreak yield 0 ;
+: break ' rdrop , ' dobreak , ; immediate
+
+
 : min ( x y -- x|y ) 2dup > if swap then drop ;
 : max ( x y -- x|y ) 2dup < if swap then drop ;
 

game.jor

@@ -35,11 +35,12 @@ REPL start-repl
 defer tick
 defer draw
 
-: defentity ( x y dir anim -- ) array , , , , ;
+: defentity ( x y dir anim do -- ) array , , , 4 << , 4 << , ;
-: entity.x 3 cells + ;
+: entity.x 4 cells + ;
-: entity.y 2 cells + ;
+: entity.y 3 cells + ;
-: entity.dir cell + ;
+: entity.dir 2 cells + ;
-: entity.anim ;
+: entity>sprite cell + @ execute ;
+: entity>do ( entity event ) swap @ execute ;
 
 0 const W
 1 const E
@@ -55,8 +56,8 @@ defer draw
 : frame ( s n e w ) b, b, b, b, ;
 array frames
 ( 0: car ) 3 1 0 2 frame
-( 1: pete stand ) 5 7 7 5 frame
+( 1: pete stand ) 11 9 7 5 frame
-( 2: pete walk ) 6 8 8 6 frame
+( 2: pete walk ) 12 10 8 6 frame
 
 : sprindex ( dir frame ) 2 << frames + + b@ ;
 : defstatic ( frame -- ) create b, does> b@ sprindex ;
@@ -71,24 +72,6 @@ array frames
 1 defstatic {pete-stand}
 1 2 2 5 defanim {pete-walk}
 
-: ~ -1 ^ ;
-var player.state
-: f! ( b v flag -- )
-  r> dup @ ( b v val r: flag )
-  <rot if r< | else r< ~ & then ( v newval )
-  swap ! ;
-: f@ ( v flag -- ) swap @ & ;
-
-1 const MOVING
-2 const DRIVING
-
-: {player}
-  player.state DRIVING f@ if {car}
-  else player.state MOVING f@ if {pete-walk}
-  else {pete-stand} then then ;
-
-128 128 N ' {player} defentity player
-
 ( timer + lerping )
 : clamp0 ( range val -- i )
   2dup  <= if drop else
@@ -181,6 +164,7 @@ var prevbutton
   mousebuttons prevbutton ! ;
 
 1 const MOUSEL
+2 const MOUSER
 : mousedown ( button -- bool ) mousebuttons & ;
 : clicked ( button -- bool )
   dup mousedown not swap
@@ -224,7 +208,8 @@ array tileflags
   dup MAXTILE > if drop 0 then
   tileselect !
 
-  MOUSEL mousedown if tileselect @ mousetile tile b! then ;
+  MOUSEL mousedown if tileselect @ mousetile tile b! then
+  MOUSER clicked if mouseworldpos world>tile swap . . then ;
 
 : copy-mapseg ( neww oldw y -- )
   r> ( oldw neww r: y )
@@ -268,19 +253,54 @@ task const JOB
 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 )
+    r@ entity.x @ r@ entity.y @ world>tile 2= ( 0 x y eq r:e )
+    if <rot drop r< >rot break ( e x y )
+    else rdrop then ( 0 x y )
+  more drop drop ;
+
+( P L A Y E R )
+var player.state
+defer player
+
+1 const MOVING
+2 const DRIVING
+
+: {player}
+  player.state DRIVING f@ if {car}
+  else player.state MOVING f@ if {pete-walk}
+  else {pete-stand} then then ;
+
 : player.canmove? ( x y -- )
   player.state DRIVING f@ if DRIVABLE else WALKABLE then mapflag? ;
 
+: move-entity ( e -- )
+  dup entity.dir @ dir>pos ( e dx dy )
+  dup if swap drop swap entity.y
+      else drop swap entity.x then
+  swap 16 * over @ + 4 <rot move-to ;
+
 : move-player
   player entity.dir @ dir>pos
-  2dup player entity.x @ player entity.y @ world>tile +pos
+  player entity.x @ player entity.y @ world>tile +pos ( x y )
-  player.canmove? if
+  2dup entity-at r> player.canmove? if r< ( entity )
-    1 player.state MOVING f!
+    ( touch entity if exists )
-    dup if swap drop player entity.y ( d v -- )
+    dup if
-      else drop player entity.x then
+      EVTOUCH entity>do
-    swap 16 * over @ + 4 <rot move-to
+    else drop
-    0 player.state MOVING f!
+      ( move the player )
-  else drop drop then ;
+      1 player.state MOVING f!
+      player move-entity
+      0 player.state MOVING f!
+    then
+  else rdrop then ;
 
 : tick-player
   0 ^LEFT key-down if drop 1 W player entity.dir ! then
@@ -289,13 +309,20 @@ JOB listen-for-jobs
   ^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
+
+( S T U F F )
 : hello-world
   s" Hello, world!" say1
   s" How are you" s" today?" say2
   player.state DRIVING f@ not player.state DRIVING f! ;
 
 : mode-move
-  tick-player
+  entities each EVTICK entity>do more
   tick-mapedit
   ^SPACE key-pressed if
     ' hello-world JOB send
@@ -307,7 +334,7 @@ JOB listen-for-jobs
 
 : draw-entity
   r> r@ entity.x @ r@ entity.y @
-  r@ entity.dir @ r< entity.anim @ execute
+  r@ entity.dir @ r< entity>sprite
   draw-sprite ;
 
 : full-draw
@@ -315,7 +342,7 @@ JOB listen-for-jobs
   player entity.y @ 92 -
   scroll
 
-  player draw-entity
+  entities each draw-entity more
   mouseworldpos 4 draw-sprite
   draw-screen
   draw-footer ;
@@ -323,4 +350,16 @@ JOB listen-for-jobs
 MODE-MOVE @ ' tick redefine
 ' full-draw ' draw redefine
 
+( P E T E )
+
+8 8 E ' {car}
+:noname EVTOUCH = if pete s" What an old rustbucket." say1 then ;
+defentity car
+
+:noname
+  player yield
+  car yield
+  0 ;
+' entities redefine
+
 s" pete.map" load-map

jorth.c

@@ -460,8 +460,12 @@ void f_docolon() {
   f_colonloop();
 }
 
+void f_dodeferred() {
+  W = *(W.p + 1);
+  f_colondispatch();
+}
+
 // this version of f_execute can be run from a colon word
-// (though not currently from the interpreter?)
 void f_execute() {
   W = TOP();
   DROP(1);
@@ -954,6 +958,7 @@ void f_init() {
   CDEF("task-user-size", f_taskusersize);
   PCONST("$DOCREATE", f_docreate);
   PCONST("$DOVAR", f_dovar);
+  PCONST("$DODEFERRED", f_dodeferred);
 
   PUSHS("boot.jor");
   f_open();