add pete's house interior; implement memory checkpointing / rollback

defs.jor

@@ -56,6 +56,15 @@
 : min ( x y -- x|y ) 2dup > if swap then drop ;
 : max ( x y -- x|y ) 2dup < if swap then drop ;
 
+: checkpoint ( cp -- )
+  create here 4 cells + , latest , tasks , ,
+  does> dup @ here!
+	dup cell + @ latest!
+	dup 2 cells + @ tasks!
+	3 cells + @ execute ;
+
+: intern create latest wordname , does> @ ;
+
 : decompile
   word lookup if 1 begin ( cp i )
     2dup cells + @ ( cp i @cp+i )

entity.jor

@@ -1,7 +1,10 @@
 0 const EVTICK
 1 const EVTOUCH
 
-: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ;
+: world>tile 4 >> swap 4 >> swap ;
+: tile>world 4 << swap 4 << swap ;
+
+: defentity ( x y dir anim -- ) array ' drop , , , tile>world , , ;
 : entity.x 4 cells + ;
 : entity.y 3 cells + ;
 : entity.dir 2 cells + ;

game.jor

@@ -15,7 +15,6 @@ JOB listen-for-jobs
 
 ( T I C K )
 defer entities
-:noname 0 ; ' entities redefine
 
 : entity-at ( x y -- entity|0 )
   0 >rot
@@ -69,9 +68,7 @@ defer player
   S = if swap drop mapsize swap drop >= else
   drop mapsize drop >= then then then ;
 
-: 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
@@ -90,6 +87,9 @@ defer player-touch ( x y -- b )
 : try-move-entity ( e -- )
   dup entity-dst check-entity-touch not if move-entity then ;
 
+var queued-level
+: queue-level queued-level ! ;
+
 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
@@ -108,7 +108,11 @@ player :tick
   ^SPACE key-pressed if
     ' hello-world JOB send
   then
-  tick-debounce ;
+  tick-debounce
+  queued-level @ dup if
+    0 queue-level
+    loadlevel
+  else drop then ;
 
 ' mode-move MODE-MOVE !
 ' tick-debounce MODE-WAIT !
@@ -128,7 +132,12 @@ player :tick
   draw-screen
   draw-footer ;
 
+: reset-level
+  :| player yield 0 |; ' entities redefine
+  :| drop drop 0 |; ' player-touch redefine ;
+
 :noname
-MODE-MOVE @ ' tick redefine
+  reset-level
-' full-draw ' draw redefine
+  MODE-MOVE @ ' tick redefine
+  ' full-draw ' draw redefine
 ; ' onload redefine

gameboot.jor

@@ -9,6 +9,7 @@ REPL start-repl
 
 defer tick
 defer draw
+defer loadlevel
 
 :noname
 s" input.jor" loadfile
@@ -17,6 +18,12 @@ s" timer.jor" loadfile
 s" footer.jor" loadfile
 s" map.jor" loadfile
 s" game.jor" loadfile
+; execute
 
-s" pete.jor" loadfile
+intern pete.jor
-; ' onload redefine
+intern petehous.jor
+
+:noname loadfile ; checkpoint _loadlevel
+' _loadlevel ' loadlevel redefine
+
+pete.jor loadlevel

jorth.c

@@ -1,3 +1,5 @@
+#define TRACE
+
 #include <stdio.h>
 #include <sys/stat.h>
 #include "jorth.h"
@@ -29,6 +31,9 @@ cell *RUNNING = (cell*)mem;
 cell *TASKS = (cell*)mem;
 cell *stack = ((cell*)mem) + STACK_OFFSET;
 cell *rstack = ((cell*)mem) + RSTACK_OFFSET;
+#ifdef TRACE
+int TRACING = 0;
+#endif
 
 #define QUIET (*(RUNNING + TASK_USER_QUIET))
 
@@ -432,6 +437,7 @@ void f_cdef() { // func name --
 }
 
 void f_docolon();
