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

boot.jor

@@ -49,17 +49,44 @@ key " const '"'
 : load-input swap-input r> r> interpreter r< r< swap-input ;
 : 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 ;
 
+: loadjor fdeactivate swap interpretjor postload factivate ;
+
 : 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
+    dup here swap interpretjor
-    swap imagefilename overwrite saveimage close
+    swap imagefilename overwrite saveimage close postload
   else drop then factivate ;

defs.jor

@@ -9,8 +9,6 @@
 : 2= ( a b c d -- a=c&b=d )
   r> <rot = swap r< = and ;
 
-: noop ;
-
 : ~ -1 ^ ;
 : f! ( b v flag -- )
   r> dup @ ( b v val r: flag )
@@ -26,9 +24,6 @@
 : :| inline| $DOCOLON , ; immediate
 : |; ' ret , |inline ; immediate
 
-: defer word new-word $DODEFERRED , ' noop , ;
-: redefine ( cp cpdeferred ) cell + ! ;
-
 : array word new-word $DOVAR , ;
 : create word new-word $DOCREATE , 0 , ;
 
@@ -56,6 +51,8 @@
 : dobreak yield 0 ;
 : break ' rdrop , ' dobreak , ; immediate
 
+: links begin yield @ dup not until ;
+
 : min ( 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-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 -- )
   over task-ip !
   dup task-stack over task-sp !
@@ -89,11 +98,16 @@
   ' ret ,
 ; immediate
 
-: send ( val task -- )
+: try-send ( val task -- b )
+  mailbox dup @ if drop drop 0 else ! 1 then ;
+
+: wait-send ( val task -- )
   mailbox
   begin dup @ while suspend repeat ( wait for empty mailbox )
   ! ;
 
+: send ( val task -- ) try-send drop ;
+
 : receive ( -- val )
   running mailbox
   begin dup @ not while suspend repeat ( wait for mail )

entity.jor

@@ -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}

footer.jor

@@ -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
+

game.jor

@@ -7,275 +7,16 @@ blah
 task const 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 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 )
 var MODE-MOVE
@@ -294,6 +35,7 @@ JOB listen-for-jobs
 
 ( T I C K )
 defer entities
+:noname 0 ; ' entities redefine
 
 : entity-at ( x y -- entity|0 )
   0 >rot
@@ -371,8 +113,6 @@ player :tick
 
 ( S T U F F )
 : hello-world
-  mary say" Hello, world!"
-  say" How are you\today?"
   player.state DRIVING f@ not player.state DRIVING f! ;
 
 : mode-move
@@ -404,24 +144,6 @@ player :tick
 MODE-MOVE @ ' tick 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
-  player yield
+  s" pete.jor" loadfile
-  car yield
+; ' onload redefine
-  0 ;
-' entities redefine
-
-s" pete.map" load-map

input.jor

@@ -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 ;

jorth.c

@@ -62,6 +62,20 @@ void f_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() {
   PUSHC(STATE);
 }
@@ -948,6 +962,9 @@ void f_init() {
   CDEF("here", f_here);
   CDEF("here!", f_here_set);
   CDEF("latest", f_latest);
+  CDEF("latest!", f_latest_set);
+  CDEF("tasks", f_tasks);
+  CDEF("tasks!", f_tasks_set);
   CDEF("state", f_state);
   CDEF("'", f_quote); f_immediate();
   CDEF("`", f_revlookup);

keyboard.jor

@@ -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 ;

map.jor

@@ -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 ;

pete.jor

@@ -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
+

timer.jor

@@ -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 ;