speed up embedding, download dialog

asm.jrt

@@ -86,7 +86,8 @@ array patchtable 10 2 cells * allot
 : L! [ ' ' , ] 2 cells + target swap ! ;
 
 array anonlabels 10 cells allot
-: <@ ( labelid -- ) cells anonlabels + @ @+ ;
+: L<@ ( labelid -- addr ) cells anonlabels + @ ;
+: <@ ( labelid -- ) L<@ @+ ;
 : :> ( labelid -- ) cells anonlabels + target swap ! ;
 
 : memreg create , does> @ oparg-base ! oparg-complete! ;

assemble.jrt

@@ -5,9 +5,7 @@ s" asm.jrt" loadfile
 :init segalloc ' comseg redefine ;
 
 : writecom ( filename -- )
-  overwrite >r 0x100 
+  overwrite >r target 0x100 - 0x100 r@ comseg farfwrite <r close ;
-  begin dup target < while dup b@t r@ fputc 1+ repeat 
-  drop <r close ;
 : writeself overwrite >r here 0x100 - 0x100 r@ fwrite <r close ;
 
 s" assemble.com" writeself

dialer.jrt

@@ -1,4 +1,4 @@
-1 var, quiet
+0 var, quiet
 0 var, quick
 
 : quiet? quiet @ quick @ or ; : quick? quick @ ;
@@ -149,7 +149,7 @@ import embed.jrt
 
 { : 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 
+    over T] open target swap embed-file 
     t' embed-size t' embed-write deffile ; 
   : deffake ( filename desc size -- ) t' noop t' rand-write deffile ; }
 
@@ -160,8 +160,54 @@ import embed.jrt
 : write-file ( file -- ) 
   dup filename overwrite >r r@ over filedata <rot @ execute <r close ;
 
+: snapshot 1 0 pagecopy ; : restore 0 1 pagecopy ;
+
+: 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 ;
+
+: draw-download-progress ( size progress -- )
+  12 12 textxy! dup n>st draw-text
+  swap 40 / / 20 12 textxy! 0xb2 draw-hrepeat ;
+
+: download-file ( file -- ) dup write-file
+  >r textstate <r snapshot green bg! white fg! 1 boxstyle!
+  10 10 textxy! 60 4 filled draw-box
+  12 11 textxy! s" Downloading " draw-text dup filename draw-text
+  filesize 0 62 12 textxy! over n>st draw-text
+  20 12 textxy! 40 0xb0 draw-hrepeat
+  2dup draw-download-progress
+  30 delay
+  begin 15 delay 256 rand 0x1f & + + 2dup > while 
+    2dup draw-download-progress repeat
+  drop dup draw-download-progress 60 delay restore textstate! ;
+
 dbg" BBSes"
 
+: tolower ( ch -- ch ) 
+  dup [ key A lit ] >= over [ key Z lit ] <= and 
+  if [ key a key A - lit ] + then ;
+
+: readch ( -- ch )
+  begin sleep-key key>ch dup printable? not while drop repeat ;
+
+: inputch readch tolower dup emit nl ;
+
 : xmit-screen ( rle -- ) 
   rle-decode textpen @ 
   (( each i 8 >> textpen ! pass next )) xmit-iter 
@@ -171,8 +217,6 @@ dbg" BBSes"
 import rick.jrt
 
 dbg" menu"
-: snapshot 1 0 pagecopy ; : restore 0 1 pagecopy ;
-
 var menu-onclose
 : close-menu ( cp -- ) menu-onclose ! restore suspend ;
 : menu-options ((
@@ -307,5 +351,5 @@ var curr-logobit
 ' go ' main redefine
 
 dbg" saving"
+{ here s", dialer.com" s" dialtest.com" writeenv }
 
-{ s" dialer.com" writecom }

embed.jrt

@@ -35,12 +35,14 @@ 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-bytes ( -- ) target 0 w>t each i >t next target swap !t ;
+: embed-file ( fp -- ) 
-: embed ( host-filename -- ) open filebytes embed-bytes ;
+  >r target 0 w>t 0xffff target r@ T] fread <r close
+  T] fcount @t target + target! target swap !t ;
+: embed ( host-filename -- ) open embed-file ;
 }
 
-: embed-size ( embed -- v ) dup @ swap - ;
 : embed-data ( embed -- p ) cell + ;
