diff --git a/assemble.com b/assemble.com index c1230ac..2fda6b6 100755 Binary files a/assemble.com and b/assemble.com differ diff --git a/common.jrt b/common.jrt index e6de62d..5a64081 100755 --- a/common.jrt +++ b/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 @ r dup >rot ! r@ if dup 0x100 - r@ seekto cell swap r@ fwrite rot ! ; +: !+ ( v p -- ) dup @ 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 ; +: iteration get-next if drop 1 else n-nextdrop 0 then ; +: EACH_ 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 ; + : EACH_ 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 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. - - 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. - - "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. ) +:asm tail ( TODO: support CREATE words ) + LODSW + MOV BX AX + INC BX INC BX + MOV SI BX + NEXT -: initial-map ( -- f c ) - nextdrop next i >next >next get-next drop drop - next >next ( remove the fake iterator ) - 2 + 1 swap ( add mapper to count and return success ) - else drop drop 0 0 then ; +: 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 rot drop drop 1 swap ; +: gen-restore ( arg-count -- args... ) + begin dup while i ( cpnext cp: restore i to previous value ) - get-next if ( cpnext cp c ) - >rot i >next i >next 2 + 1 swap - else >rot drop drop 0 swap then ; +: cancel-now cancel iteration drop ; +: _resume ( cpcancel -- c f args... ) + nextdrop 0 0 r rswap ub@ gen-restore ; +: _suspend ( cpresume -- ) + rswap r@ ub@ swap >r gen-save next >next ; -: >map ( mapper -- ) >next ' initial-map >next ; +: GENSTART_ next :| ' noop _resume |; >next ; -: filter ( cp -- f c ) - >r 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 ; +{ 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 ; } -: .all each i [ key 0 lit ] + draw-char more ; -: doubled :| ' 2* map |; >map ; +:yield yield0 :| ' noop _resume |; _suspend ; +:yield yield >i :| ' idrop _resume idrop |; _suspend ; +:yield yield> >i :| ' idrop _resume next >i :| :| idrop i cancel-now |; + _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 ; diff --git a/swine.com b/swine.com index 1c3c249..311932a 100755 Binary files a/swine.com and b/swine.com differ diff --git a/swine.jrt b/swine.jrt index bbe4b3d..7a961c7 100755 --- a/swine.jrt +++ b/swine.jrt @@ -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 diff --git a/zipoff.com b/zipoff.com index f66d5cf..c67968a 100755 Binary files a/zipoff.com and b/zipoff.com differ diff --git a/zipoff.jrt b/zipoff.jrt index 6ea7819..1e489df 100755 --- a/zipoff.jrt +++ b/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 ; -: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 [ , ] ; diff --git a/zipstub.seg b/zipstub.seg index 2ecde3c..36ac220 100755 Binary files a/zipstub.seg and b/zipstub.seg differ