iteration, cooperative multitasking, touchtone noises

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

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 <rot 1- dup not until drop drop drop ;
 

common.jrt

@@ -2,6 +2,7 @@ import text.jrt
 import keys.jrt
 import random.jrt
 import file.jrt
+import task.jrt
 import timer.jrt
 import beep.jrt
 

dialer.jrt

@@ -0,0 +1,17 @@
+array dtmf-col 1209 freq>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 ;
+

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 ;
+
+taskseg task-init drop
+
+{ : :peek 
+:ASM ( pixp -- ) >r
+  ( i -- v )
+  POP AX
+  SHL AX 1 #
+  MOV BX @[ SS: <r @]
+  ADD BX AX
+  PUSH @[ SS: BX]
+  NEXT ; }
+
+itop    :peek ipeek
+nexttop :peek nextpeek
+
+{ : :drop ( pixp -- )
+:ASM >r
+  MOV BX @[ SS: r@ @]
+  INC BX INC BX
+  MOV @[ SS: <r @] BX
+  NEXT ; }
+
+itop    :drop idrop
+nexttop :drop nextdrop
+
+{ : :push ( pixp -- )
+:ASM >r
+  ( v -- )
+  POP AX
+  MOV BX @[ SS: r@ @]
+  DEC BX DEC BX
+  MOV @[ SS: <r @] BX
+  MOV @[ SS: BX] AX
+  NEXT ; }
+
+itop    :push >i
+nexttop :push >next
+
+: <i    0 ipeek    idrop ;
+: <next 0 nextpeek nextdrop ;
+: i 0 ipeek ; : j 1 ipeek ;
+
+( iterator words must have the following shape: )
+( -- more nextcount )
+( It must take care of updating the i-stack directly. if there are
+  no more values, it must remove the values from the i-stack and return 
+  0 in the "more" place.
+
+  "nextcount" must be the number of items that are being taken up on the 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 
+  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.
+
+  If an iterator requires any more complex cleanup to happen as the result
+  of a cancellation, such as dropping multiple items off the i-stack, or
+  aborting a task, it should check the "cancelled" flag to determine whether 
+  to perform it. An iterator that returns 0 0 will not cause any further
+  changes to occur to the iteration stacks, which allows it to be in complete
+  control of this scenario if needed.
+
+  Note that all "next" words _must_ be defined in the target Forth!
+  This means that any iterator that dereferences near memory, such as "links",
+  WILL NOT WORK on the host Forth! )
+
+( get-next returns the result of the iterator in swapped order - it is usually
+  more convenient to specify the count last when writing iterators, but it's 
+  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 ;
+
+{ ( 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 ' 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 dup if 1- >i 1 then 1 |; >next ;
+: links ( p -- )
+  dup if >i :| <i @ dup if >i 1 then 1 |; >next else nothing then ;
+: +for? ( n -- f ) <i + dup 1 nextpeek = if drop 0 else >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 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 ;
+
+: 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 ;
+
+: >map ( mapper -- ) >next ' initial-map >next ;
+
+: 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 ;
+

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

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 10 10 10 config-game ; s" Easy     ( 10x10, 10 truffles )" 0 defitem
-:noname 20 12 30 config-game ; s" Moderate ( 20x12, 30 swine )" 1 defitem
+:noname 20 12 30 config-game ; s" Moderate ( 20x12, 30 truffles )" 1 defitem
-:noname 30 12 60 config-game ; s" Hard     ( 30x12, 60 swine )" 2 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 
+' main :chain textmode reseed! hidecursor title-menu textmode ;
-  title-menu 
-  textmode uninstall-timer ;
 
-' title ' main redefine
 dbg" saving"
 
 { s" swine.com" writecom }

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.

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 !far ;
+: spawn-task-raw ( cp cseg arise -- taskseg ) 
+  next-unused-taskseg >r r@ link-new-task
+  r@ last-task @ > if r@ last-task ! then
+  cell + tasksi r@ !far
+  taskcs r@ !far
+  r@ push-into-task 
+  <r task-init ;
+
+: spawn-task ( cp -- taskseg )
+  get-cseg ' task-arise spawn-task-raw ;
+{ : spawn-task ( cp -- taskseg )
+    get-host-cseg ' task-arise-host spawn-task-raw ; }
+

timer.jrt

@@ -29,10 +29,6 @@
     STI
     JMP FAR CS: @+ ; }
 
-:asm get-cseg
-  PUSH CS
-  NEXT
-
 : isr>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 ;
+  timer @ + begin suspend dup timer @ <= until drop ;
-: install-timer 0xffff 2 >> set-timer-div timer-isr install-isr ;
+' init :chain [ 0xffff 3 >> lit ] set-timer-div timer-isr install-isr ;
-: uninstall-timer 0xffff set-timer-div timer-isr uninstall-isr ;
+' cleanup :chain 0xffff set-timer-div timer-isr uninstall-isr ;
 

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"
 

zipoff.jrt

@@ -38,8 +38,9 @@ array $DOFAR
   JMP @[ BX]
 asm-com
 
-: te word tdict dict-lookup interpretword ; immediate
+: tdict-lookup word tdict dict-lookup ;
-: tlookup ( -- tcp ) word tdict dict-lookup not if dup err then cell + @ ;
+: 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 <rot !t startcolon w>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 )
+DEFERRED init noop
-:init 0 target! 0xff ALLOT comfilename @ readcom } ;
+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