continue conversion to use generators

iter.jrt

@@ -71,7 +71,7 @@ nexttop :push >next
   stack by this word. For simple iterators this will be 1, for the space
   the iterator word takes. If "more" is 0, this number of items will be 
   dropped. This is always returned even if there are more items to iterate 
-  over, in order to support efficient cancellation. "cancel" will push a word 
+  over, in order to support efficient cancellation. ">cancel" will push a word 
   onto the next-stack that will query the iterator below it to determine how 
   many items need to be dropped. It will drop one item from the i-stack if the
   iterator indicates that there are more items.
@@ -98,19 +98,19 @@ nexttop :push >next
 { ( 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 iteration if cell + else @ then >r ;
-  : each ' EACH_ , here 0 , ; immediate
+  : each ' EACH_ , >i 0 , ; immediate
-  : continue ' GOTO_ , dup cell - , ; immediate
+  : continue ' GOTO_ , i cell - , ; immediate
-  : next ['] continue here swap ! ; immediate
+  : next ['] continue here <i ! ; immediate
-  :timm each t, EACH_ patchpt ;
+  :timm each t, EACH_ patchpt >i ;
-  : CONTINUE t, GOTO_ dup cell - w>t ;
+  : CONTINUE t, GOTO_ i cell - w>t ;
   :timm continue CONTINUE ;
-  :timm next CONTINUE patch!t ; }
+  :timm next CONTINUE <i patch!t ; }
 
 0 var, cancelled
-: cancel 1 cancelled ! 
+: >cancel :| 1 cancelled ! nextdrop get-next if idrop then 
-  :| nextdrop get-next if idrop then 0 cancelled ! 0 swap |; >next ;
+             0 cancelled ! 0 swap |; >next ;
-{ : break ' cancel , ['] continue ; immediate
+{ : break ' >cancel , ['] continue ; immediate
-  :timm break t, cancel CONTINUE ; }
+  :timm break t, >cancel CONTINUE ; }
 
 : nothing :| 0 1 |; >next ;
 : single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ;
@@ -137,7 +137,7 @@ nexttop :push >next
 : gen-restore ( arg-count -- args... )
   begin dup while <next swap 1- repeat drop ;
 
-: cancel-now cancel iteration drop ;
+: cancel >cancel iteration drop ;
 : _resume ( cpcancel -- c f args... )
   nextdrop 0 0 <rot 
   cancelled @ if <next ub@ n-nextdrop execute rdrop return then
@@ -159,14 +159,9 @@ nexttop :push >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 |; 
+:yield map    <i >next >i :| :| idrop <next >i cancel |; 
                              _resume idrop <next >i |; _suspend 1+ ;
-:yield filter if :| ' cancel-now _resume |; _suspend else <r 1+ >r then ;
+: _pass-suspend rdrop :| ' cancel _resume |; _suspend ;
-
+:yield pass _pass-suspend ;
-: . i [ key 0 lit ] + draw-char ;
+:yield filter if _pass-suspend else <r 1+ >r then ;
-: .all each i . next ;
-: .first each i . break i . next ;
-: multiple-of >arg (( each dup i swap % not filter next drop )) ;
-: increased >arg (( each dup i + map next drop )) ;
-: even+ 2 multiple-of increased ;
 

swine.jrt

@@ -1,5 +1,7 @@
 dbg" start"
 
+: digit ( n -- ) [ key 0 lit ] + draw-char ;
+
 : meep 2000 5 -80 slide ;
 : meeeep 2000 16 -50 slide ;
 : moop 1600 5 80 slide ;
@@ -47,6 +49,8 @@ array board maxw maxh * allot
   begin rand boardw @ % rand boardh @ % place-mine until ;
 
 : iterboard board board-lim for ;
+: iterrows board board-lim boardw @ for+ ;
+: lastrow? ( p -- f ) board-lim boardw @ - >= ;
 : reset-board iterboard each 0 i b! next ;
 : populate-board minecount @ times each rand-mine next ;
 
@@ -55,29 +59,28 @@ array board maxw maxh * allot
 : revealed? ( p -- f )   b@ FREVEALED & ;
 : squarecount ( p -- c ) b@ NEIGHBOUR-MASK & ;
 
-: do-at ( x y cp -- )
+:yield yield2 >i >i :| idrop idrop ' noop _resume |; _suspend ;
-  >rot 2dup valid-pos? if square-at swap execute else drop drop drop then ;
-: do-neighbour-squares ( x y cp -- )
-  >r over 1- over 1- r@ do-at
-     over 1- over    r@ do-at
-     over 1- over 1+ r@ do-at
-     over    over 1- r@ do-at
-     over    over 1+ r@ do-at
-     over 1+ over 1- r@ do-at
-     over 1+ over    r@ do-at
-     swap 1+ swap 1+ <r do-at ;
 
