356 lines
10 KiB
Plaintext
Executable file
356 lines
10 KiB
Plaintext
Executable file
0 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 , 1336 , 1477 ,
|
|
array dtmf-row 697 , 770 , 852 , 941 ,
|
|
|
|
( 0 1 2
|
|
3 4 5
|
|
6 7 8
|
|
-3 -1 -2 )
|
|
|
|
-2 const D*
|
|
-1 const D#
|
|
|
|
: dtmf ( digit -- f1 f2 ) 1-
|
|
dup 0 < if abs 3 % 3 swap else 3 /mod then
|
|
cells dtmf-col + @ swap cells dtmf-row + @ ;
|
|
: dial ( digit -- ) dtmf 20 arp 7 sleep-csec ;
|
|
: dialch ( b -- ) >r
|
|
r@ [ key * lit ] = if D* dial then
|
|
r@ [ key # lit ] = if D# dial then
|
|
r@ [ key 0 lit ] >= if r@ [ key 9 lit ] <= if
|
|
r@ [ key 0 lit ] - dial
|
|
then then rdrop ;
|
|
|
|
: dialst ( st -- ) chars each i dialch next ;
|
|
: dialtone 350 440 200 arp ;
|
|
: offhook noisy 30 sleep-csec 2 3 divboop 15 sleep-csec 2 7 divboop 10 sleep-csec ;
|
|
|
|
2100 const carrier-freq
|
|
980 const hs-low
|
|
1180 const hs-high
|
|
1650 const hs2-low
|
|
1850 const hs2-high
|
|
|
|
: carrier-drop 1 0x6000 divboop ;
|
|
: carrier ( csec -- ) carrier-freq swap boop carrier-drop ;
|
|
: scramblebip ( div div -- ) rand 2 % if swap then drop 1 boop ;
|
|
: hs-with-carrier ( csec -- )
|
|
over-csec each carrier-freq 1 boop hs-low hs-high scramblebip next ;
|
|
: dual-hs ( csec -- ) over-csec each
|
|
hs-low hs-high scramblebip hs2-low hs2-high scramblebip
|
|
next ;
|
|
: probe-hi ( csec -- ) 2400 1200 <rot arp ;
|
|
: probe-lo ( csec -- ) 600 300 <rot arp ;
|
|
: fullduplex ( csec -- )
|
|
over-csec each rand 3700 % 20 + freq>div >spk next silence ;
|
|
: handshake
|
|
30 carrier 45 carrier 75 carrier 30 carrier
|
|
30 hs-with-carrier 75 hs-with-carrier 45 hs-with-carrier
|
|
37 dual-hs 37 dual-hs 37 dual-hs 30 dual-hs
|
|
45 probe-hi 50 probe-lo 15 probe-hi 60 probe-lo 60 probe-hi
|
|
300 fullduplex ;
|
|
|
|
dbg" statusbar"
|
|
var status
|
|
var status-timer
|
|
var status-bg
|
|
|
|
: disconnect-status
|
|
s" DISCONNECTED" status ! 0 status-timer ! magenta status-bg ! ;
|
|
: connect-status
|
|
s" CONNECTED" status ! ticks status-timer ! green status-bg ! ;
|
|
disconnect-status
|
|
|
|
: connected? status-bg @ green = ;
|
|
: space-to ( x -- ) textx - sp draw-hrepeat ;
|
|
: .digit ( v -- ) [ key 0 lit ] + draw-char ;
|
|
: .2digit ( v -- ) 10 /mod swap 10 % .digit .digit ;
|
|
: .: [ key : lit ] draw-char ;
|
|
: draw-status-timer
|
|
ticks status-timer @ - 18 / 60 /mod swap 60 /mod swap
|
|
.2digit .: .2digit .: .2digit ;
|
|
|
|
: draw-status
|
|
status-bg @ bg! white fg! 0 0 textxy!
|
|
1 space-to status @ draw-text
|
|
connected? if 70 space-to draw-status-timer
|
|
else 65 space-to s" | ESC for menu" draw-text then
|
|
80 space-to ;
|
|
|
|
: init-statusbar
|
|
:| begin textstate draw-status textstate! suspend again |;
|
|
spawn-task drop ;
|
|
|
|
dbg" terminal"
|
|
: sleep-key begin key-waiting? not while suspend repeat wait-key ;
|
|
: pause sleep-key drop ;
|
|
|
|
: fixcursor
|
|
texty 24 - dup 0 > if times each 1 24 scrollup next 24 texty! else drop then
|
|
texty 8 << textx | movecursor ;
|
|
|
|
: nl nextline fixcursor ;
|
|
: emit draw-char fixcursor ;
|
|
: 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 ; }
|
|
|
|
79 const MAXLINE
|
|
array linebuf MAXLINE 1+ allot
|
|
|
|
: printable? ( k -- f ) key>ch dup 0x20 >= swap 0x7e <= and ;
|
|
: bs? ( k -- f ) key>scan dup %bs = swap %left = or ;
|
|
: bs textx 1- dup textx! sp draw-char textx! fixcursor ;
|
|
: enter? ( k -- f ) key>scan %enter = ;
|
|
: readline linebuf begin sleep-key
|
|
dup enter? not while
|
|
dup printable? if over linebuf MAXLINE + <
|
|
if key>ch 2dup swap b! emit 1+ else drop then else
|
|
dup bs? if drop dup linebuf > if bs 1- then else
|
|
drop then then
|
|
repeat drop 0 swap b! linebuf ;
|
|
|
|
|
|
: 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 ( -- ) offhook nl disconnect-status white fg! l" NO CARRIER" ;
|
|
|
|
: connect ( cp st -- )
|
|
successful-call connect-status l" CONNECT 57600" execute hangup ;
|
|
|
|
dbg" downloading"
|
|
import embed.jrt
|
|
|
|
: 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 T] open target swap embed-file
|
|
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 ;
|
|
|
|
: 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
|
|
textpen ! ;
|
|
{ : lines-of pagew 2* * take ; }
|
|
|
|
import rick.jrt
|
|
|
|
dbg" menu"
|
|
var menu-onclose
|
|
: close-menu ( cp -- ) menu-onclose ! restore suspend ;
|
|
: menu-options ((
|
|
0 s" Phone Book:" yield2
|
|
:| :| ' rick s" 5551212" connect |; close-menu |;
|
|
s" Rick's Clubhouse BBS" yield2
|
|
0 0 yield2
|
|
quiet @ if :| 0 quiet !save |; s" Enable modem sounds" yield2 else
|
|
:| 1 quiet !save |; s" Disable modem sounds" yield2 then
|
|
:| connected? if hangup then textmode exit |; s" Exit to DOS" yield2 )) ;
|
|
|
|
var selection
|
|
: option-walk ( cpstop -- )
|
|
>r selection @ 0 menu-options each
|
|
i if dup selection ! then r@ execute if break then 1+
|
|
next 2drop rdrop ;
|
|
|
|
: prev-option :| 2dup 1+ <= |; option-walk ;
|
|
: next-option :| i if 2dup < else 0 then |; option-walk ;
|
|
: choose menu-options selection @ nth execute ;
|
|
: first-option 0 selection ! next-option prev-option ;
|
|
|
|
25 const menux 7 const menuy
|
|
pagew menux 2* - const menuw
|
|
|
|
: draw-options
|
|
menux 2 + menuy 1+ textxy!
|
|
0 menu-options each
|
|
dup selection @ = if green else magenta then bg!
|
|
textx j if j draw-text then menux menuw + 2 - space-to nextline textx!
|
|
1+ next drop ;
|
|
: draw-menubox
|
|
magenta bg! white fg! 1 boxstyle!
|
|
menux menuy textxy!
|
|
menuw menu-options count 2 + filled draw-box ;
|
|
|
|
: menu-interact sleep-key key>scan
|
|
dup %enter = if choose then
|
|
dup %up = if prev-option then
|
|
dup %down = if next-option then
|
|
%esc = if ' noop close-menu then ;
|
|
|
|
: menu-loop begin draw-options menu-interact menu-onclose @ until ;
|
|
: popup-menu snapshot textstate 0 menu-onclose ! first-option
|
|
draw-menubox menu-loop textstate! menu-onclose @ execute 0 menu-onclose ! ;
|
|
|
|
dbg" startup"
|
|
{ : X ( v -- v ) 2* 1 | ;
|
|
: o ( v -- v ) 2* ; }
|
|
7 const logoh
|
|
6 const logocount
|
|
|
|
array logo
|
|
0 X X X X X o o o >t
|
|
0 X X o o X X o o >t
|
|
0 X X o o X X o o >t
|
|
0 X X o o X X o o >t
|
|
0 X X o o X X o o >t
|
|
0 X X o o X X o o >t
|
|
0 X X X X X o o o >t
|
|
|
|
0 o o o o o o o o >t
|
|
0 o o X X X o o o >t
|
|
0 o o o o o o o o >t
|
|
0 o o X X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o X X X X X X o >t
|
|
|
|
0 o o o o o o o o >t
|
|
0 o o o o o o o o >t
|
|
0 o o X X X X X o >t
|
|
0 o X X o o X X o >t
|
|
0 o X X o o X X o >t
|
|
0 o X X o o X X o >t
|
|
0 o o X X X X X X >t
|
|
|
|
0 o o X X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o o o X X o o o >t
|
|
0 o o X X X X o o >t
|
|
|
|
0 o o o o o o o o >t
|
|
0 o o o o o o o o >t
|
|
0 o o X X X X o o >t
|
|
0 o X X o o X X o >t
|
|
0 o X X X X X X o >t
|
|
0 o X X o o o o o >t
|
|
0 o o X X X X X o >t
|
|
|
|
0 o o o o o o o o >t
|
|
0 o o o o o o o o >t
|
|
0 X X o X X X o o >t
|
|
0 o X X X o X X o >t
|
|
0 o X X o o o o o >t
|
|
0 o X X o o o o o >t
|
|
0 X X X X o o o o >t
|
|
|
|
array logobits
|
|
0xb2 b, 0xdd b, 0xf0 b, 0xde b, 0x1f b, 0x7f b, 0xfe b, 0x0a b, 0xba b,
|
|
target logobits - const logobit-count
|
|
|
|
var curr-logobit
|
|
: logobit curr-logobit @ logobits + ub@ ;
|
|
: nextlogo curr-logobit @ 1+ logobit-count % curr-logobit ! ;
|
|
|
|
: draw-logo
|
|
80 logocount 8 * - 2/ 3 textxy!
|
|
logo logo logoh + for each textx 0 logocount for each
|
|
j i logoh * + ub@
|
|
8 times each dup 0x80 &
|
|
if logobit else [ key lit ] then draw-char 2*
|
|
next drop
|
|
next nextline textx! next ;
|
|
|
|
: animate-logo draw-logo slow
|
|
logobit-count 3 * times each draw-logo 10 sleep-csec nextlogo next ;
|
|
|
|
: splash
|
|
blue bg! lgray fg! sp fill-page lcyan fg! animate-logo
|
|
nl nl 15 textx! lblue bg! lred fg! s" Unregistered version" xmit
|
|
blue bg! lcyan fg! s" - you have used 13246 / 30" xmit-line
|
|
15 textx! s" days of your limited trial!" xmit-line nl nl nl 200 delay
|
|
lgray fg! ;
|
|
|
|
: go init-statusbar splash
|
|
popup-menu begin sleep-key key>scan %esc = if popup-menu then again ;
|
|
|
|
' go ' main redefine
|
|
|
|
dbg" saving"
|
|
{ here s", dialer.com" s" dialtest.com" writeenv }
|
|
|