Text animations, save memory to .jim files post-load to speed startup

boot.jor

@@ -4,6 +4,7 @@
 key ) const ')'
 
 10 const '\n'
+13 const '\r'
 key  const sp
 
 128 const F_IMMEDIATE
@@ -47,4 +48,18 @@ key " const '"'
   begin word dup b@ while compileword repeat drop ;
 : load-input swap-input r> r> interpreter r< r< swap-input ;
 : loadstring ' key-string load-input drop drop ;
-: loadfile fdeactivate ' key-file load-input drop close ;
+
+: loadimage-if-uptodate ( filename -- b )
+  dup image-uptodate if imagefilename open loadimage close else drop 0 then ;
+
+: loadjor ( filename -- )
+  open fdeactivate ' key-file load-input drop factivate close ;
+
+: loadfile ( filename -- )
+  ( active file is preserved for the currently-loading file, but the
+    new file is always loaded with no active files )
+  fdeactivate swap
+  dup loadimage-if-uptodate not if
+    dup here swap loadjor
+    swap imagefilename overwrite saveimage close
+  else drop then factivate ;

defs.jor

@@ -1,7 +1,5 @@
 : stdout ' putc task-emit ! ;
-s" jorth.log" open seekend deactivate const LOGFILE
 : withfp ( xt fp -- ) fdeactivate r> factivate execute fdeactivate drop r< factivate ;
-: log-emit ' fputc LOGFILE withfp ;
 
 : >rot <rot <rot ;
 : 2dup over over ;
@@ -20,6 +18,8 @@ s" jorth.log" open seekend deactivate const LOGFILE
   swap ! ;
 : f@ ( v flag -- ) swap @ & ;
 
+: expile state if , else execute then ;
+
 ' cells @ const $DOCOLON ( get the colon execution token )
 : :noname here $DOCOLON , ] ;
 
@@ -41,11 +41,14 @@ s" jorth.log" open seekend deactivate const LOGFILE
 : +towards ( from to -- from+-1 )
   over > if 1 + else 1 - then ;
 
-: for ( from to -- ) ' r> , here ' r> , ; immediate ( r: to from )
+: for ( from to -- )
+  ' r> , [ ' begin , ] ( from r: to )
+  ' dup , ' r@ , ' != , [ ' while , ]
+  ' r> , ; immediate ( r: to from )
 : i ' r@ , ; immediate
