speed up embedding, download dialog

main
Jeremy Penner 2023-10-15 21:05:54 -04:00
parent 57f2f4b3d3
commit 314ee8b476
14 changed files with 104 additions and 61 deletions

View File

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

Binary file not shown.

View File

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

Binary file not shown.

View File

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

BIN
dialtest.com Executable file

Binary file not shown.

View File

@ -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 ( host-filename -- ) open filebytes embed-bytes ;
: embed-file ( fp -- )
>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 )

View File

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

BIN
jort.com

Binary file not shown.

View File

@ -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........"
500 delay
l" Sorry, guess he's not home!"
x" Paging Sysop..."
5 times each 100 delay [ key . lit ] emit next nl
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" Dirty Rectangles - A simple textmode graphics demo"
s" dirtrect.com"
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
drop lred fg! l" Sorry, that is not a valid selection." ' select-file ;
download-file l" Done!" else
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

Binary file not shown.

Binary file not shown.

View File

@ -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!
begin dup fgetc dup EOF != while >t repeat drop close ;
: readcom ( filename ) open >r
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

Binary file not shown.