Split game.jor into multiple .jor files, add ability to specify code to run post-load for side effects

This commit is contained in:
Jeremy Penner 2019-03-09 18:49:45 -05:00
parent ad0f3fbf6c
commit a5ec79c88a
22 changed files with 399 additions and 299 deletions

BIN
boot.jim

Binary file not shown.

View file

@ -49,17 +49,44 @@ key " const '"'
: load-input swap-input r> r> interpreter r< r< swap-input ; : load-input swap-input r> r> interpreter r< r< swap-input ;
: loadstring ' key-string load-input drop drop ; : loadstring ' key-string load-input drop drop ;
: loadimage-if-uptodate ( filename -- b ) ( image loading )
dup image-uptodate if imagefilename open loadimage close else drop 0 then ; : noop ;
: loadjor ( filename -- ) : defer word new-word $DODEFERRED , ' noop , ;
: redefine ( cp cpdeferred ) cell + ! ;
: definition ( cpdeferred ) cell + @ ;
defer onload
: postload onload ' noop ' onload redefine ;
: loadimage ( -- [0 | onload] )
fget fget fget fget fget ( onload tasks latest size start )
here != if tell + seek drop drop drop 0 else
dup here fread here + here! latest! tasks! then ;
: saveimage ( herestart -- )
' onload definition here drop fput
tasks fput
latest fput
dup here swap - fput
dup fput
dup here swap - swap fwrite ;
( file loading )
: loadimage-if-uptodate ( filename -- b )
dup image-uptodate if imagefilename open loadimage close else drop 0 then
dup if execute 1 then ;
: interpretjor ( filename -- )
open fdeactivate ' key-file load-input drop factivate close ; open fdeactivate ' key-file load-input drop factivate close ;
: loadjor fdeactivate swap interpretjor postload factivate ;
: loadfile ( filename -- ) : loadfile ( filename -- )
( active file is preserved for the currently-loading file, but the ( active file is preserved for the currently-loading file, but the
new file is always loaded with no active files ) new file is always loaded with no active files )
fdeactivate swap fdeactivate swap
dup loadimage-if-uptodate not if dup loadimage-if-uptodate not if
dup here swap loadjor dup here swap interpretjor
swap imagefilename overwrite saveimage close swap imagefilename overwrite saveimage close postload
else drop then factivate ; else drop then factivate ;

BIN
defs.jim

Binary file not shown.

View file

@ -9,8 +9,6 @@
: 2= ( a b c d -- a=c&b=d ) : 2= ( a b c d -- a=c&b=d )
r> <rot = swap r< = and ; r> <rot = swap r< = and ;
: noop ;
: ~ -1 ^ ; : ~ -1 ^ ;
: f! ( b v flag -- ) : f! ( b v flag -- )
r> dup @ ( b v val r: flag ) r> dup @ ( b v val r: flag )
@ -26,9 +24,6 @@
: :| inline| $DOCOLON , ; immediate : :| inline| $DOCOLON , ; immediate
: |; ' ret , |inline ; immediate : |; ' ret , |inline ; immediate
: defer word new-word $DODEFERRED , ' noop , ;
: redefine ( cp cpdeferred ) cell + ! ;
: array word new-word $DOVAR , ; : array word new-word $DOVAR , ;
: create word new-word $DOCREATE , 0 , ; : create word new-word $DOCREATE , 0 , ;
@ -56,6 +51,8 @@
: dobreak yield 0 ; : dobreak yield 0 ;
: break ' rdrop , ' dobreak , ; immediate : break ' rdrop , ' dobreak , ; immediate
: links begin yield @ dup not until ;
: 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 ;
@ -76,6 +73,18 @@
: task-stack task-user-size 3 + cells + ; : task-stack task-user-size 3 + cells + ;
: task-rstack task-stack stacksize cells + ; : task-rstack task-stack stacksize cells + ;
: .wordin ( ptr -- )
latest links each
2dup > if wordname type drop 0 break then
more dup if . else drop then ;
: tasks.s
tasks links each
dup .wordin s" : " type
dup task-sp @ over task-stack ( task stackLim stack )
begin 2dup > while dup @ . cell + repeat
cr drop drop more ;
: doactivate ( task ip -- ) : doactivate ( task ip -- )
over task-ip ! over task-ip !
dup task-stack over task-sp ! dup task-stack over task-sp !
@ -89,11 +98,16 @@
' ret , ' ret ,
; immediate ; immediate
: send ( val task -- ) : try-send ( val task -- b )
mailbox dup @ if drop drop 0 else ! 1 then ;
: wait-send ( val task -- )
mailbox mailbox
begin dup @ while suspend repeat ( wait for empty mailbox ) begin dup @ while suspend repeat ( wait for empty mailbox )
! ; ! ;
: send ( val task -- ) try-send drop ;
: receive ( -- val ) : receive ( -- val )
running mailbox running mailbox
begin dup @ not while suspend repeat ( wait for mail ) begin dup @ not while suspend repeat ( wait for mail )

