add pete's house interior; implement memory checkpointing / rollback
This commit is contained in:
parent
f0a35a31b9
commit
9165b44bc7
9
defs.jor
9
defs.jor
|
@ -56,6 +56,15 @@
|
||||||
: min ( x y -- x|y ) 2dup > if swap then drop ;
|
: min ( x y -- x|y ) 2dup > if swap then drop ;
|
||||||
: max ( 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
|
: decompile
|
||||||
word lookup if 1 begin ( cp i )
|
word lookup if 1 begin ( cp i )
|
||||||
2dup cells + @ ( cp i @cp+i )
|
2dup cells + @ ( cp i @cp+i )
|
||||||
|
|
BIN
entity.jim
BIN
entity.jim
Binary file not shown.
|
@ -1,7 +1,10 @@
|
||||||
0 const EVTICK
|
0 const EVTICK
|
||||||
1 const EVTOUCH
|
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.x 4 cells + ;
|
||||||
: entity.y 3 cells + ;
|
: entity.y 3 cells + ;
|
||||||
: entity.dir 2 cells + ;
|
: entity.dir 2 cells + ;
|
||||||
|
|
BIN
footer.jim
BIN
footer.jim
Binary file not shown.
17
game.jor
17
game.jor
|
@ -15,7 +15,6 @@ JOB listen-for-jobs
|
||||||
|
|
||||||
( T I C K )
|
( T I C K )
|
||||||
defer entities
|
defer entities
|
||||||
:noname 0 ; ' entities redefine
|
|
||||||
|
|
||||||
: entity-at ( x y -- entity|0 )
|
: entity-at ( x y -- entity|0 )
|
||||||
0 >rot
|
0 >rot
|
||||||
|
@ -69,9 +68,7 @@ defer player
|
||||||
S = if swap drop mapsize swap drop >= else
|
S = if swap drop mapsize swap drop >= else
|
||||||
drop mapsize drop >= then then then ;
|
drop mapsize drop >= then then then ;
|
||||||
|
|
||||||
: no-touch drop drop 0 ;
|
|
||||||
defer player-touch ( x y -- b )
|
defer player-touch ( x y -- b )
|
||||||
' no-touch ' player-touch redefine
|
|
||||||
|
|
||||||
: check-player-touch ( x y -- b )
|
: check-player-touch ( x y -- b )
|
||||||
2dup entity-at dup if EVTOUCH entity>do drop drop 1 else drop
|
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 -- )
|
: try-move-entity ( e -- )
|
||||||
dup entity-dst check-entity-touch not if move-entity then ;
|
dup entity-dst check-entity-touch not if move-entity then ;
|
||||||
|
|
||||||
|
var queued-level
|
||||||
|
: queue-level queued-level ! ;
|
||||||
|
|
||||||
player :tick
|
player :tick
|
||||||
0 ^LEFT key-down if drop 1 W player entity.dir ! then
|
0 ^LEFT key-down if drop 1 W player entity.dir ! then
|
||||||
^RIGHT key-down if drop 1 E 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
|
^SPACE key-pressed if
|
||||||
' hello-world JOB send
|
' hello-world JOB send
|
||||||
then
|
then
|
||||||
tick-debounce ;
|
tick-debounce
|
||||||
|
queued-level @ dup if
|
||||||
|
0 queue-level
|
||||||
|
loadlevel
|
||||||
|
else drop then ;
|
||||||
|
|
||||||
' mode-move MODE-MOVE !
|
' mode-move MODE-MOVE !
|
||||||
' tick-debounce MODE-WAIT !
|
' tick-debounce MODE-WAIT !
|
||||||
|
@ -128,7 +132,12 @@ player :tick
|
||||||
draw-screen
|
draw-screen
|
||||||
draw-footer ;
|
draw-footer ;
|
||||||
|
|
||||||
|
: reset-level
|
||||||
|
:| player yield 0 |; ' entities redefine
|
||||||
|
:| drop drop 0 |; ' player-touch redefine ;
|
||||||
|
|
||||||
:noname
|
:noname
|
||||||
|
reset-level
|
||||||
MODE-MOVE @ ' tick redefine
|
MODE-MOVE @ ' tick redefine
|
||||||
' full-draw ' draw redefine
|
' full-draw ' draw redefine
|
||||||
; ' onload redefine
|
; ' onload redefine
|
11
gameboot.jor
11
gameboot.jor
|
@ -9,6 +9,7 @@ REPL start-repl
|
||||||
|
|
||||||
defer tick
|
defer tick
|
||||||
defer draw
|
defer draw
|
||||||
|
defer loadlevel
|
||||||
|
|
||||||
:noname
|
:noname
|
||||||
s" input.jor" loadfile
|
s" input.jor" loadfile
|
||||||
|
@ -17,6 +18,12 @@ s" timer.jor" loadfile
|
||||||
s" footer.jor" loadfile
|
s" footer.jor" loadfile
|
||||||
s" map.jor" loadfile
|
s" map.jor" loadfile
|
||||||
s" game.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
|
||||||
|
|
36
jorth.c
36
jorth.c
|
@ -1,3 +1,5 @@
|
||||||
|
#define TRACE
|
||||||
|
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
#include <sys/stat.h>
|
#include <sys/stat.h>
|
||||||
#include "jorth.h"
|
#include "jorth.h"
|
||||||
|
@ -29,6 +31,9 @@ cell *RUNNING = (cell*)mem;
|
||||||
cell *TASKS = (cell*)mem;
|
cell *TASKS = (cell*)mem;
|
||||||
cell *stack = ((cell*)mem) + STACK_OFFSET;
|
cell *stack = ((cell*)mem) + STACK_OFFSET;
|
||||||
cell *rstack = ((cell*)mem) + RSTACK_OFFSET;
|
cell *rstack = ((cell*)mem) + RSTACK_OFFSET;
|
||||||
|
#ifdef TRACE
|
||||||
|
int TRACING = 0;
|
||||||
|
#endif
|
||||||
|
|
||||||
#define QUIET (*(RUNNING + TASK_USER_QUIET))
|
#define QUIET (*(RUNNING + TASK_USER_QUIET))
|
||||||
|
|
||||||
|
@ -432,6 +437,7 @@ void f_cdef() { // func name --
|
||||||
}
|
}
|
||||||
|
|
||||||
void f_docolon();
|
void f_docolon();
|
||||||
|
void f_revlookup();
|
||||||
|
|
||||||
// C code must always call a colon word through f_cexecute()
|
// C code must always call a colon word through f_cexecute()
|
||||||
void f_cexecute() {
|
void f_cexecute() {
|
||||||
|
@ -449,9 +455,35 @@ void f_cexecute() {
|
||||||
IP = oldIP;
|
IP = oldIP;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
#ifdef TRACE
|
||||||
|
void f_traceon() {
|
||||||
|
TRACING = 1;
|
||||||
|
}
|
||||||
|
void f_traceoff() {
|
||||||
|
TRACING = 0;
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
|
||||||
void f_colondispatch() {
|
void f_colondispatch() {
|
||||||
cell codeptr;
|
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;
|
codeptr = *W.p;
|
||||||
if (codeptr.f == f_docolon) {
|
if (codeptr.f == f_docolon) {
|
||||||
RPUSH(IP);
|
RPUSH(IP);
|
||||||
|
@ -1076,6 +1108,10 @@ void f_init() {
|
||||||
PCONST("$DOCREATE", f_docreate);
|
PCONST("$DOCREATE", f_docreate);
|
||||||
PCONST("$DOVAR", f_dovar);
|
PCONST("$DOVAR", f_dovar);
|
||||||
PCONST("$DODEFERRED", f_dodeferred);
|
PCONST("$DODEFERRED", f_dodeferred);
|
||||||
|
#ifdef TRACE
|
||||||
|
CDEF("traceon", f_traceon);
|
||||||
|
CDEF("traceoff", f_traceoff);
|
||||||
|
#endif
|
||||||
|
|
||||||
f_loadfile_cterp("boot.jor");
|
f_loadfile_cterp("boot.jor");
|
||||||
f_loadfile("defs.jor");
|
f_loadfile("defs.jor");
|
||||||
|
|
24
map.jor
24
map.jor
|
@ -3,10 +3,8 @@
|
||||||
<rot + >rot + swap ;
|
<rot + >rot + swap ;
|
||||||
|
|
||||||
var tileselect
|
var tileselect
|
||||||
8 const MAXTILE
|
: invalidate-map mapsize mapsize! ;
|
||||||
|
|
||||||
: mouseworldpos mousepos scrollpos +pos ;
|
: mouseworldpos mousepos scrollpos +pos ;
|
||||||
: world>tile 4 >> swap 4 >> swap ;
|
|
||||||
: mousetile mouseworldpos world>tile ;
|
: mousetile mouseworldpos world>tile ;
|
||||||
: tile ( x y -- ptr ) mapsize drop * + map + ;
|
: tile ( x y -- ptr ) mapsize drop * + map + ;
|
||||||
|
|
||||||
|
@ -23,6 +21,16 @@ array tileflags
|
||||||
( roof ) 0 b,
|
( roof ) 0 b,
|
||||||
( brick ) 0 b,
|
( brick ) 0 b,
|
||||||
( window ) 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@ & ;
|
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
|
||||||
: walkable? ( x y -- b ) WALKABLE mapflag? ;
|
: walkable? ( x y -- b ) WALKABLE mapflag? ;
|
||||||
|
@ -36,8 +44,11 @@ array tileflags
|
||||||
dup MAXTILE > if drop 0 then
|
dup MAXTILE > if drop 0 then
|
||||||
tileselect !
|
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 -- )
|
: copy-mapseg ( neww oldw y -- )
|
||||||
r> ( oldw neww r: y )
|
r> ( oldw neww r: y )
|
||||||
|
@ -64,3 +75,6 @@ array tileflags
|
||||||
2dup * map fread
|
2dup * map fread
|
||||||
mapsize!
|
mapsize!
|
||||||
factivate ;
|
factivate ;
|
||||||
|
|
||||||
|
: fill-map ( tile -- )
|
||||||
|
0 mapsize * for dup map i + b! next drop invalidate-map ;
|
||||||
|
|
4
pete.jor
4
pete.jor
|
@ -16,7 +16,9 @@ car :touch
|
||||||
:| 2dup S leaving? player.driving? not and if
|
:| 2dup S leaving? player.driving? not and if
|
||||||
pete say" It's too far to walk to town." 1 else
|
pete say" It's too far to walk to town." 1 else
|
||||||
2dup 12 7 2= if
|
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
|
else 0 then then >rot drop drop
|
||||||
|; ' player-touch redefine
|
|; ' player-touch redefine
|
||||||
s" pete.map" load-map
|
s" pete.map" load-map
|
||||||
|
|
BIN
petehous.jim
Executable file
BIN
petehous.jim
Executable file
Binary file not shown.
14
petehous.jor
Executable file
14
petehous.jor
Executable file
|
@ -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
|
||||||
|
|
BIN
petehous.map
Executable file
BIN
petehous.map
Executable file
Binary file not shown.
Loading…
Reference in a new issue