-: next ' r< , ' r@ , ' +towards , ( from+1 r: to )
+: next
-       ' dup , ' r@ , ' = , ' BZ_ , ,
+  ' r< , ' r@ , ' +towards , ( from+1 r: to )
-       ' rdrop , ' drop , ; immediate
+  [ ' repeat , ] ' drop , ' rdrop , ; immediate
 
 : yield rswap ;
 : each [ ' begin , ] ' dup , [ ' while , ] ; immediate
@@ -53,7 +56,6 @@ s" jorth.log" open seekend deactivate const LOGFILE
 : 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

@@ -1,8 +1,5 @@
-: blah
+: blah ' seremit task-emit ! ;
-  ' seremit task-emit !
+blah
-  ' log-emit task-echo ! ;
-
-' seremit task-emit !
 
 : start-repl activate blah
   s" .:: J O R T H ( jean forth) ::." type cr
@@ -108,6 +105,9 @@ array frames
   2dup <= if drop r< +! 1 else drop drop rdrop 0 then ;
 
 : now! ( timer -- ) ticks swap ! ;
+: advance! ( timer -- delta )
+  dup @ ticks udelta ( timer delta )
+  dup <rot +! ;
 
 ( F O O T E R )
 var footer-y
@@ -135,15 +135,43 @@ var footer-y
 var text-color
 WHITE text-color !
 
-: texty 7 swap <rot text-color @ text ;
+: statusy 7 swap <rot text-color @ text ;
-: text0 10 texty ;
+: status0 10 statusy ;
-: text1 20 texty ;
+: status1 20 statusy ;
-: text2 30 texty ;
+: status2 30 statusy ;
+
+var textx
+var texty
+2 const textspeed
+
+: nltext 7 textx ! 10 texty +! ;
+: inctextx
+  textx @ 1 + dup 38 <= if textx !
+  else drop nltext 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 ;
+
+var texttimer
+: textnextc ( s -- s )
+  dup b@ dup if statusc 1 + else drop then ;
+
+: slowtext ( s -- )
+  texttimer now!
+  begin dup b@ while
+    texttimer advance! textspeed * 0 for textnextc next
+  suspend repeat drop ;
+
 : clear
   text-color @
   WHITE text-color !
-  s"                                 " dup dup text0 text1 text2
+  s"                                 " dup dup status0 status1 status2
-  text-color ! ;
+  text-color !
+  7 textx !
+  10 texty ! ;
 
 : move-to ( target speed p -- )
   dup r> @ >rot ticks ( from to duration start )
@@ -159,10 +187,8 @@ WHITE text-color !
 
 : footer-wait show-footer ^ENTER wait-key ;
 
-( todo: generic say" that handles newlines, gradual text display )
+: say ( s -- ) clear show-footer slowtext footer-wait ;
-: say1 ( s -- ) clear text1 footer-wait ;
+: say" [ ' s" , ] ' say expile ; immediate
-: say2 ( s1 s2 -- ) clear text1 text0 footer-wait ;
-: say3 ( s1 s2 s3 -- ) clear text2 text1 text0 footer-wait ;
 
 : character ( iportrait color ) create , ,
   does> dup @ text-color ! cell + @ draw-portrait ;
@@ -294,6 +320,10 @@ defer player
 
 12 9 N ' {player} defentity player
 
+: entity-dst ( e -- x y )
+  r> r@ entity.dir @ dir>pos
+  r@ entity.x @ r< entity.y @ world>tile +pos ;
+
 : move-entity ( e -- )
   dup entity.dir @ dir>pos ( e dx dy )
   dup if swap drop swap entity.y
@@ -321,9 +351,15 @@ defer player-touch ( x y -- b )
   player.canmove? if 0 else 1 then then then then ;
 
 : try-move-player
-  player entity.dir @ dir>pos
+  player entity-dst check-player-touch not if move-player then ;
-  player entity.x @ player entity.y @ world>tile +pos ( x y )
+
-  check-player-touch not if move-player then ;
+: check-entity-touch ( x y -- b )
+  2dup entity-at if drop drop 1 else
+  2dup out-of-bounds if 1 else
+  WALKABLE mapflag? if 0 else 1 then then then ;
+
+: try-move-entity ( e -- )
+  dup entity-dst check-entity-touch not if move-entity then ;
 
 player :tick
   0 ^LEFT key-down if drop 1 W player entity.dir ! then
@@ -335,8 +371,8 @@ player :tick
 
 ( S T U F F )
 : hello-world
-  s" Hello, world!" say1
+  mary say" Hello, world!"
-  s" How are you" s" today?" say2
+  say" How are you\today?"
   player.state DRIVING f@ not player.state DRIVING f! ;
 
 : mode-move
@@ -376,9 +412,10 @@ 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
+  car try-move-entity |; JOB send
 then
-:touch pete s" What an old rustbucket." say1
+:touch pete say" What an old rustbucket.
+Hasn't driven in years."
 ;entity
 
 :noname

jorth.c

@@ -1,4 +1,5 @@
 #include <stdio.h>
+#include <sys/stat.h>
 #include "jorth.h"
 #include "serial.h"
 
@@ -80,7 +81,7 @@ BINOP(f_add, i, +)
 BINOP(f_sub, i, -)
 BINOP(f_mul, i, *)
 BINOP(f_div, i, /)
-BINOP(f_mod, i, %)
+BINOP(f_mod, u, %)
 BINOP(f_eq, i, ==)
 BINOP(f_neq, i, !=)
 BINOP(f_ge, i, >=)
@@ -314,23 +315,22 @@ void f_fwrite() { // ( length p )
 void f_fgetc() {
   int result = EOF;
   if (ACTIVE_FILE) {
-    char byte = 0;
+    result = fgetc(ACTIVE_FILE);
-    if (fread(&byte, 1, 1, ACTIVE_FILE) == 1) {
-      result = byte;
-    }
   }
   PUSHI(result);
 }
 
 void f_fget() {
+  unsigned int result = 0;
   if (ACTIVE_FILE) {
-    int result = 0;
+    int low = fgetc(ACTIVE_FILE);
-    fread(&result, 2, 1, ACTIVE_FILE);
+    int high = fgetc(ACTIVE_FILE);
-    PUSHU(result);
+    if (low != EOF && high != EOF) {
-  } else {
+      result = low | (high << 8);
-    PUSHU(0); // no way to signal EOF
     }
   }
+  PUSHU(result);
+}
 
 void f_fread() { // ( length p )
   if (ACTIVE_FILE) {
@@ -641,7 +641,6 @@ void f_close() {
 
 void f_open() {
   FILE *fp;
-  f_close();
   fp = fopen(TOP().s, "ab+");
   fseek(fp, 0, SEEK_SET);
   ACTIVE_FILE = fp;
@@ -769,16 +768,105 @@ void f_quote() {
     DROP(1);
   }
 }
+void f_imagefilename() {
+  static char imagefilename[32];
+  int i;
+
+  strcpy(imagefilename, TOP().s);
+  for (i = 0; i < strlen(imagefilename); i ++) {
+    if (imagefilename[i] == '.') break;
+  }
+  strcpy(&imagefilename[i], ".jim");
+  TOP().s = imagefilename;
+}
+
+void f_image_up_to_date() {
+  struct stat src, img;
+  int uptodate = 0;
+  f_dup();
+  f_imagefilename();
+  if (stat(TOP().s, &img) == 0 && stat(ST1().s, &src) == 0) {
+    uptodate = img.st_mtime > src.st_mtime;
+  }
+  DROP(1);
+  TOP().i = uptodate;
+}
+
+void f_loadimage() {
+  cell *start, *latestNew, *tasksNew;
+  size_t size;
+
+  fread(&start, sizeof(cell *), 1, ACTIVE_FILE);
+  fread(&latestNew, sizeof(cell *), 1, ACTIVE_FILE);
+  fread(&tasksNew, sizeof(cell *), 1, ACTIVE_FILE);
+  fread(&size, sizeof(size_t), 1, ACTIVE_FILE);
+  if (start != HERE) {
+    fseek(ACTIVE_FILE, size, SEEK_CUR);
+    PUSHI(0);
+  } else {
+    fread(HERE, 1, size, ACTIVE_FILE);
+    HERE = CELL_OFFSET(HERE, size);
+    LATEST = latestNew;
+    TASKS = tasksNew;
+    PUSHI(1);
+  }
+}
+
+void f_saveimage() {
+  size_t size = (size_t)(((char*)HERE) - TOP().s);
+  fwrite(&TOP().p, sizeof(cell *), 1, ACTIVE_FILE);
+  fwrite(&LATEST, sizeof(cell *), 1, ACTIVE_FILE);
+  fwrite(&TASKS, sizeof(cell *), 1, ACTIVE_FILE);
+  fwrite(&size, sizeof(size_t), 1, ACTIVE_FILE);
+  fwrite(TOP().p, 1, size, ACTIVE_FILE);
+  DROP(1);
+}
 
 void f_loadfile(char *filename) {
   PUSHS(filename);
-  f_open();
   PUSHS("loadfile");
   f_lookup();
   DROP(1);
   f_cexecute();
 }
 
+// does not use the jorth interpreter defined in boot.jor
+void f_loadfile_cterp(char *filename) {
+  cell *start = HERE;
+  PUSHS(filename);
+  f_dup();
+  f_image_up_to_date();
+  if (TOP().i) {
+    DROP(1);
+    f_dup();
+    f_imagefilename();
+    f_open();
+    f_loadimage();
+    f_close();
+    if (TOP().i) {
+      DROP(2);
+      return;
+    }
+  }
+  DROP(1);
+  f_open();
+  f_deactivate();
+  PUSHS("key-file");
+  f_lookup();
+  DROP(1);
+  f_swapinput();
+  f_interpreter();
+  f_swapinput();
+  DROP(2);
+
+  PUSHS(filename);
+  f_imagefilename();
+  f_overwrite();
+  PUSHCP(start);
+  f_saveimage();
+  f_close();
+}
+
 void f_runstring(char *s) {
   PUSHS(s);
   PUSHS("loadstring");
@@ -946,6 +1034,10 @@ void f_init() {
   CDEF("fget", f_fget);
   CDEF("fwrite", f_fwrite);
   CDEF("fread", f_fread);
+  CDEF("imagefilename", f_imagefilename);
+  CDEF("image-uptodate", f_image_up_to_date);
+  CDEF("loadimage", f_loadimage);
+  CDEF("saveimage", f_saveimage);
   CDEF("memmove", f_memmove);
   CDEF("quiet", f_quiet);
   CDEF("loud", f_loud);
@@ -960,17 +1052,7 @@ void f_init() {
   PCONST("$DOVAR", f_dovar);
   PCONST("$DODEFERRED", f_dodeferred);
 
-  PUSHS("boot.jor");
+  f_loadfile_cterp("boot.jor");
-  f_open();
-  f_deactivate();
-  PUSHS("key-file");
-  f_lookup();
-  DROP(1);
-  f_swapinput();
-  f_interpreter();
-  f_swapinput();
-  DROP(2);
-
   f_loadfile("defs.jor");
 }
 

testbed.c

@@ -148,6 +148,13 @@ void f_splitscreen() {
   DROP(1);
 }
 
+void f_textc() { // ( col line c color -- )
+  setWriteMode(0);
+  setPlaneColor(TOP().u);
+  DROP(1);
+  text_draw_char(ST2().u + (ST1().u * PAGE_STRIDE), TOP().i);
+  DROP(3);
+}
 
 void f_text() { // ( col line s color -- )
   setWriteMode(0);
@@ -199,6 +206,7 @@ void game_f_init() {
   CDEF("split-screen", f_splitscreen);
   CDEF("ticks", f_ticks);
   CDEF("text", f_text);
+  CDEF("textc", f_textc);
   CDEF("map", f_map);
   CDEF("mapsize", f_mapsize);
   CDEF("mapsize!", f_mapsize_set);