generators, start converting swine meeper to use iteration

common.jrt

@@ -1,17 +1,18 @@
-import text.jrt
-import keys.jrt
-import random.jrt
-import file.jrt
-import task.jrt
-import timer.jrt
-import beep.jrt
-
 : !+ ( v p -- ) dup @ <rot + swap ! ;
 : b!+ ( v p -- ) dup b@ <rot + swap b! ;
 : b!| ( f p -- ) dup b@ <rot | swap b! ;
 : b!^ ( f p -- ) dup b@ <rot ^ swap b! ;
 : ~ 0xffff ^ ;
 
+import text.jrt
+import keys.jrt
+import random.jrt
+import file.jrt
+import task.jrt
+import iter.jrt
+import timer.jrt
+import beep.jrt
+
 : !save ( v p -- ) openself >r dup >rot ! 
   r@ if dup 0x100 - r@ seekto cell swap r@ fwrite <r close 
      else rdrop drop then ;

defs.jrt

@@ -2,6 +2,7 @@
 : 2drop drop drop ;
 
 : @! ( newval v -- oldval ) dup @ >rot ! ;
+: !+ ( v p -- ) dup @ <rot + swap ! ;
 
 : expile state if , else execute then ;
 : ['] word lookup drop , ; immediate

iter.jrt

@@ -1,4 +1,4 @@
-( iteration control stack
+( iteration control stacks
   We create two new stacks - a small stack to hold the "current" value
   of the loop, or the "i" stack, and a larger stack to hold any extra 
   state, as well as the cp of a word that moves to the next value, which
@@ -9,10 +9,10 @@
   the iter-next stack which calls out to the previous one. )
 
 uservar itop
-4 cells userallot
+8 cells userallot
 { userhere @ } const itop-init
 uservar nexttop
-16 cells userallot
+24 cells userallot
 { userhere @ } const nexttop-init
 
 ' task-init :chain 
@@ -92,22 +92,25 @@ nexttop :push >next
   always more convenient to check the flag first when consuming the result. )
 : get-next ( -- c f ) 0 nextpeek execute swap ;
 : n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ;
-: EACH_ <r get-next if drop cell + else n-nextdrop @ then >r ;
+: iteration get-next if drop 1 else n-nextdrop 0 then ;
+: EACH_ <r iteration if cell + else @ then >r ;
 
 { ( Because we dereference pointers on the return stack, we must run this 
     from the caller's segment. Copy the definition into the host segment. )
-  : EACH_ <r get-next if drop cell + else n-nextdrop @ then >r ;
+  : EACH_ <r iteration if cell + else @ then >r ;
   : each ' EACH_ , here 0 , ; immediate
   : continue ' GOTO_ , dup cell - , ; immediate
-  : more ['] continue here swap ! ; immediate
+  : next ['] continue here swap ! ; immediate
   :timm each t, EACH_ patchpt ;
   : CONTINUE t, GOTO_ dup cell - w>t ;
   :timm continue CONTINUE ;
-  :timm more CONTINUE patch!t ; }
+  :timm next CONTINUE patch!t ; }
 
 0 var, cancelled
 : cancel 1 cancelled ! 
   :| nextdrop get-next if idrop then 0 cancelled ! 0 swap |; >next ;
+{ : break ' cancel , ['] continue ; immediate
+  :timm break t, cancel CONTINUE ; }
 
 : nothing :| 0 1 |; >next ;
 : single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ;
@@ -118,49 +121,52 @@ nexttop :push >next
 : for ( start lim -- ) >next 1- >i :| 1 +for? 2 |; >next ;
 : for+ ( start lim inc -- )
   >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ;
+: chars ( st -- ) 1- >i :| <i 1+ dup b@ if >i 1 else drop 0 then 1 |; >next ;
 
-( Mapping is complex because iterators use the i-stack to store their own
+:asm tail ( TODO: support CREATE words )
-  state - when asking for the next value, we must restore the previous value.
+  LODSW
-  However, we do not want to touch the i-stack until the iterator has run,
+  MOV BX AX
-  in case it is an empty iterator with no values. We want to handle this
+  INC BX INC BX
-  using a minimum of next-stack space; ideally never more than two slots. 
+  MOV SI BX
+  NEXT
 
-  The user defines a mapping iterator by defining a word or no-name that
+: gen-save-args ( extra-args... extra-arg-count -- )
-  passes an anonymous function to "map" and returning. "map" must assume that
+  begin dup while swap >next 1- repeat drop ;
-  the current i value sits below the mapper on the next-stack and
+: gen-save ( 0 0 extra-args... extra-arg-count -- 1 cnext ) 
-  the iterator to remap sits below that. 
+  >r r@ gen-save-args <r 2 + >rot drop drop 1 swap ;
+: gen-restore ( arg-count -- args... )
+  begin dup while <next swap 1- repeat drop ;
 
-  "initial-map" assumes a mapper is below it on the stack with no initial 
+: cancel-now cancel iteration drop ;
-  i value, and the iterator to remap sits below that. It queries the iterator
+: _resume ( cpcancel -- c f args... )
-  to ensure it's not empty, and then sets up the environment to allow the
+  nextdrop 0 0 <rot 
-  mapper to continue working. )
+  cancelled @ if <next ub@ n-nextdrop execute rdrop return then
+  drop <next dup 1+ >r rswap ub@ gen-restore ;
+: _suspend ( cpresume -- ) 
+  rswap r@ ub@ swap >r gen-save <r <r >next >next ;
 
-: initial-map ( -- f c )
+: GENSTART_ <r >next :| ' noop _resume |; >next ;
-  nextdrop <next get-next if ( cpnext c )
-    ( inject a fake iterator that just returns the top i value so we can
-      safely call get-next again from the mapper )
-    swap :| 1 1 |; >next i >next >next get-next drop drop
-    <next <next nextdrop >next >next ( remove the fake iterator )
-    2 + 1 swap ( add mapper to count and return success )
-  else drop drop 0 0 then ;
 
-: map ( cp -- f c ) 
+{ var gen-arg-count 
-  <next swap <next idrop >i ( cpnext cp: restore i to previous value )
+  :timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
-  get-next if ( cpnext cp c )
+  :timm )) t|; t, execute 0 gen-arg-count ! ;
-       >rot i >next <i swap execute >i >next 2 + 1 swap
+  : +arg  1 gen-arg-count !+ ; :timm +arg +arg ;
-  else >rot drop drop 0 swap then ;
+  : -arg -1 gen-arg-count !+ ; :timm -arg -arg ;
+  :timm >arg t, >next +arg ;
+  : :yield } create immediate target , startcolon 
+           does> @ w>t gen-arg-count @ >t ; }
 