BIN
entity.jim Executable file

Binary file not shown.

50
entity.jor Executable file
View file

@ -0,0 +1,50 @@
0 const EVTICK
1 const EVTOUCH
: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ;
: entity.x 4 cells + ;
: entity.y 3 cells + ;
: entity.dir 2 cells + ;
: entity>sprite cell + @ execute ;
: entity>do ( entity event ) swap @ execute ;
var entity-defstate
: entitydo-ev ( [cp ifhere] ev -- )
entity-defstate @ if swap [ ' then , ]
else 1 entity-defstate ! :noname swap then
' dup , lit ' = , [ ' if , ] ;
: :touch EVTOUCH entitydo-ev ; immediate
: :tick EVTICK entitydo-ev ; immediate
: ;entity ( entity cp ifhere -- )
[ ' then , ] ' drop , [ ' ; , ]
0 entity-defstate ! swap ! ; immediate
0 const W
1 const E
2 const N
3 const S
: dir>pos ( dir -- dx dy )
dup W = if drop -1 0 ret then
dup E = if drop 1 0 ret then
N = if 0 -1
else 0 1 then ;
: frame ( s n e w ) b, b, b, b, ;
array frames
( 0: car ) 3 1 0 2 frame
( 1: pete stand ) 11 9 7 5 frame
( 2: pete walk ) 12 10 8 6 frame
: sprindex ( dir frame ) 2 << frames + + b@ ;
: defstatic ( frame -- ) create b, does> b@ sprindex ;
: defanim ( frame... framecount ticks-per-frame -- )
create b, dup b, 0 for b, next
does> ( dir a -- )
dup dup 1 + b@ swap b@ ( dir a count tpf )
ticks swap / swap % ( dir a index )
2 + + b@ sprindex ;
0 defstatic {car}
1 defstatic {pete-stand}
1 2 2 5 defanim {pete-walk}

BIN
footer.jim Executable file

Binary file not shown.

79
footer.jor Executable file
View file

@ -0,0 +1,79 @@
( F O O T E R )
var footer-y
0 footer-y !
: draw-footer footer-y @ split-screen ;
0 const BLACK
1 const BLUE
2 const GREEN
3 const CYAN
4 const RED
5 const MAGENTA
6 const BROWN
7 const LGRAY
8 const DGRAY
9 const LBLUE
10 const LGREEN
11 const LCYAN
12 const PINK
13 const LMAGENTA
14 const YELLOW
15 const WHITE
var text-color
WHITE text-color !
: statusy 7 swap <rot text-color @ text ;
: status0 10 statusy ;
: status1 20 statusy ;
: 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 status0 status1 status2
text-color !
7 textx !
10 texty ! ;
: show-footer 48 10 footer-y move-to ;
: hide-footer 0 10 footer-y move-to ;
: footer-wait show-footer ^ENTER wait-key ;
: say ( s -- ) clear show-footer slowtext footer-wait ;
: say" [ ' s" , ] ' say expile ; immediate
: character ( iportrait color ) create , ,
does> dup @ text-color ! cell + @ draw-portrait ;
0 GREEN character pete
1 MAGENTA character mary
2 BROWN character chuck

BIN
game.exe

Binary file not shown.

BIN
game.jim

Binary file not shown.

298
game.jor
View file

@ -7,275 +7,16 @@ blah
task const REPL task const REPL
REPL start-repl REPL start-repl
1 const ^ESC
28 const ^ENTER
29 const ^CTRL
51 const ^<
52 const ^>
56 const ^ALT
57 const ^SPACE
72 const ^UP
75 const ^LEFT
77 const ^RIGHT
80 const ^DOWN
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
: udelta ( u u -- u )
2dup u> if
swap -1 swap - + 1 +
else
swap -
then ;
: sleep ( count -- )
ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;
defer tick defer tick
defer draw defer draw
0 const EVTICK :noname
1 const EVTOUCH s" input.jor" loadfile
s" entity.jor" loadfile
: defentity ( x y dir anim -- ) array ' drop , , , 4 << , 4 << , ; s" timer.jor" loadfile
: entity.x 4 cells + ; s" footer.jor" loadfile
: entity.y 3 cells + ; s" map.jor" loadfile
: entity.dir 2 cells + ; ; execute
: entity>sprite cell + @ execute ;
: entity>do ( entity event ) swap @ execute ;
var entity-defstate
: entitydo-ev ( [cp ifhere] ev -- )
entity-defstate @ if swap [ ' then , ]
else 1 entity-defstate ! :noname swap then
' dup , lit ' = , [ ' if , ] ;
: :touch EVTOUCH entitydo-ev ; immediate
: :tick EVTICK entitydo-ev ; immediate
: ;entity ( entity cp ifhere -- )
[ ' then , ] ' drop , [ ' ; , ]
0 entity-defstate ! swap ! ; immediate
0 const W
1 const E
2 const N
3 const S
: dir>pos ( dir -- dx dy )
dup W = if drop -1 0 ret then
dup E = if drop 1 0 ret then
N = if 0 -1
else 0 1 then ;
: frame ( s n e w ) b, b, b, b, ;
array frames
( 0: car ) 3 1 0 2 frame
( 1: pete stand ) 11 9 7 5 frame
( 2: pete walk ) 12 10 8 6 frame
: sprindex ( dir frame ) 2 << frames + + b@ ;
: defstatic ( frame -- ) create b, does> b@ sprindex ;
: defanim ( frame... framecount ticks-per-frame -- )
create b, dup b, 0 for b, next
does> ( dir a -- )
dup dup 1 + b@ swap b@ ( dir a count tpf )
ticks swap / swap % ( dir a index )
2 + + b@ sprindex ;
0 defstatic {car}
1 defstatic {pete-stand}
1 2 2 5 defanim {pete-walk}
( timer + lerping )
: clamp0 ( range val -- i )
2dup <= if drop else
dup 0 <= if drop drop 0 else
swap drop then then ;
: >ratio ( range value -- f )
over swap clamp0 swap />ratio ;
: <ratio ( range ratio -- v ) *<ratio ;
: >range ( start end -- start range ) over - ;
: <range ( start range -- start end ) over + ;
: lerpr ( start end ratio ) r> >range r< <ratio + ;
: lerpn ( start1 end1 start2 end2 val )
r> >range r< <rot - >ratio lerpr ;
: lerp ( start end duration start -- i )
ticks udelta ( start end duration delta )
>ratio lerpr ;
: triggered ( duration timer -- b )
dup r> @ ticks udelta ( duration delta )
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
0 footer-y !
: draw-footer footer-y @ split-screen ;
0 const BLACK
1 const BLUE
2 const GREEN
3 const CYAN
4 const RED
5 const MAGENTA
6 const BROWN
7 const LGRAY
8 const DGRAY
9 const LBLUE
10 const LGREEN
11 const LCYAN
12 const PINK
13 const LMAGENTA
14 const YELLOW
15 const WHITE
var text-color
WHITE text-color !
: statusy 7 swap <rot text-color @ text ;
: status0 10 statusy ;
: status1 20 statusy ;
: 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 status0 status1 status2
text-color !
7 textx !
10 texty ! ;
: move-to ( target speed p -- )
dup r> @ >rot ticks ( from to duration start )
begin
4dup lerp r@ !
<rot dup r@ @ != ( from duration start to !done )
while
>rot suspend
repeat rdrop drop drop drop drop ;
: show-footer 48 10 footer-y move-to ;
: hide-footer 0 10 footer-y move-to ;
: footer-wait show-footer ^ENTER wait-key ;
: say ( s -- ) clear show-footer slowtext footer-wait ;
: say" [ ' s" , ] ' say expile ; immediate
: character ( iportrait color ) create , ,
does> dup @ text-color ! cell + @ draw-portrait ;
0 GREEN character pete
1 MAGENTA character mary
2 BROWN character chuck
( M O U S E )
var prevbutton
: tick-debounce
mousebuttons prevbutton ! ;
1 const MOUSEL
2 const MOUSER
: mousedown ( button -- bool ) mousebuttons & ;
: clicked ( button -- bool )
dup mousedown not swap
prevbutton @ & and ;
( M A P )
: +pos ( x1 y1 x2 y2 -- x y )
<rot + >rot + swap ;
var tileselect
8 const MAXTILE
: mouseworldpos mousepos scrollpos +pos ;
: world>tile 4 >> swap 4 >> swap ;
: mousetile mouseworldpos world>tile ;
: tile ( x y -- ptr ) mapsize drop * + map + ;
1 const WALKABLE
2 const DRIVABLE
array tileflags
( grass ) WALKABLE b,
( dirt ) WALKABLE b,
( water ) 0 b,
( pavement ) WALKABLE DRIVABLE | b,
( brick ) 0 b,
( forest ) 0 b,
( roof ) 0 b,
( brick ) 0 b,
( window ) 0 b,
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
: walkable? ( x y -- b ) WALKABLE mapflag? ;
: drivable? ( x y -- b ) DRIVABLE mapflag? ;
: tick-mapedit
tileselect @
^< key-pressed if 1 - then
^> key-pressed if 1 + then
dup 0 < if drop MAXTILE then
dup MAXTILE > if drop 0 then
tileselect !
MOUSEL mousedown if tileselect @ mousetile tile b! then
MOUSER clicked if mouseworldpos world>tile swap . . then ;
: copy-mapseg ( neww oldw y -- )
r> ( oldw neww r: y )
2dup min >rot ( copyw neww oldw )
r@ * map + ( copyw neww src )
swap r< * map + ( copyw src dst )
swap <rot memmove ;
: resize-map ( neww newh -- )
swap mapsize r> ( newh neww oldw r: oldh )
2dup < if 1 r< else r< 1 - 0 then ( newh neww copyw ystart ylim )
for 2dup i copy-mapseg next
drop swap mapsize! ;
: save-map ( filename -- )
fdeactivate swap overwrite
mapsize swap fput fput
mapsize * map fwrite
factivate ;
: load-map ( filename -- )
fdeactivate swap open
fget fget
2dup * map fread
mapsize!
factivate ;
( J O B ) ( J O B )
var MODE-MOVE var MODE-MOVE
@ -294,6 +35,7 @@ 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
@ -371,8 +113,6 @@ player :tick
( S T U F F ) ( S T U F F )
: hello-world : hello-world
mary say" Hello, world!"
say" How are you\today?"
player.state DRIVING f@ not player.state DRIVING f! ; player.state DRIVING f@ not player.state DRIVING f! ;
: mode-move : mode-move
@ -404,24 +144,6 @@ player :tick
MODE-MOVE @ ' tick redefine MODE-MOVE @ ' tick redefine
' full-draw ' draw redefine ' full-draw ' draw redefine
( P E T E )
8 8 E ' {car} defentity car
var cartimer
cartimer now!
car :tick 60 cartimer triggered if
:| car entity.dir @ E = if W else E then car entity.dir !
car try-move-entity |; JOB send
then
:touch pete say" What an old rustbucket.
Hasn't driven in years."
;entity
:noname :noname
player yield s" pete.jor" loadfile
car yield ; ' onload redefine
0 ;
' entities redefine
s" pete.map" load-map

BIN
game.prj

Binary file not shown.

BIN
input.jim Executable file

Binary file not shown.

32
input.jor Executable file
View file

@ -0,0 +1,32 @@
( K E Y B O A R D )
1 const ^ESC
28 const ^ENTER
29 const ^CTRL
51 const ^<
52 const ^>
56 const ^ALT
57 const ^SPACE
72 const ^UP
75 const ^LEFT
77 const ^RIGHT
80 const ^DOWN
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
: udelta ( u u -- u )
2dup u> if
swap -1 swap - + 1 +
else
swap -
then ;
( M O U S E )
var prevbutton
: tick-debounce
mousebuttons prevbutton ! ;
1 const MOUSEL
2 const MOUSER
: mousedown ( button -- bool ) mousebuttons & ;
: clicked ( button -- bool )
dup mousedown not swap
prevbutton @ & and ;

17
jorth.c
View file

@ -62,6 +62,20 @@ void f_latest() {
PUSHCP(LATEST); PUSHCP(LATEST);
} }
void f_latest_set() {
LATEST = TOP().p;
DROP(1);
}
void f_tasks() {
PUSHCP(TASKS);
}
void f_tasks_set() {
TASKS = TOP().p;
DROP(1);
}
void f_state() { void f_state() {
PUSHC(STATE); PUSHC(STATE);
} }
@ -948,6 +962,9 @@ void f_init() {
CDEF("here", f_here); CDEF("here", f_here);
CDEF("here!", f_here_set); CDEF("here!", f_here_set);
CDEF("latest", f_latest); CDEF("latest", f_latest);
CDEF("latest!", f_latest_set);
CDEF("tasks", f_tasks);
CDEF("tasks!", f_tasks_set);
CDEF("state", f_state); CDEF("state", f_state);
CDEF("'", f_quote); f_immediate(); CDEF("'", f_quote); f_immediate();
CDEF("`", f_revlookup); CDEF("`", f_revlookup);

32
keyboard.jor Executable file
View file

@ -0,0 +1,32 @@
( K E Y B O A R D )
1 const ^ESC
28 const ^ENTER
29 const ^CTRL
51 const ^<
52 const ^>
56 const ^ALT
57 const ^SPACE
72 const ^UP
75 const ^LEFT
77 const ^RIGHT
80 const ^DOWN
: wait-key ( k -- ) begin dup key-pressed not while suspend repeat drop ;
: udelta ( u u -- u )
2dup u> if
swap -1 swap - + 1 +
else
swap -
then ;
( M O U S E )
var prevbutton
: tick-debounce
mousebuttons prevbutton ! ;
1 const MOUSEL
2 const MOUSER
: mousedown ( button -- bool ) mousebuttons & ;
: clicked ( button -- bool )
dup mousedown not swap
prevbutton @ & and ;

BIN
map.jim Executable file

Binary file not shown.

66
map.jor Executable file
View file

@ -0,0 +1,66 @@
( M A P )
: +pos ( x1 y1 x2 y2 -- x y )
<rot + >rot + swap ;
var tileselect
8 const MAXTILE
: mouseworldpos mousepos scrollpos +pos ;
: world>tile 4 >> swap 4 >> swap ;
: mousetile mouseworldpos world>tile ;
: tile ( x y -- ptr ) mapsize drop * + map + ;
1 const WALKABLE
2 const DRIVABLE
array tileflags
( grass ) WALKABLE b,
( dirt ) WALKABLE b,
( water ) 0 b,
( pavement ) WALKABLE DRIVABLE | b,
( brick ) 0 b,
( forest ) 0 b,
( roof ) 0 b,
( brick ) 0 b,
( window ) 0 b,
: mapflag? ( x y flag -- b ) >rot tile b@ tileflags + b@ & ;
: walkable? ( x y -- b ) WALKABLE mapflag? ;
: drivable? ( x y -- b ) DRIVABLE mapflag? ;
: tick-mapedit
tileselect @
^< key-pressed if 1 - then
^> key-pressed if 1 + then
dup 0 < if drop MAXTILE then
dup MAXTILE > if drop 0 then
tileselect !
MOUSEL mousedown if tileselect @ mousetile tile b! then
MOUSER clicked if mouseworldpos world>tile swap . . then ;
: copy-mapseg ( neww oldw y -- )
r> ( oldw neww r: y )
2dup min >rot ( copyw neww oldw )
r@ * map + ( copyw neww src )
swap r< * map + ( copyw src dst )
swap <rot memmove ;
: resize-map ( neww newh -- )
swap mapsize r> ( newh neww oldw r: oldh )
2dup < if 1 r< else r< 1 - 0 then ( newh neww copyw ystart ylim )
for 2dup i copy-mapseg next
drop swap mapsize! ;
: save-map ( filename -- )
fdeactivate swap overwrite
mapsize swap fput fput
mapsize * map fwrite
factivate ;
: load-map ( filename -- )
fdeactivate swap open
fget fget
2dup * map fread
mapsize!
factivate ;

BIN
pete.jim Executable file

Binary file not shown.

24
pete.jor Executable file
View file

@ -0,0 +1,24 @@
( P E T E )
8 8 E ' {car} defentity car
var cartimer
car :tick 60 cartimer triggered if
:| car entity.dir @ E = if W else E then car entity.dir !
car try-move-entity |; JOB send
then
:touch pete say" What an old rustbucket.
Hasn't driven in years."
;entity
:noname
:|
player yield
car yield
0 |;
' entities redefine
cartimer now!
s" pete.map" load-map
; ' onload redefine

BIN
timer.jim Executable file

Binary file not shown.

37
timer.jor Executable file
View file

@ -0,0 +1,37 @@
( timer + lerping )
: clamp0 ( range val -- i )
2dup <= if drop else
dup 0 <= if drop drop 0 else
swap drop then then ;
: >ratio ( range value -- f )
over swap clamp0 swap />ratio ;
: <ratio ( range ratio -- v ) *<ratio ;
: >range ( start end -- start range ) over - ;
: <range ( start range -- start end ) over + ;
: lerpr ( start end ratio ) r> >range r< <ratio + ;
: lerpn ( start1 end1 start2 end2 val )
r> >range r< <rot - >ratio lerpr ;
: lerp ( start end duration start -- i )
ticks udelta ( start end duration delta )
>ratio lerpr ;
: triggered ( duration timer -- b )
dup r> @ ticks udelta ( duration delta )
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 +! ;
: move-to ( target speed p -- )
dup r> @ >rot ticks ( from to duration start )
begin
4dup lerp r@ !
<rot dup r@ @ != ( from duration start to !done )
while
>rot suspend
repeat rdrop drop drop drop drop ;
: sleep ( count -- )
ticks swap begin over ticks udelta over u< while suspend repeat drop drop ;