116 lines
3.8 KiB
Plaintext
Executable file
116 lines
3.8 KiB
Plaintext
Executable file
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 }
|
|
|
|
: 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
|
|
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!"
|
|
' 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: " inputch
|
|
dup [ key m lit ] = if
|
|
lred fg! l" Sorry, message boards are not available to guests." then
|
|
dup [ key g lit ] = if
|
|
lred fg! l" Sorry, games are not available to guests." then
|
|
dup [ key p lit ] = if swap drop ' page-rick swap then
|
|
dup [ key f lit ] = if swap drop ' rick-files swap then
|
|
[ key h lit ] = if
|
|
lcyan fg! l" Thank you for calling!" 300 delay return then
|
|
dup until ; ' rick-menu redefine
|
|
|
|
: rick
|
|
black bg! white fg!
|
|
sp [ pagew 3 * lit ] repeated xmit-iter
|
|
rick-welcome-rle xmit-screen login
|
|
' rick-menu begin execute dup not until ;
|
|
|