iteration, cooperative multitasking, touchtone noises

main
Jeremy Penner 2023-10-01 21:54:58 -04:00
parent 85766dad46
commit ca38564024
18 changed files with 369 additions and 34 deletions

View File

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

Binary file not shown.

View File

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

View File

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

17
dialer.jrt Executable file
View File

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

166
iter.jrt Executable file
View File

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

BIN
jort.com

Binary file not shown.

View File

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

BIN
swine.com

Binary file not shown.

View File

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

View File

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

120
task.jrt Executable file
View File

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

View File

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

Binary file not shown.

View File

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

Binary file not shown.

View File

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

Binary file not shown.