-: >map ( mapper -- ) >next ' initial-map >next ;
+:yield yield0 :| ' noop _resume |; _suspend ;
+:yield yield  >i :| ' idrop _resume idrop |; _suspend ;
+:yield yield> >i :| ' idrop _resume <i |; _suspend ;
+:yield map    <i >next >i :| :| idrop <next >i cancel-now |; 
+                             _resume idrop <next >i |; _suspend 1+ ;
+:yield filter if :| ' cancel-now _resume |; _suspend else <r 1+ >r then ;
 
-: filter ( cp -- f c )
+: . i [ key 0 lit ] + draw-char ;
-  >r <next begin get-next ( cpnext c f )
+: .all each i . next ;
-    if i r@ execute
+: .first each i . break i . next ;
-      if swap >next 1 swap 1+ rdrop return then ( filter hit -- f c )
+: multiple-of >arg (( each dup i swap % not filter next drop )) ;
-      drop ( cpnext )
+: increased >arg (( each dup i + map next drop )) ;
-    else ( no more items )
+: even+ 2 multiple-of increased ;
-      swap drop 0 swap rdrop return
-    then again ;
-
-: .all each i [ key 0 lit ] + draw-char more ;
-: doubled :| ' 2* map |; >map ;
 

swine.jrt

@@ -46,10 +46,10 @@ array board maxw maxh * allot
 : rand-mine ( -- )
   begin rand boardw @ % rand boardh @ % place-mine until ;
 
-: reset-board
+: iterboard board board-lim for ;
-  board begin dup board-lim < while 0 over b! 1+ repeat drop ;
+: reset-board iterboard each 0 i b! next ;
-: populate-board
+: populate-board minecount @ times each rand-mine next ;
-  minecount @ begin rand-mine 1- dup not until drop ;
+
 : mine? ( p -- f )       b@ FMINE & ;
 : flag? ( p -- f )       b@ FFLAG & ;
 : revealed? ( p -- f )   b@ FREVEALED & ;