+: embed-size ( embed -- v ) dup @ swap embed-data - ;
 
 : rle-decode ( p -- )
   >arg (( dup @ swap cell + +arg ( pend p )

file.jrt

@@ -55,24 +55,36 @@
   NEXT
 
 0 VAR, fcount
-:ASM fread
+:ASM farfread
+  POP DS ( seg )
+0 :>
   MOV AH 0x3f #
   POP BX ( fp )
   POP DX ( buffer )
   POP CX ( length )
   INT 0x21 #
+  MOV BX CS
+  MOV DS BX
   MOV t& fcount @+ AX ( save number of bytes read )
   NEXT
 
-:ASM fwrite
+DEF fread 0 L<@ w>t
+
+:ASM farfwrite
+  POP DS ( seg )
+0 :>
   MOV AH 0x40 #
   POP BX ( fp )
   POP DX ( buffer )
   POP CX ( length )
   INT 0x21 #
+  MOV BX CS
+  MOV DS BX
   MOV t& fcount @+ AX ( save number of bytes written )
   NEXT
 
+DEF fwrite 0 L<@ w>t
+
 -1 CONST EOF
 0 VAR, fbuffer
 :t fgetc ( fp -- c )

rick.jrt

@@ -1,76 +1,60 @@
+dbg" Rick's Clubhouse BBS"
 array rick-welcome-rle 
 { s" rickclub.bin" open filebytes 18 lines-of encode-rle }
 array rick-menu-rle
 { s" rickmenu.bin" open filebytes 7 lines-of encode-rle }
 
+dbg" login"
 : login
   l" To login as a guest, leave your name blank."
   begin 
     x" Enter your name: " readline nl 
     dup b@ while x" Sorry, I don't recognize " xmit l" !" nl
   repeat nl
+  cyan fg!
   l" Welcome, guest! We hope you decide to apply for a full membership." 
   l" Guest accounts have limited access." 
   l" If you have any questions, feel free to page the sysop - I'll be happy"
   l" to chat with you if I'm around!" 
   l"    -- Rick" nl ;
 
-: tolower ( ch -- ch ) 
-  dup [ key A lit ] >= over [ key Z lit ] <= and 
-  if [ key a key A - lit ] + then ;
-: readch ( -- ch )
-  begin sleep-key key>ch dup printable? not while drop repeat ;
-
 deferred rick-menu noop
 
 : page-rick 
-  l" Paging Sysop........" 
+  x" Paging Sysop..."
-  500 delay
+  5 times each 100 delay [ key . lit ] emit next nl
-  l" Sorry, guess he's not home!" 
+  l" Sorry, guess they're not home!" 
   ' rick-menu ;
 
-dbg" swine.com" s" swine.com" 
+dbg" files"
+s" swine.com" 
 s" Swine Meeper - A fun freeware puzzler. Find all the truffles!"
 defembed swine.com
 
-dbg" dirtrect.com" s" dirtrect.com"
+s" dirtrect.com"
-s" Dirty Rectangles - A simple textmode graphics demo"
+s" A simple textmode graphics demo advertising the game development collective\called Dirty Rectangles."
 defembed dirtrect.com
 
-dbg" kpshrink4.kps" s" kpshrink4.kps"
+s" assemble.com"
+s" I think this is an 8086 assembler, but I don't have any documentation for\it and it doesn't use a standard syntax. Some kind of Forth system?"
+defembed assemble.com
+
+(
+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" 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 
+    dirtrect.com yield
+    assemble.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 
@@ -78,20 +62,20 @@ key 0 const $0
     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 
+    rick-filelist nth
     lblue fg! x" Downloading " dup filename xmit l" ..."
-    download-file l" Done!" ' rick-menu return then
+    download-file l" Done!" else
-  drop lred fg! l" Sorry, that is not a valid selection." ' select-file ;
+  drop lred fg! l" Sorry, that is not a valid selection." then 
+  ' select-file ;
 
 : rick-files nl rick-filelist list-files ' select-file ;
 
+dbg" menu"
+
 :noname ( -- cp )
   nl rick-menu-rle xmit-screen nl
   0 begin

zipoff.jrt

@@ -39,6 +39,7 @@ array $DOFAR
 asm-com
 
 : tdict-lookup word tdict dict-lookup ;
+: T] tdict-lookup not if err return then state if , then ; immediate
 : te tdict-lookup interpretword ; immediate
 : tlookup ( -- tcp ) tdict-lookup not if dup err then cell + @ ;
 : t' tlookup interpretnumber ; immediate
@@ -144,20 +145,21 @@ dbg" CREATE"
 
 var comfilename
 
-: readcom ( filename ) open 0x100 target! 
+: readcom ( filename ) open >r 
-  begin dup fgetc dup EOF != while >t repeat drop close ;
+  0x100 0xffff over r@ comseg farfread 
+  fcount @ + target! <r close ;
 
 DEFERRED init noop
 DEFERRED main noop
 DEFERRED cleanup noop
 
-tdict-lookup cleanup drop ' cleanup redefine
+T] cleanup ' 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 , ] ;
+  T] init ;
 
 : writeenv ( comfile wrapper -- ) 
   swap comfilename !
@@ -180,7 +182,7 @@ dbg" boot"
 
 } import common.jrt {
 
-tdict-lookup init drop execute
+T] init execute
 
 here s", zipstub.seg" s" zipoff.com" writeenv