generators, start converting swine meeper to use iteration

This commit is contained in:
Jeremy Penner 2023-10-03 20:59:18 -04:00
parent ca38564024
commit 1f7e6ecb36
9 changed files with 87 additions and 81 deletions

Binary file not shown.

View file

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

View file

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

View file

@ -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
state - when asking for the next value, we must restore the previous value.
However, we do not want to touch the i-stack until the iterator has run,
in case it is an empty iterator with no values. We want to handle this
using a minimum of next-stack space; ideally never more than two slots.
:asm tail ( TODO: support CREATE words )
LODSW
MOV BX AX
INC BX INC BX
MOV SI BX
NEXT
The user defines a mapping iterator by defining a word or no-name that
passes an anonymous function to "map" and returning. "map" must assume that
the current i value sits below the mapper on the next-stack and
the iterator to remap sits below that.
: gen-save-args ( extra-args... extra-arg-count -- )
begin dup while swap >next 1- repeat drop ;
: gen-save ( 0 0 extra-args... extra-arg-count -- 1 cnext )
>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
i value, and the iterator to remap sits below that. It queries the iterator
to ensure it's not empty, and then sets up the environment to allow the
mapper to continue working. )
: cancel-now cancel iteration drop ;
: _resume ( cpcancel -- c f args... )
nextdrop 0 0 <rot
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 )
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 ;
: GENSTART_ <r >next :| ' noop _resume |; >next ;
: map ( cp -- f c )
<next swap <next idrop >i ( cpnext cp: restore i to previous value )
get-next if ( cpnext cp c )
>rot i >next <i swap execute >i >next 2 + 1 swap
else >rot drop drop 0 swap then ;
{ var gen-arg-count
:timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
:timm )) t|; t, execute 0 gen-arg-count ! ;
: +arg 1 gen-arg-count !+ ; :timm +arg +arg ;
: -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 )
>r <next begin get-next ( cpnext c f )
if i r@ execute
if swap >next 1 swap 1+ rdrop return then ( filter hit -- f c )
drop ( cpnext )
else ( no more items )
swap drop 0 swap rdrop return
then again ;
: .all each i [ key 0 lit ] + draw-char more ;
: doubled :| ' 2* map |; >map ;
: . 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 ;

BIN
swine.com

Binary file not shown.

View file

@ -46,10 +46,10 @@ array board maxw maxh * allot
: rand-mine ( -- )
begin rand boardw @ % rand boardh @ % place-mine until ;
: reset-board
board begin dup board-lim < while 0 over b! 1+ repeat drop ;
: populate-board
minecount @ begin rand-mine 1- dup not until drop ;
: iterboard board board-lim for ;
: reset-board iterboard each 0 i b! next ;
: populate-board minecount @ times each rand-mine next ;
: 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
board begin dup board-lim < while
dup square-pos analyze-pos over b@ | over b! 1+ repeat drop ;
: analyze-board iterboard each i square-pos analyze-pos i b!| next ;
: 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 )
dup visibly-empty? over backtrack-square backtrack? and
if backtrack-square 1- then ;
: autoreveal-backtrack ( -- )
i visibly-empty? over backtrack-square backtrack? and
if backtrack-square 1- idrop >i then ;
: autoreveal ( -- )
board begin dup board-lim < while
dup revealed? not if
dup square-pos ' visibly-empty? count-neighbours
if dup reveal autoreveal-backtrack then then
1+ repeat drop ;
iterboard each i revealed? not if
i square-pos ' visibly-empty? count-neighbours
if i reveal autoreveal-backtrack then
then next ;
: check-win ( -- )
in-progress? if
0 board begin dup board-lim < while
dup b@ dup FMINE & swap FREVEALED & or not if swap 1+ swap then
1+ repeat drop not if WON game-state b! then then ;
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 ;
: 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
dup draw-selection dup draw-option 1+ nextline over textx! repeat
drop drop ;
textx 0 menu-size for each
i draw-selection i draw-option nextline dup textx!
next ;
: await-menu
wait-key key>scan

Binary file not shown.

View file

@ -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 ;
:timm |; t, return patch!t ;
: t:| t, INLINEDATA_ patchpt startcolon ;
: t|; t, return patch!t ;
:timm :| t:| ;
:timm |; t|; ;
:noname DEF startcolon ;
:timm : [ dup , ] ; :timm :t [ , ] ;

Binary file not shown.