file area, speed up text display

This commit is contained in:
Jeremy Penner 2023-10-15 16:54:40 -04:00
parent 85824a202d
commit 57f2f4b3d3
10 changed files with 120 additions and 24 deletions

Binary file not shown.

View file

@ -1,6 +1,21 @@
0 var, quiet 1 var, quiet
0 var, quick 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-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 , 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* -2 const D*
-1 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- : dtmf ( digit -- f1 f2 ) 1-
dup 0 < if abs 3 % 3 swap else 3 /mod then dup 0 < if abs 3 % 3 swap else 3 /mod then
cells dtmf-col + @ swap cells dtmf-row + @ ; 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 45 probe-hi 50 probe-lo 15 probe-hi 60 probe-lo 60 probe-hi
300 fullduplex ; 300 fullduplex ;
( statusbar words ) dbg" statusbar"
var status var status
var status-timer var status-timer
var status-bg var status-bg
@ -88,7 +98,7 @@ disconnect-status
:| begin textstate draw-status textstate! suspend again |; :| begin textstate draw-status textstate! suspend again |;
spawn-task drop ; spawn-task drop ;
( terminal words ) dbg" terminal"
: sleep-key begin key-waiting? not while suspend repeat wait-key ; : sleep-key begin key-waiting? not while suspend repeat wait-key ;
: pause sleep-key drop ; : pause sleep-key drop ;
@ -98,8 +108,10 @@ disconnect-status
: nl nextline fixcursor ; : nl nextline fixcursor ;
: emit draw-char 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 ; : xmit-line xmit nl ;
: repeated ( v n -- ) times >arg (( each dup map next drop )) ;
{ :timm x" t" t, xmit ; { :timm x" t" t, xmit ;
:timm l" t" t, xmit-line ; } :timm l" t" t, xmit-line ; }
@ -123,23 +135,43 @@ array linebuf MAXLINE 1+ allot
: call ( st -- ) white fg! x" ATDT" dup xmit-line : call ( st -- ) white fg! x" ATDT" dup xmit-line
quiet? if drop else offhook dialtone dialst then ; quiet? if drop else offhook dialtone dialst then ;
: successful-call ( st -- ) call noisy 200 sleep-csec handshake ; : 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 -- ) : connect ( cp st -- )
successful-call connect-status l" CONNECT 57600" execute hangup ; successful-call connect-status l" CONNECT 57600" execute hangup ;
( bbses ) dbg" downloading"
import embed.jrt 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 ; } { : lines-of pagew 2* * take ; }
import rick.jrt import rick.jrt
( menu ) dbg" menu"
: snapshot 1 0 pagecopy ; : restore 0 1 pagecopy ; : 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 var menu-onclose
: close-menu ( cp -- ) menu-onclose ! restore suspend ; : 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 : popup-menu snapshot textstate 0 menu-onclose ! first-option
draw-menubox menu-loop textstate! menu-onclose @ execute 0 menu-onclose ! ; draw-menubox menu-loop textstate! menu-onclose @ execute 0 menu-onclose ! ;
( logo ) dbg" startup"
{ : X ( v -- v ) 2* 1 | ; { : X ( v -- v ) 2* 1 | ;
: o ( v -- v ) 2* ; } : o ( v -- v ) 2* ; }
7 const logoh 7 const logoh

Binary file not shown.

View file

@ -35,8 +35,8 @@ var rle-run
: encode-rle ( call with iterator that returns bytes ) : encode-rle ( call with iterator that returns bytes )
>rle-start each i iterate if i 8 << | >rle else drop then next >rle-done ; >rle-start each i iterate if i 8 << | >rle else drop then next >rle-done ;
: embed-rle ( host-filename -- ) open filebytes encode-rle ; : embed-rle ( host-filename -- ) open filebytes encode-rle ;
: embed ( host-filename -- ) : embed-bytes ( -- ) target 0 w>t each i >t next target swap !t ;
target 0 w>t open filebytes each i >t next target swap !t ; : embed ( host-filename -- ) open filebytes embed-bytes ;
} }
: embed-size ( embed -- v ) dup @ swap - ; : embed-size ( embed -- v ) dup @ swap - ;

View file

@ -142,6 +142,9 @@ nexttop :push >next
>next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >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 ; : 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... ) :asm _resume ( cpcancel -- 0 0 args... )
POP DX POP DX
MOV AX SS MOV AX SS

View file

@ -29,13 +29,74 @@ deferred rick-menu noop
l" Sorry, guess he's not home!" l" Sorry, guess he's not home!"
' rick-menu ; ' 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 ) :noname ( -- cp )
nl rick-menu-rle xmit-screen nl nl rick-menu-rle xmit-screen nl
0 begin 0 begin
yellow fg! black bg! yellow fg! black bg!
nl x" Your selection: " readch tolower dup emit nl nl x" Your selection: " inputch
dup [ key m lit ] = if dup [ key m lit ] = if
lred fg! l" Sorry, message boards are not available to guests." then lred fg! l" Sorry, message boards are not available to guests." then
dup [ key g lit ] = if dup [ key g lit ] = if
@ -48,7 +109,7 @@ deferred rick-menu noop
: rick : rick
black bg! white fg! 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 ; ' rick-menu begin execute dup not until ;
: call-rick s" 5551212" ;

BIN
swine.com

Binary file not shown.

View file

@ -60,7 +60,7 @@ var timer
( the timer is set to run at just under 150hz, so a "csec" is closer to 7.5ms ( the timer is set to run at just under 150hz, so a "csec" is closer to 7.5ms
than 10ms. ) than 10ms. )
: over-csec ( csec -- ) : 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 ; : sleep-csec ( cs -- ) over-csec each suspend next ;
' init :chain [ 0xffff 3 >> lit ] set-timer-div timer-isr install-isr ; ' init :chain [ 0xffff 3 >> lit ] set-timer-div timer-isr install-isr ;

Binary file not shown.

Binary file not shown.