diff --git a/boot.img b/boot.img new file mode 100755 index 0000000..2dc664a Binary files /dev/null and b/boot.img differ diff --git a/boot.jim b/boot.jim new file mode 100755 index 0000000..815b51e Binary files /dev/null and b/boot.jim differ diff --git a/boot.jor b/boot.jor index 7d4a211..520d1d4 100755 --- a/boot.jor +++ b/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 ; diff --git a/defs.jim b/defs.jim new file mode 100755 index 0000000..8ad65f1 Binary files /dev/null and b/defs.jim differ diff --git a/defs.jor b/defs.jor index a3578c6..a032e4d 100755 --- a/defs.jor +++ b/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 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 ) - ' dup , ' r@ , ' = , ' BZ_ , , - ' rdrop , ' drop , ; immediate +: next + ' r< , ' r@ , ' +towards , ( from+1 r: to ) + [ ' 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 ; diff --git a/game.exe b/game.exe index 9b27587..22bfdb0 100755 Binary files a/game.exe and b/game.exe differ diff --git a/game.img b/game.img new file mode 100755 index 0000000..3fa9f28 Binary files /dev/null and b/game.img differ diff --git a/game.jim b/game.jim new file mode 100755 index 0000000..4d79ccd Binary files /dev/null and b/game.jim differ diff --git a/game.jor b/game.jor index bd1e3c2..0ecc60c 100755 --- a/game.jor +++ b/game.jor @@ -1,8 +1,5 @@ -: blah - ' seremit task-emit ! - ' log-emit task-echo ! ; - -' seremit task-emit ! +: blah ' seremit task-emit ! ; +blah : 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 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 ) -: say1 ( s -- ) clear text1 footer-wait ; -: say2 ( s1 s2 -- ) clear text1 text0 footer-wait ; -: say3 ( s1 s2 s3 -- ) clear text2 text1 text0 footer-wait ; +: say ( s -- ) clear show-footer slowtext footer-wait ; +: say" [ ' s" , ] ' say expile ; immediate : 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.x @ player entity.y @ world>tile +pos ( x y ) - check-player-touch not if move-player then ; + player entity-dst 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 - s" How are you" s" today?" say2 + mary say" Hello, world!" + 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 diff --git a/game.prj b/game.prj index 7ff771f..8918e13 100755 Binary files a/game.prj and b/game.prj differ diff --git a/jorth.c b/jorth.c index f92a222..128dbfa 100755 --- a/jorth.c +++ b/jorth.c @@ -1,4 +1,5 @@ #include +#include #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,22 +315,21 @@ void f_fwrite() { // ( length p ) void f_fgetc() { int result = EOF; if (ACTIVE_FILE) { - char byte = 0; - if (fread(&byte, 1, 1, ACTIVE_FILE) == 1) { - result = byte; - } + result = fgetc(ACTIVE_FILE); } PUSHI(result); } void f_fget() { + unsigned int result = 0; if (ACTIVE_FILE) { - int result = 0; - fread(&result, 2, 1, ACTIVE_FILE); - PUSHU(result); - } else { - PUSHU(0); // no way to signal EOF + int low = fgetc(ACTIVE_FILE); + int high = fgetc(ACTIVE_FILE); + if (low != EOF && high != EOF) { + result = low | (high << 8); + } } + PUSHU(result); } void f_fread() { // ( length p ) @@ -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_open(); - f_deactivate(); - PUSHS("key-file"); - f_lookup(); - DROP(1); - f_swapinput(); - f_interpreter(); - f_swapinput(); - DROP(2); - + f_loadfile_cterp("boot.jor"); f_loadfile("defs.jor"); } diff --git a/jorth.img b/jorth.img new file mode 100755 index 0000000..a67f4b8 Binary files /dev/null and b/jorth.img differ diff --git a/testbed.c b/testbed.c index 367c2a0..123749e 100755 --- a/testbed.c +++ b/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);