@@ -75,9 +75,7 @@ var neighbour-check
   ' count-neighbour do-neighbour-squares neighbour-count @ ;
 
 : analyze-pos ( x y -- n ) ' mine? count-neighbours ;
-: analyze-board
+: analyze-board iterboard each i square-pos analyze-pos i b!| next ;
-  board begin dup board-lim < while 
-    dup square-pos analyze-pos over b@ | over b! 1+ repeat drop ;
 
 : count-surrounding-flags ( x y -- n ) ' flag? count-neighbours ;
 
@@ -85,7 +83,7 @@ var neighbour-check
   reset-board populate-board analyze-board ;
 
 : lose LOST game-state b!
-  board begin dup board-lim < while FREVEALED over b!| 1+ repeat drop ;
+  iterboard each FREVEALED i b!| next ;
 
 : reveal ( p -- ) dup flag? not if 
     dup mine? if lose then FREVEALED swap b!|
@@ -95,21 +93,19 @@ var neighbour-check
 : backtrack-square ( p -- p ) boardw @ - 1- dup board < if drop board then ;
 : backtrack? ( p -- f ) 
   dup revealed? over 1+ revealed? and swap 2 + revealed? and not ;
-: autoreveal-backtrack ( p -- p )
+: autoreveal-backtrack ( -- )
-  dup visibly-empty? over backtrack-square backtrack? and
+  i visibly-empty? over backtrack-square backtrack? and
-  if backtrack-square 1- then ;
+  if backtrack-square 1- idrop >i then ;
 : autoreveal ( -- )
-  board begin dup board-lim < while
+  iterboard each i revealed? not if
-    dup revealed? not if
+    i square-pos ' visibly-empty? count-neighbours
-      dup square-pos ' visibly-empty? count-neighbours
+    if i reveal autoreveal-backtrack then 
-      if dup reveal autoreveal-backtrack then then
+  then next ;
-    1+ repeat drop ;
 
 : check-win ( -- )
-  in-progress? if
+  in-progress? if 0 iterboard each 
-    0 board begin dup board-lim < while
+    i b@ dup FMINE & swap FREVEALED & or not if 1+ break then
-      dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then
+  next not if WON game-state b! then then ;
-      1+ repeat drop not if WON game-state b! then then ;
 
 : reveal-unflagged-neighbours? ( p -- )
   dup square-pos count-surrounding-flags over squarecount =
@@ -167,7 +163,7 @@ dbg" board drawing"
 : next-row ( -- ) nextline boardx! ;
 
 : draw-border ( end mid -- ) 
-  boardw @ begin .- 1- dup while over execute repeat drop drop execute next-row ;
+  boardw @ times each .- dup execute next execute next-row ;
 : draw-board-top tl ' tr ' dT draw-border ;
 : draw-board-bottom bl ' br ' uT draw-border ;
 : draw-rowborder rT ' lT ' .+ draw-border ;
@@ -190,7 +186,7 @@ dbg" general-purpose drawing"
 : spacer ( st -- ) sp drawdot? if dot else sp then sp ;
 
 : draw-spaced-text ( st -- )
-  begin dup b@ dup while draw-char dup spacer 1+ repeat drop drop ;
+  chars each i b@ draw-char i spacer next ;
 
 ( menu subsystem )
 dbg" menu"
@@ -214,9 +210,9 @@ var current-menu
 : draw-option ( iopt -- ) white fg! menu-option @ draw-text ;
 : draw-menu
   30 9 textxy! 
-  textx 0 begin dup menu-size < while
+  textx 0 menu-size for each 
-    dup draw-selection dup draw-option 1+ nextline over textx! repeat 
+    i draw-selection i draw-option nextline dup textx! 
-  drop drop ;
+  next ;
 
 : await-menu
   wait-key key>scan 

zipoff.jrt

@@ -101,8 +101,10 @@ s" coredefs.jrt" loadfile
 :timm s" state if t, INLINEDATA_ patchpt t", patch!t else target t", then ;
 
 : startcolon t& $DOCOLON w>t ] ;
-:timm :| t, INLINEDATA_ patchpt startcolon ;
+: t:| t, INLINEDATA_ patchpt startcolon ;
-:timm |; t, return patch!t ;
+: t|; t, return patch!t ;
+:timm :| t:| ;
+:timm |; t|; ;
 
 :noname DEF startcolon ;
 :timm : [ dup , ] ; :timm :t [ , ] ;