DSL for level-based player touch event handling

defs.jor

@@ -15,6 +15,7 @@
   <rot if r< | else r< ~ & then ( v newval )
   swap ! ;
 : f@ ( v flag -- ) swap @ & ;
+: fnot! 2dup f@ not f! ;
 
 : expile state if , else execute then ;
 
@@ -53,6 +54,18 @@
 
 : links begin yield @ dup not until ;
 
+( usage:
+  : search-xy { x y -- b r: coroutine } begin 2dup search >rot drop drop ;
+  : test-xy { x y -- b }
+    search-xy 1 2 2= yield 3 4 2= yield drop drop 999 yield ;
+  test-xy will return 1 if x y is 1 2 or 3 4, otherwise it returns 999.
+  Note that it must always end with a yield, as search has no way to tell
+  the difference between an early termination and a final non-zero result.
+)
+: search
+  ' yield , ' dup , ' not , [ ' while , ] ' drop , [ ' repeat , ]
+  ' rdrop , ; immediate
+
 : min ( x y -- x|y ) 2dup > if swap then drop ;
 : max ( x y -- x|y ) 2dup < if swap then drop ;
 

footer.jor

@@ -33,16 +33,16 @@ var textx
 var texty
 2 const textspeed
 
-: nltext 7 textx ! 10 texty +! ;
+: nltext 6 textx ! 10 texty +! ;
 : inctextx
   textx @ 1 + dup 38 <= if textx !
-  else drop nltext then ;
+  else drop nltext inctextx then ;
 
 key \ const '\'
 : statusc
   dup dup '\' = swap '\n' = or if drop nltext
   else dup '\r' = if drop
-  else textx @ texty @ <rot text-color @ textc inctextx then then ;
+  else inctextx textx @ texty @ <rot text-color @ textc then then ;
 
 var texttimer
 : textnextc ( s -- s )
@@ -59,7 +59,7 @@ var texttimer
   WHITE text-color !
   s"                                 " dup dup status0 status1 status2
   text-color !
-  7 textx !
+  6 textx !
   10 texty ! ;
 
 : show-footer 48 10 footer-y move-to ;

game.jor

@@ -70,19 +70,26 @@ defer player
 
 defer player-touch ( x y -- b )
 
+: touch-begin begin 2dup search >rot drop drop 1 - ;
+: touched? if 2 else 1 then ;
+: touched-more? if 2 else 0 then ;
+: touch-next ' touched-more? , ' yield , ; immediate
+: touch-last ' touched? , ' yield , ; immediate
+: ;touch [ ' touch-last , ' [ , ] ; immediate
+
 : check-player-touch ( x y -- b )
-  2dup entity-at dup if EVTOUCH entity>do drop drop 1 else drop
+  touch-begin entity-at dup if EVTOUCH entity>do 1 then
-  2dup player-touch if drop drop 1 else
+  touch-next player-touch
-  2dup out-of-bounds if drop drop 1 else
+  touch-next out-of-bounds
-  player.canmove? if 0 else 1 then then then then ;
+  touch-next player.canmove? not ;touch
 
 : try-move-player
   player entity-dst check-player-touch not if move-player then ;
 
-: check-entity-touch ( x y -- b )
+: check-entity-touch
-  2dup entity-at if drop drop 1 else
+  touch-begin entity-at
-  2dup out-of-bounds if 1 else
+  touch-next out-of-bounds
-  WALKABLE mapflag? if 0 else 1 then then then ;
+  touch-next WALKABLE mapflag? ;touch
 
 : try-move-entity ( e -- )
   dup entity-dst check-entity-touch not if move-entity then ;
@@ -100,7 +107,7 @@ player :tick
 
 ( S T U F F )
 : hello-world
-  player.state DRIVING f@ not player.state DRIVING f! ;
+  player.state DRIVING fnot! ;
 
 : mode-move
   entities each EVTICK entity>do more

pete.jor

@@ -12,15 +12,13 @@ car :touch
      player.driving? not if car yield then
      0 |; ' entities redefine
 
-  ( TODO: DSL for touch events? )
+ :| touch-begin S leaving? player.driving? not and dup if
- :| 2dup S leaving? player.driving? not and if
+       pete say" It's too far to walk to town."	then
-       pete say" It's too far to walk to town."	1 else
+    touch-next 12 7 2= dup if
-     2dup 12 7 2= if
+      player.driving? not if
-       player.driving? not if
+	petehous.jor queue-level
-	 petehous.jor queue-level
+      then then
-       then 1
+    touch-last |; ' player-touch redefine
-     else 0 then then >rot drop drop
-  |; ' player-touch redefine
   s" pete.map" load-map
 ; ' onload redefine
 

petehous.jor

@@ -3,11 +3,19 @@
 :noname
   reset-level
   16 9 tile>world player entity.pos!
-  :| 16 10 2= if
+  :|
-     12 8 tile>world player entity.pos!
+touch-begin 16 10 2= dup if
-     pete.jor queue-level
+  12 8 tile>world player entity.pos!
-     1 else 0 then
+  pete.jor queue-level
-  |; ' player-touch redefine
+then touch-next 9 4 2= dup if
+  pete say" The closet is a disaster.\I don't want to deal with that\right now."
+then touch-next 11 4 2= dup if
+  pete say" I'm already dressed."
+then touch-next 16 3 2= dup if
+  pete say" The sink's full of nasty dishes.\I'm not touching them."
+then touch-next 18 3 2= dup if
+  pete say" Should get some more beer soon."
+then touch-last |; ' player-touch redefine
 
   s" petehous.map" load-map
 ; ' onload redefine