diff --git a/dialer.com b/dialer.com index 0ca7d2d..1944d9a 100755 Binary files a/dialer.com and b/dialer.com differ diff --git a/dialer.jrt b/dialer.jrt index f6ca1cd..f632ae6 100755 --- a/dialer.jrt +++ b/dialer.jrt @@ -1,6 +1,21 @@ -0 var, quiet +1 var, quiet 0 var, quick +: quiet? quiet @ quick @ or ; : quick? quick @ ; +: noisy quiet? if rdrop then ; +: slow quick? if rdrop then ; +var last-delay +: delay-base + timer @ dup last-delay @ - dup 0 >= swap 5 < and if drop last-delay @ then ; +: delay dup not quick? and if drop else + delay-base + dup last-delay ! + begin dup timer @ > while suspend repeat drop + then ; + +var ms-error +: ms ms-error @ + 8 /mod ms-error ! delay ; + +dbg" modem sounds" 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 , @@ -12,11 +27,6 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div , -2 const D* -1 const D# -: quiet? quiet @ quick @ or ; : quick? quick @ ; -: noisy quiet? if rdrop then ; -: slow quick? if rdrop then ; -: delay quick? if drop else sleep-csec then ; - : dtmf ( digit -- f1 f2 ) 1- dup 0 < if abs 3 % 3 swap else 3 /mod then cells dtmf-col + @ swap cells dtmf-row + @ ; @@ -57,7 +67,7 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div , 45 probe-hi 50 probe-lo 15 probe-hi 60 probe-lo 60 probe-hi 300 fullduplex ; -( statusbar words ) +dbg" statusbar" var status var status-timer var status-bg @@ -88,7 +98,7 @@ disconnect-status :| begin textstate draw-status textstate! suspend again |; spawn-task drop ; -( terminal words ) +dbg" terminal" : sleep-key begin key-waiting? not while suspend repeat wait-key ; : pause sleep-key drop ; @@ -98,8 +108,10 @@ disconnect-status : nl nextline fixcursor ; : emit draw-char fixcursor ; -: xmit ( st -- ) chars each i emit 1 delay next ; +: xmit-iter each i emit 3 ms next ; +: xmit ( st -- ) chars xmit-iter ; : xmit-line xmit nl ; +: repeated ( v n -- ) times >arg (( each dup map next drop )) ; { :timm x" t" t, xmit ; :timm l" t" t, xmit-line ; } @@ -123,23 +135,43 @@ array linebuf MAXLINE 1+ allot : call ( st -- ) white fg! x" ATDT" dup xmit-line quiet? if drop else offhook dialtone dialst then ; : successful-call ( st -- ) call noisy 200 sleep-csec handshake ; -: hangup ( -- ) nl offhook disconnect-status white fg! l" NO CARRIER" ; +: hangup ( -- ) offhook nl disconnect-status white fg! l" NO CARRIER" ; : connect ( cp st -- ) successful-call connect-status l" CONNECT 57600" execute hangup ; -( bbses ) - +dbg" downloading" import embed.jrt -: xmit-screen ( rle -- ) rle-decode each i 8 >> textpen ! i emit next ; + +: embed-write ( fp p -- ) dup embed-size swap embed-data t w>t w>t w>t w>t ; + : defembed ( filename desc -- ) + over [ tdict-lookup open drop , ] filebytes target embed-bytes + t' embed-size t' embed-write deffile ; + : deffake ( filename desc size -- ) t' noop t' rand-write deffile ; } + +: filename ( file -- st ) 4 cells + @ ; +: filedesc ( file -- st ) 3 cells + @ ; +: filedata ( file -- data ) 2 cells + @ ; +: filesize ( file -- n ) dup filedata swap cell + @ execute ; +: write-file ( file -- ) + dup filename overwrite >r r@ over filedata > textpen ! pass next )) xmit-iter + textpen ! ; { : lines-of pagew 2* * take ; } import rick.jrt -( menu ) +dbg" menu" : snapshot 1 0 pagecopy ; : restore 0 1 pagecopy ; -: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ; -: count 0 each 1+ next ; var menu-onclose : close-menu ( cp -- ) menu-onclose ! restore suspend ; @@ -187,7 +219,7 @@ pagew menux 2* - const menuw : popup-menu snapshot textstate 0 menu-onclose ! first-option draw-menubox menu-loop textstate! menu-onclose @ execute 0 menu-onclose ! ; -( logo ) +dbg" startup" { : X ( v -- v ) 2* 1 | ; : o ( v -- v ) 2* ; } 7 const logoh diff --git a/dirtrect.com b/dirtrect.com index 1485fe2..51c3287 100755 Binary files a/dirtrect.com and b/dirtrect.com differ diff --git a/embed.jrt b/embed.jrt index b6050ae..6e40052 100755 --- a/embed.jrt +++ b/embed.jrt @@ -35,8 +35,8 @@ var rle-run : encode-rle ( call with iterator that returns bytes ) >rle-start each i iterate if i 8 << | >rle else drop then next >rle-done ; : embed-rle ( host-filename -- ) open filebytes encode-rle ; -: embed ( host-filename -- ) - target 0 w>t open filebytes each i >t next target swap !t ; +: embed-bytes ( -- ) target 0 w>t each i >t next target swap !t ; +: embed ( host-filename -- ) open filebytes embed-bytes ; } : embed-size ( embed -- v ) dup @ swap - ; diff --git a/iter.jrt b/iter.jrt index f66a1b4..d28e572 100755 --- a/iter.jrt +++ b/iter.jrt @@ -142,6 +142,9 @@ nexttop :push >next >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ; : pchars ( st -- ) 1- >i :| i 1 else drop 0 then 1 |; >next ; +: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ; +: count 0 each 1+ next ; + :asm _resume ( cpcancel -- 0 0 args... ) POP DX MOV AX SS diff --git a/rick.jrt b/rick.jrt index e06d63b..35eb61e 100755 --- a/rick.jrt +++ b/rick.jrt @@ -29,13 +29,74 @@ deferred rick-menu noop l" Sorry, guess he's not home!" ' rick-menu ; -: rick-files l" WORK IN PROGRESS, HERE BE DRAGONS" ' rick-menu ; +dbg" swine.com" s" swine.com" +s" Swine Meeper - A fun freeware puzzler. Find all the truffles!" +defembed swine.com + +dbg" dirtrect.com" s" dirtrect.com" +s" Dirty Rectangles - A simple textmode graphics demo" +defembed dirtrect.com + +dbg" kpshrink4.kps" s" kpshrink4.kps" +s" KP Shrinker 4.0 - Compressor and decompressor for KPS files\Requires an earlier version of PK Shrinker to extract." +59943 deffake kpshrink4.kps + +dbg" mazecr3d.kps" s" mazecr3d.kps" +s" Maze Crazy 3D - Explore a fascinating maze filled with twists and turns\in 3 incredible dimensions! Includes instructions for building a PC adapter\for the Virtua Glove." +48371 deffake mazecr3d.kps + +: rick-filelist (( + kpshrink4.kps yield + dirtrect.com yield + mazecr3d.kps yield + swine.com yield + )) ; + +: xmit-desc ( st -- ) + chars (( each i [ key \ lit ] = if nl else pass then next )) + xmit-iter ; + +array numstr 7 allot +key 0 const $0 +: char>> ( st ch -- st+1 ) over b! 1+ ; +: digit>> ( st state n div -- st state n ) + /mod swap dup if ( st state n digit ) + $0 + >r > ( state n st ) + > >rot then then ; +: nsep>> ( st state n -- st state n ) + over if > >rot then ; +: n>st ( n -- st ) + numstr 0 > 1000 digit>> nsep>> 100 digit>> 10 digit>> + swap drop $0 + char>> 0 char>> drop numstr ; + +: list-files 1 each + blue bg! yellow fg! x" [" dup .digit x" ]" + lcyan fg! black bg! sp emit i filename xmit + cyan fg! x" (" i filesize n>st xmit l" bytes)" + lgray fg! nl i filedesc xmit-desc nl + nl 1+ next drop ; + +: inputch readch tolower dup emit nl ; + +: download-file ( file -- ) write-file ; ( todo: more elaborate ) +: select-file + x" Type the number of a file, or Q to return to the menu: " inputch + dup [ key q lit ] = if drop ' rick-menu return then + [ key 1 lit ] - dup 0 >= over rick-filelist count < and if + rick-filelist nth + lblue fg! x" Downloading " dup filename xmit l" ..." + download-file l" Done!" ' rick-menu return then + drop lred fg! l" Sorry, that is not a valid selection." ' select-file ; + +: rick-files nl rick-filelist list-files ' select-file ; :noname ( -- cp ) nl rick-menu-rle xmit-screen nl 0 begin yellow fg! black bg! - nl x" Your selection: " readch tolower dup emit nl + nl x" Your selection: " inputch dup [ key m lit ] = if lred fg! l" Sorry, message boards are not available to guests." then dup [ key g lit ] = if @@ -48,7 +109,7 @@ deferred rick-menu noop : rick black bg! white fg! - nl nl nl rick-welcome-rle xmit-screen login + sp [ pagew 3 * lit ] repeated xmit-iter + rick-welcome-rle xmit-screen login ' rick-menu begin execute dup not until ; -: call-rick s" 5551212" ; diff --git a/swine.com b/swine.com index fddd259..6351e5d 100755 Binary files a/swine.com and b/swine.com differ diff --git a/timer.jrt b/timer.jrt index 33a8fb8..c4776a6 100755 --- a/timer.jrt +++ b/timer.jrt @@ -60,7 +60,7 @@ var timer ( the timer is set to run at just under 150hz, so a "csec" is closer to 7.5ms than 10ms. ) : over-csec ( csec -- ) - timer @ + >arg (( begin yield0 dup timer @ <= until drop )) ; + timer @ + >arg (( begin dup timer @ > while yield0 repeat drop )) ; : sleep-csec ( cs -- ) over-csec each suspend next ; ' init :chain [ 0xffff 3 >> lit ] set-timer-div timer-isr install-isr ; diff --git a/zipoff.com b/zipoff.com index 1d2a05f..32c449b 100755 Binary files a/zipoff.com and b/zipoff.com differ diff --git a/zipstub.seg b/zipstub.seg index 98f353a..ecbb944 100755 Binary files a/zipstub.seg and b/zipstub.seg differ