-var neighbour-count
+: 8-neighbours ( x y -- ) >arg >arg (( 
-var neighbour-check
+  over 1- over 1- yield2
+  over 1- over    yield2
+  over 1- over 1+ yield2
+  over    over 1- yield2
+  over    over 1+ yield2
+  over 1+ over 1- yield2
+  over 1+ over    yield2 -arg -arg
+  swap 1+ swap 1+ yield2 )) ;
 
-: count-neighbour neighbour-check @ execute if 1 neighbour-count !+ then ;
+: neighbours ( p -- ) square-pos 8-neighbours 
-: count-neighbours ( x y cp -- c ) neighbour-check ! 0 neighbour-count ! 
+  (( each i j valid-pos? if i j square-at map then next )) ;
-  ' count-neighbour do-neighbour-squares neighbour-count @ ;
 
-: analyze-pos ( x y -- n ) ' mine? count-neighbours ;
+: count-neighbours ( p cp -- n ) 
-: analyze-board iterboard each i square-pos analyze-pos i b!| next ;
+  >r neighbours 0 each i r@ execute if 1+ then next rdrop ;
 
-: count-surrounding-flags ( x y -- n ) ' flag? count-neighbours ;
+: analyze-square ( p -- n ) ' mine? count-neighbours ;
+: analyze-board iterboard each i analyze-square i b!| next ;
+
+: count-surrounding-flags ( p -- n ) ' flag? count-neighbours ;
 
 : init-board ( -- )
   reset-board populate-board analyze-board ;
@@ -94,22 +97,21 @@ var neighbour-check
 : backtrack? ( p -- f ) 
   dup revealed? over 1+ revealed? and swap 2 + revealed? and not ;
 : autoreveal-backtrack ( -- )
-  i visibly-empty? over backtrack-square backtrack? and
+  i visibly-empty? i backtrack-square backtrack? and
-  if backtrack-square 1- idrop >i then ;
+  if i backtrack-square 1- idrop >i then ;
 : autoreveal ( -- )
   iterboard each i revealed? not if
-    i square-pos ' visibly-empty? count-neighbours
+    i ' visibly-empty? count-neighbours
     if i reveal autoreveal-backtrack then 
   then next ;
 
-: check-win ( -- )
+: won? ( -- f )
-  in-progress? if 0 iterboard each 
+  1 iterboard each i b@ FMINE FREVEALED | & not if not break then next ;
-    i b@ dup FMINE & swap FREVEALED & or not if 1+ break then
+: check-win ( -- ) in-progress? if won? if WON game-state b! then then ;
-  next not if WON game-state b! then then ;
 
 : reveal-unflagged-neighbours? ( p -- )
-  dup square-pos count-surrounding-flags over squarecount =
+  dup count-surrounding-flags over squarecount =
-  if click square-pos ' reveal do-neighbour-squares else drop then ;
+  if click neighbours each i reveal next else drop then ;
 : reveal-at square-at dup revealed? 
   if reveal-unflagged-neighbours? else reveal click then 
   autoreveal check-win ;
@@ -145,7 +147,7 @@ win31
 dbg" board drawing"
 : draw-neighbour-count ( b -- )
   NEIGHBOUR-MASK & dup col-count 
-  dup if [ key 0 lit ] + else drop [ key   lit ] then draw-char ;
+  dup if digit else drop [ key   lit ] draw-char then ;
 : draw-flag ( -- ) col-flag 0x0d draw-char ;
 : draw-mine ( -- ) col-mine 0xec draw-char ;
 : draw-block ( -- ) col-block 0xb1 draw-char ;
@@ -163,16 +165,17 @@ dbg" board drawing"
 : next-row ( -- ) nextline boardx! ;
 
 : draw-border ( end mid -- ) 
-  boardw @ times each .- dup execute next execute next-row ;
+  boardw @ times each .- i if dup execute then next drop 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 ;
-: draw-row ( p -- p )
+: draw-row ( p -- )
-  .| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
+  .| boardw @ times each dup draw-square 1+ .| next drop next-row ;
 : draw-board ( -- ) 0 boxstyle!
   col-grid col-bg boardx! boardy! draw-board-top
-  board begin draw-row dup square-pos valid-pos? while draw-rowborder repeat
+  iterrows each i draw-row 
-  drop draw-board-bottom ;
+    i lastrow? not if draw-rowborder then 
+  next draw-board-bottom ;
 
 ( general-purpose drawing )
 dbg" general-purpose drawing"