diff --git a/asm.jrt b/asm.jrt index 7fd4d3a..8173b3d 100755 --- a/asm.jrt +++ b/asm.jrt @@ -54,16 +54,16 @@ array oparg2 3 cells allot : # oparg-imm! oparg-complete! ; : @[ 0 oparg-mem! ; -: @] -1 oparg-base ! oparg-complete! ; +: @] oparg-val ! -1 oparg-base ! oparg-complete! ; : unexpected-addr ( addr -- ) drop s" unexpected address" operror ; : @+ ( disp -- ) opargs-remaining @ if - oparg-unset? if oparg-mem! @] return then + oparg-unset? if @[ @] return then oparg-mem? if oparg-val ! return then then drop unexpected-addr ; -: @FAR ( offset segment -- ) 4 set-oparg! oparg-base ! ; +: @FAR ( offset segment -- ) 4 set-oparg! oparg-base ! oparg-complete! ; : oparg-faraddr? oparg-type @ 4 = ; array patchtable 10 2 cells * allot @@ -76,7 +76,7 @@ array patchtable 10 2 cells * allot : patch-r8 ( tptr targ -- ) over 1 + - swap b!t ; : apply-patch ( tptr type -- ) target swap execute ; -: @> ( patchid -- ) 0x13 set-oparg! @] ; +: @> ( patchid -- ) dup 0x13 set-oparg! @] ; : <: ( patchid -- ) find-patch dup @ swap cell + @ swap apply-patch ; : L: here create wordname lastlabel ! 0 , target here cell - ! does> @ @+ ; diff --git a/assemble.com b/assemble.com index 04d17eb..c1230ac 100755 Binary files a/assemble.com and b/assemble.com differ diff --git a/beep.jrt b/beep.jrt index a6ca975..3da4e26 100755 --- a/beep.jrt +++ b/beep.jrt @@ -1,5 +1,3 @@ -import timer.jrt - :asm >spk ( div -- ) MOV AL 0xb6 # OUT 0x43 # AL @@ -12,6 +10,14 @@ import timer.jrt OUT 0x61 # AL NEXT +:asm freq>div ( f -- d ) + MOV AX 0x34df # + MOV DX 0x12 # + POP BX + DIV BX + PUSH AX + NEXT + :asm silence ( -- ) IN AL 0x61 # AND AL 0xfc # @@ -19,9 +25,11 @@ import timer.jrt NEXT : slide ( div count + -- ) - >r begin over >spk 1 sleep-csec swap r@ + swap 1- dup not until + >r begin over >spk 2 sleep-csec swap r@ + swap 1- dup not until rdrop drop drop silence ; : boop ( div count -- ) swap >spk sleep-csec silence ; : noise ( count -- ) begin rand >spk 1 sleep-csec 1- dup not until drop silence ; +: arp ( d1 d2 count -- ) + begin >rot dup 1 boop swap div , 1336 freq>div , 1477 freq>div , +array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div , + +( 0 1 2 + 3 4 5 + 6 7 8 + -3 -1 -2 ) + +-2 const D* +-1 const D# + +: dtmf ( digit -- f1 f2 ) 1- + dup 0 < if abs 3 % 3 swap else 3 /mod then + cells dtmf-col + @ swap cells dtmf-row + @ ; +: dial ( digit -- ) dtmf 20 arp 7 sleep-csec ; +: dialtone [ 350 freq>div lit 440 freq>div lit ] 200 arp ; + diff --git a/iter.jrt b/iter.jrt new file mode 100755 index 0000000..67523a6 --- /dev/null +++ b/iter.jrt @@ -0,0 +1,166 @@ +( iteration control stack + 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 + we call the "next" stack. + With these two new stacks, we can create a generic loop construct for + iterating over streaming values. Not only that, but those values can be + arbitrarily filtered and transformed simply by pushing a new value onto + the iter-next stack which calls out to the previous one. ) + +uservar itop +4 cells userallot +{ userhere @ } const itop-init +uservar nexttop +16 cells userallot +{ userhere @ } const nexttop-init + +' task-init :chain + >r itop-init itop r@ !far + nexttop-init nexttop r@ !far r + ( i -- v ) + POP AX + SHL AX 1 # + MOV BX @[ SS: r + MOV BX @[ SS: r@ @] + INC BX INC BX + MOV @[ SS: r + ( v -- ) + POP AX + MOV BX @[ SS: r@ @] + DEC BX DEC BX + MOV @[ SS: i +nexttop :push >next + +: 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 ' EACH_ , here 0 , ; immediate + : continue ' GOTO_ , dup cell - , ; immediate + : more ['] continue here swap ! ; immediate + :timm each t, EACH_ patchpt ; + : CONTINUE t, GOTO_ dup cell - w>t ; + :timm continue CONTINUE ; + :timm more CONTINUE patch!t ; } + +0 var, cancelled +: cancel 1 cancelled ! + :| nextdrop get-next if idrop then 0 cancelled ! 0 swap |; >next ; + +: nothing :| 0 1 |; >next ; +: single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ; +: times ( n -- ) >i :| i 1 then 1 |; >next ; +: links ( p -- ) + dup if >i :| i 1 then 1 |; >next else nothing then ; +: +for? ( n -- f ) i 1 then ; +: for ( start lim -- ) >next 1- >i :| 1 +for? 2 |; >next ; +: for+ ( start lim inc -- ) + >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >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. ) + +: 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 ; + +: map ( cp -- f c ) + 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 ; + +: >map ( mapper -- ) >next ' initial-map >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 ; + +: .all each i [ key 0 lit ] + draw-char more ; +: doubled :| ' 2* map |; >map ; + diff --git a/jort.com b/jort.com index 7afbfb7..84d3e47 100755 Binary files a/jort.com and b/jort.com differ diff --git a/logic.jrt b/logic.jrt index 8b10d31..dc87a1e 100755 --- a/logic.jrt +++ b/logic.jrt @@ -36,6 +36,15 @@ dbg" math" :t / /mod drop ; :t % /mod swap drop ; +:ASM abs ( n -- n ) + POP AX + OR AX AX + JNS 0 @> + NEG AX +0 <: + PUSH AX + NEXT + dbg" comparisons" L: TRUE 0xffff w>t L: FALSE 0 w>t diff --git a/swine.com b/swine.com index 8b29bd8..1c3c249 100755 Binary files a/swine.com and b/swine.com differ diff --git a/swine.jrt b/swine.jrt index 7d4dbc6..bbe4b3d 100755 --- a/swine.jrt +++ b/swine.jrt @@ -71,7 +71,7 @@ var neighbour-count var neighbour-check : count-neighbour neighbour-check @ execute if 1 neighbour-count !+ then ; -: count-neighbours ( x y cp -- ) neighbour-check ! 0 neighbour-count ! +: count-neighbours ( x y cp -- c ) neighbour-check ! 0 neighbour-count ! ' count-neighbour do-neighbour-squares neighbour-count @ ; : analyze-pos ( x y -- n ) ' mine? count-neighbours ; @@ -311,9 +311,9 @@ array title-text t", SWINE MEEPER" minecount !save boardh !save boardw !save leave ; 3 :noname red bg! clear ; defmenu difficulty-menu -:noname 10 10 10 config-game ; s" Easy ( 10x10, 10 swine )" 0 defitem -:noname 20 12 30 config-game ; s" Moderate ( 20x12, 30 swine )" 1 defitem -:noname 30 12 60 config-game ; s" Hard ( 30x12, 60 swine )" 2 defitem +:noname 10 10 10 config-game ; s" Easy ( 10x10, 10 truffles )" 0 defitem +:noname 20 12 30 config-game ; s" Moderate ( 20x12, 30 truffles )" 1 defitem +:noname 30 12 60 config-game ; s" Hard ( 30x12, 60 truffles )" 2 defitem : draw-title blue bg! yellow fg! clear @@ -325,11 +325,8 @@ array title-text t", SWINE MEEPER" ' theme-menu s" Themes" 2 defitem ' leave s" Quit" 3 defitem -: title install-timer textmode reseed! hidecursor - title-menu - textmode uninstall-timer ; +' main :chain textmode reseed! hidecursor title-menu textmode ; -' title ' main redefine dbg" saving" { s" swine.com" writecom } diff --git a/swine.txt b/swine.txt index 9a9b58a..aa7405b 100755 --- a/swine.txt +++ b/swine.txt @@ -18,3 +18,9 @@ You can use the "F" key to flag and unflag a square as containing a truffle without digging there. If you select a square that has already been dug up, and the number on the square matches the number of flags next to it, the unflagged squares will be dug up automatically. + +If you can dig up every square except for the ones with truffles in them, +you win the game! + +At any time, you can press the "ESC" key to quit the game or to exit from a +menu. diff --git a/task.jrt b/task.jrt new file mode 100755 index 0000000..4978a7f --- /dev/null +++ b/task.jrt @@ -0,0 +1,120 @@ +{ 0x100 var, userhere + : userallot userhere @ + userhere ! ; + : userarray userhere @ CONST userallot ; + : uservar cell userarray ; } + +uservar tasksp +uservar taskbp +uservar tasksi +uservar taskcoff +uservar taskcs +uservar next-task + +:asm @u ( p -- v ) + POP BX + PUSH @[ SS: BX] + NEXT + +:asm !u ( v p -- ) + POP BX + POP AX + MOV @[ SS: BX] AX + NEXT + +:asm get-cseg PUSH CS NEXT +{ :asm get-host-cseg PUSH CS NEXT } + +:asm suspend + MOV @[ SS: taskcs @] CS + MOV @[ SS: tasksp @] SP + MOV @[ SS: taskbp @] BP + MOV @[ SS: tasksi @] SI + MOV AX @[ SS: next-task @] +L: resume-task-ax + MOV SS AX + MOV SP @[ SS: tasksp @] + MOV BP @[ SS: taskbp @] + MOV SI @[ SS: tasksi @] + MOV DS @[ SS: taskcs @] + LODSW + MOV BX AX + MOV AX @[ BX] + MOV @[ SS: taskcoff @] AX + JMP FAR @[ SS: taskcoff @] + +:asm resume-task ( taskseg -- ) + POP AX + JMP resume-task-ax + +:asm taskseg + PUSH SS + NEXT + +0 var, first-task +0 var, last-task +0x200 4 >> const tasksegsize + +( taskseg -- taskseg ) +deferred task-init noop + +: init-first-task + taskseg dup next-task !u task-init dup first-task ! last-task ! ; + +init-first-task +' init :chain init-first-task ; + +:asm unlink-task ( prevtaskseg taskseg -- ) + MOV CX SS + POP AX + POP BX + MOV SS AX + MOV DX @[ SS: next-task @] + XOR AX AX + MOV @[ SS: next-task @] AX + MOV SS BX + MOV @[ SS: next-task @] DX + MOV SS CX + NEXT + +: prev-taskseg ( -- taskseg ) + first-task @ begin next-task over @far taskseg != while + tasksegsize + repeat ; +: next-unused-taskseg + first-task @ begin next-task over @far over last-task @ <= and while + tasksegsize + repeat ; + +: task-complete next-task @u prev-taskseg taskseg unlink-task resume-task [ +: task-arise execute task-complete [ +{ : task-arise-host execute task-complete [ } + +:asm link-new-task ( taskseg -- ) + MOV CX SS + POP AX ( taskseg ) + ( save the current next task in BX so we can point the new task at it ) + MOV BX @[ SS: next-task @] + ( link our task segment to the new task ) + MOV @[ SS: next-task @] AX + MOV SS AX + MOV AX 0x100 # + MOV @[ SS: tasksp @] AX + XOR AX AX + MOV @[ SS: taskbp @] AX + MOV @[ SS: next-task @] BX + MOV SS CX ( restore the current task ) + NEXT + +: push-into-task ( v taskseg -- ) + >r tasksp r@ @far 2 - dup tasksp r@ !far r r@ link-new-task + r@ last-task @ > if r@ last-task ! then + cell + tasksi r@ !far + taskcs r@ !far + r@ push-into-task + int ( isr -- int ) 2 cells + @ ; : isr>code ( isr -- p ) 3 cells + ; : uninstall-isr ( isr -- ) @@ -46,7 +42,7 @@ var timer MOV AX CS: timer @+ INC AX MOV CS: timer @+ AX - AND AX 0x03 # + AND AX 0x07 # JZ 0 @> ISR-DONE 0 <: @@ -62,7 +58,7 @@ var timer NEXT : sleep-csec ( cs -- ) - timer @ + begin dup timer @ <= until drop ; -: install-timer 0xffff 2 >> set-timer-div timer-isr install-isr ; -: uninstall-timer 0xffff set-timer-div timer-isr uninstall-isr ; + timer @ + begin suspend dup timer @ <= until drop ; +' init :chain [ 0xffff 3 >> lit ] set-timer-div timer-isr install-isr ; +' cleanup :chain 0xffff set-timer-div timer-isr uninstall-isr ; diff --git a/tinyjort.com b/tinyjort.com index 7afbfb7..84d3e47 100755 Binary files a/tinyjort.com and b/tinyjort.com differ diff --git a/tinyjort.jrt b/tinyjort.jrt index 2a246ac..8c5ba73 100755 --- a/tinyjort.jrt +++ b/tinyjort.jrt @@ -494,7 +494,8 @@ dbg" flow control words and misc." [ patch!t ] drop ; DEFERRED main interpreter -:t tinyjort doinit main terminate ; +DEFERRED cleanup noop +:t tinyjort doinit main cleanup terminate ; dbg" boot" diff --git a/zipoff.com b/zipoff.com index 71bfa3c..f66d5cf 100755 Binary files a/zipoff.com and b/zipoff.com differ diff --git a/zipoff.jrt b/zipoff.jrt index 25b5e91..6ea7819 100755 --- a/zipoff.jrt +++ b/zipoff.jrt @@ -38,8 +38,9 @@ array $DOFAR JMP @[ BX] asm-com -: te word tdict dict-lookup interpretword ; immediate -: tlookup ( -- tcp ) word tdict dict-lookup not if dup err then cell + @ ; +: tdict-lookup word tdict dict-lookup ; +: te tdict-lookup interpretword ; immediate +: tlookup ( -- tcp ) tdict-lookup not if dup err then cell + @ ; : t' tlookup interpretnumber ; immediate : t& tlookup cell + interpretnumber ; immediate : t, tlookup state if lit ' w>t , else w>t then ; immediate @@ -99,13 +100,14 @@ s" coredefs.jrt" loadfile : t", begin key dup [ key " lit ] != while >t repeat drop 0 >t ; :timm s" state if t, INLINEDATA_ patchpt t", patch!t else target t", then ; -:timm :| t, INLINEDATA_ patchpt t& $DOCOLON w>t ; +: startcolon t& $DOCOLON w>t ] ; +:timm :| t, INLINEDATA_ patchpt startcolon ; :timm |; t, return patch!t ; -:noname DEF t& $DOCOLON w>t ] ; +:noname DEF startcolon ; :timm : [ dup , ] ; :timm :t [ , ] ; :timm ' ['] t' ; -:timm :noname target t& $DOCOLON w>t ] ; +:timm :noname target startcolon ; :timm const CONST ; :timm var, VAR, ; :timm var 0 VAR, ; @@ -117,6 +119,9 @@ s" coredefs.jrt" loadfile :timm lit compilenum ; :timm deferred DEFERRED ; +: :chain ( cpdeferred -- ) + cell + dup @t target t ; + dbg" CREATE" : CREATE DEF t& $DOCREATE w>t 0 w>t ; : FINISHCREATE ' latest ' tdict with-dict codepointer cell + @ cell + !t ; @@ -139,19 +144,26 @@ var comfilename : readcom ( filename ) open 0x100 target! begin dup fgetc dup EOF != while >t repeat drop close ; -( we write a fake all-null PSP so openself can fail gracefully ) -:init 0 target! 0xff ALLOT comfilename @ readcom } ; +DEFERRED init noop +DEFERRED main noop +DEFERRED cleanup noop + +tdict-lookup cleanup drop ' cleanup redefine + +:init + ( we write a fake all-null PSP so openself can fail gracefully ) + 0 target! 0xff ALLOT + comfilename @ readcom } + [ tdict-lookup init drop , ] ; : writeenv ( comfile wrapper -- ) swap comfilename ! dup type cr writeself comfilename @ dup type cr writecom ; -DEFERRED main terminate - dbg" boot" -} : start main terminate ; { +} : start init main cleanup terminate ; { 9 <: ( actual entry point ) MOV SI t& start # @@ -165,5 +177,7 @@ dbg" boot" } import common.jrt { +tdict-lookup init drop execute + here s", zipstub.seg" s" zipoff.com" writeenv diff --git a/zipstub.seg b/zipstub.seg index 192cd70..2ecde3c 100755 Binary files a/zipstub.seg and b/zipstub.seg differ