diff --git a/iter.jrt b/iter.jrt index 339b67a..ab0d32c 100755 --- a/iter.jrt +++ b/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 ; - : 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 ; + : CONTINUE t, GOTO_ i cell - w>t ; :timm continue CONTINUE ; - :timm next CONTINUE patch!t ; } + :timm next CONTINUE 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 cancel iteration drop ; : _resume ( cpcancel -- c f args... ) nextdrop 0 0 next :yield yield0 :| ' noop _resume |; _suspend ; :yield yield >i :| ' idrop _resume idrop |; _suspend ; :yield yield> >i :| ' idrop _resume next >i :| :| idrop i cancel-now |; +:yield map next >i :| :| idrop i cancel |; _resume idrop i |; _suspend 1+ ; -:yield filter if :| ' cancel-now _resume |; _suspend else 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 then ; diff --git a/swine.com b/swine.com index 311932a..bf50f07 100755 Binary files a/swine.com and b/swine.com differ diff --git a/swine.jrt b/swine.jrt index 7a961c7..20c0971 100755 --- a/swine.jrt +++ b/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 -- ) - >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+ 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" diff --git a/zipoff.com b/zipoff.com index c67968a..a01d020 100755 Binary files a/zipoff.com and b/zipoff.com differ diff --git a/zipstub.seg b/zipstub.seg index 36ac220..2d8a9c4 100755 Binary files a/zipstub.seg and b/zipstub.seg differ