+void f_revlookup();
 
 // C code must always call a colon word through f_cexecute()
 void f_cexecute() {
@@ -449,9 +455,35 @@ void f_cexecute() {
   IP = oldIP;
 }
 
+#ifdef TRACE
+void f_traceon() {
+  TRACING = 1;
+}
+void f_traceoff() {
+  TRACING = 0;
+}
+#endif
+
 void f_colondispatch() {
   cell codeptr;
+#ifdef TRACE
+  static int printing = 0;
 
+  if (TRACING && !printing) {
+    printing = 1;
+    PUSHCP(W.p);
+    f_revlookup();
+    if (TOP().s) {
+      f_puts();
+      PUSHU(' ');
+      f_emit();
+    } else {
+      TOP().p = W.p;
+      f_dot();
+    }
+    printing = 0;
+  }
+#endif
   codeptr = *W.p;
   if (codeptr.f == f_docolon) {
     RPUSH(IP);
@@ -1076,6 +1108,10 @@ void f_init() {
   PCONST("$DOCREATE", f_docreate);
   PCONST("$DOVAR", f_dovar);
   PCONST("$DODEFERRED", f_dodeferred);
+#ifdef TRACE
+  CDEF("traceon", f_traceon);
+  CDEF("traceoff", f_traceoff);
+#endif
 
   f_loadfile_cterp("boot.jor");
   f_loadfile("defs.jor");

map.jor

@@ -3,10 +3,8 @@
   <rot + >rot + swap ;
 
 var tileselect
-8 const MAXTILE
+: invalidate-map mapsize mapsize! ;
-
 : mouseworldpos mousepos scrollpos +pos ;
-: world>tile 4 >> swap 4 >> swap ;
 : mousetile mouseworldpos world>tile ;
 : tile ( x y -- ptr ) mapsize drop * + map + ;
 
@@ -23,6 +21,16 @@ array tileflags
 ( roof )       0 b,
 ( brick )      0 b,
 ( window )     0 b,
+( carpet )     WALKABLE b,
+( wallpaper )  0 b,
+( tile )       WALKABLE b,
+( door )       0 b,
+( cabinet )    0 b,
+( fridge )     0 b,
+( countertop ) 0 b,
+( sink )       0 b,
+
+here tileflags - 1 - const MAXTILE
 
 : mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
 : walkable? ( x y -- b ) WALKABLE mapflag? ;
@@ -36,8 +44,11 @@ array tileflags
   dup MAXTILE > if drop 0 then
   tileselect !
 
-  MOUSEL mousedown if tileselect @ mousetile tile b! then
+  MOUSEL mousedown if tileselect @ mousetile tile b! invalidate-map then
-  MOUSER clicked if mouseworldpos world>tile swap . . then ;
+  MOUSER clicked if
+    mouseworldpos world>tile
+    2dup tile b@ dup tileselect ! .
+    swap . . cr then ;
 
 : copy-mapseg ( neww oldw y -- )
   r> ( oldw neww r: y )
@@ -64,3 +75,6 @@ array tileflags
   2dup * map fread
   mapsize!
   factivate ;
+
+: fill-map ( tile -- )
+  0 mapsize * for dup map i + b! next drop invalidate-map ;

pete.jor

@@ -16,7 +16,9 @@ car :touch
  :| 2dup S leaving? player.driving? not and if
        pete say" It's too far to walk to town."	1 else
      2dup 12 7 2= if
-       player.driving? not if pete say" TODO: Go home" then 1
+       player.driving? not if
+	 petehous.jor queue-level
+       then 1
      else 0 then then >rot drop drop
   |; ' player-touch redefine
   s" pete.map" load-map

petehous.jor

@@ -0,0 +1,14 @@
+( P E T E ' S   H O U S E )
+
+:noname
+  reset-level
+  16 9 tile>world player entity.pos!
+  :| 16 10 2= if
+     12 8 tile>world player entity.pos!
+     pete.jor queue-level
+     1 else 0 then
+  |; ' player-touch redefine
+
+  s" petehous.map" load-map
+; ' onload redefine
+