continue conversion to use generators

main
Jeremy Penner 2023-10-06 11:07:26 -04:00
parent 1f7e6ecb36
commit 2980900aa0
5 changed files with 53 additions and 55 deletions

View File

@ -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
: continue ' GOTO_ , dup cell - , ; immediate
: next ['] continue here swap ! ; immediate
:timm each t, EACH_ patchpt ;
: CONTINUE t, GOTO_ dup cell - w>t ;
: each ' EACH_ , >i 0 , ; immediate
: continue ' GOTO_ , i cell - , ; immediate
: next ['] continue here <i ! ; immediate
:timm each t, EACH_ patchpt >i ;
: 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 !
:| nextdrop get-next if idrop then 0 cancelled ! 0 swap |; >next ;
{ : break ' cancel , ['] continue ; immediate
:timm break t, cancel CONTINUE ; }
: >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 ;
@ -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 ;
: . i [ key 0 lit ] + draw-char ;
: .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 ;
: _pass-suspend rdrop :| ' cancel _resume |; _suspend ;
:yield pass _pass-suspend ;
:yield filter if _pass-suspend else <r 1+ >r then ;

BIN
swine.com

Binary file not shown.

View File

@ -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 -- )
>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 ;
:yield yield2 >i >i :| idrop idrop ' noop _resume |; _suspend ;
var neighbour-count
var neighbour-check
: 8-neighbours ( x y -- ) >arg >arg ((
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 ;
: count-neighbours ( x y cp -- c ) neighbour-check ! 0 neighbour-count !
' count-neighbour do-neighbour-squares neighbour-count @ ;
: neighbours ( p -- ) square-pos 8-neighbours
(( each i j valid-pos? if i j square-at map then next )) ;
: analyze-pos ( x y -- n ) ' mine? count-neighbours ;
: analyze-board iterboard each i square-pos analyze-pos i b!| next ;
: count-neighbours ( p cp -- n )
>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
if backtrack-square 1- idrop >i then ;
i visibly-empty? i backtrack-square backtrack? and
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 ( -- )
in-progress? if 0 iterboard each
i b@ dup FMINE & swap FREVEALED & or not if 1+ break then
next not if WON game-state b! then then ;
: won? ( -- f )
1 iterboard each i b@ FMINE FREVEALED | & not if not break then next ;
: check-win ( -- ) in-progress? if won? if WON game-state b! then then ;
: reveal-unflagged-neighbours? ( p -- )
dup square-pos count-surrounding-flags over squarecount =
if click square-pos ' reveal do-neighbour-squares else drop then ;
dup count-surrounding-flags over squarecount =
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 )
.| begin dup draw-square .| 1+ dup square-pos drop not until next-row ;
: draw-row ( p -- )
.| 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
drop draw-board-bottom ;
iterrows each i draw-row
i lastrow? not if draw-rowborder then
next draw-board-bottom ;
( general-purpose drawing )
dbg" general-purpose drawing"

Binary file not shown.

Binary file not shown.