file area, speed up text display

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 <rot fwrite ; 
+: rand-write ( fp size -- ) dup prngstate ! ( write the same file every time )
+  times each rand over fputc next drop reseed! ;
+
+{ : deffile ( filename desc file sizer writer ) ARRAY w>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 <rot @ execute <r close ;
+
+dbg" BBSes"
+
+: xmit-screen ( rle -- ) 
+  rle-decode textpen @ 
+  (( each i 8 >> 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

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

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+ dup b@ if >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

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 <rot <r char>> ( state n st )
+    <rot drop 1 <rot
+  else drop over if <rot $0 char>> >rot then then ;
+: nsep>> ( st state n -- st state n )
+  over if <rot [ key , lit ] char>> >rot then ;
+: n>st ( n -- st )
+  numstr 0 <rot 
+  10000 digit>> 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" ;

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 ;