home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.wwiv.com
/
ftp.wwiv.com.zip
/
ftp.wwiv.com
/
pub
/
DOOR
/
DDPLUS67.ZIP
/
BBSLIST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-11-21
|
20KB
|
737 lines
{-------------------------------------------------------------------------}
{ }
{ Program: BBS-LIST }
{ }
{ Purpose: Maintains a bbs list database. Demonstrates use of ANSIMENU }
{ unit. }
{ }
{-------------------------------------------------------------------------}
{$V-}
{$M 32768,0,256000}
uses dos, crt, ddplus;
const
comps: array[1..10] of string[20]=
('IBM', 'Amiga', 'Apple', 'Atari',
'C-64', 'Mac', 'Coco', 'other',
'other', 'other');
compbig: array[1..10] of string[30]=
('IBM & Compatibles', 'Commodore Amiga',
'Apple', 'Atari',
'Commodore C-64', 'Tandy Color Computer',
'Other', 'Other',
'Other', 'Other');
menu1: menutype =
(header: 'BBS-List Maintenance System';
footer: 'Please type a command letter';
headercolor: green;
footercolor: lightgreen;
optioncolor: yellow;
desccolor: white;
arrowcolor: lightred;
bracketcolor: lightgray;
numoptions: 10;
options: ('A','B','C','D','E','F','G','H','I','Q','','','','','',
'','','','','');
desc: ('Enter a New Listing', 'Edit an existing listing',
'Display 80-col GRPX', 'Display 80-col ASCII',
'Display 132-col GRPX', 'Display 132-col ASCII',
'Write lists to disk', 'Sort Listing',
'Statistics', 'Quit to bbs',
'', '',
'','','','','','','',''));
type
bbsentry= record
active: boolean;
board_name: string[20];
number: string[8];
hours: string[10];
max_baud: word;
allow3: boolean;
megs: word;
network: string[10];
sysop_name: string[20];
software: string[10];
pay: boolean;
computers: array[1..10] of byte;
comments: array[1..5] of string[80];
end;
var
bbsfile: file of bbsentry;
bbs: bbsentry;
f: text;
todisk: boolean;
sortmode: integer;
procedure add_system;
var
s: string;
a: integer;
begin;
sclrscr;
set_foreground(green);
swriteln('Add a bbs to the list');
swriteln('');
set_foreground(default_fore);
bbs.active:=true;
swrite(' Board Name: '); prompt(bbs.board_name,20,true);
swrite(' Phone number: '); prompt(bbs.number,8,true);
swrite(' Hours: '); prompt(bbs.hours,10,true);
swrite(' Max baud: '); prompt(s,4,true); val(s,bbs.max_baud,a);
swrite(' 300 allowed (Y/N): '); prompt(s,1,true); if (s='Y') or (s='y') then bbs.allow3:=true else bbs.allow3:=false;
swrite(' Megabytes storage: '); prompt(s,4,true); val(s,bbs.megs,a);
swrite(' Network address: '); prompt(bbs.network,10,true);
swrite(' Sysop name: '); prompt(bbs.sysop_name,20,true);
swrite(' Software: '); prompt(bbs.software,10,true);
swrite(' Pay required (Y/N): '); prompt(s,1,true); if (s='Y') or (s='y') then bbs.pay:=true else bbs.pay:=false;
for a:=1 to 7 do begin;
s:=comps[a];
while length(s)<11 do s:=' '+s;
swrite(s+' (Y/N/M):');
prompt(s,1,true);
if (s='Y') or (s='y') then bbs.computers[a]:=1 else bbs.computers[a]:=0;
if (s='M') or (s='m') then bbs.computers[a]:=2;
end;
swriteln('');
swriteln('Comments: 5 lines max');
for a:=1 to 5 do begin;
swrite(va(a)+':'); prompt(bbs.comments[a],75,true);
end;
swriteln('');
swrite('Add this entry ? '); sread(s);
if (s='Y') or (s='y') then begin;
seek(bbsfile,filesize(bbsfile));
write(bbsfile,bbs);
end;
end;
procedure textout(s: string);
begin;
if todisk then writeln(f,s) else swriteln(s);
end;
procedure copystring(src: string; var dest: string; num: integer);
var
a: integer;
begin;
for a:=1 to num do dest:=dest+src;
end;
procedure display_80_asc_old;
var
a: integer;
s,s2: string;
begin;
textout(' ┌─────┬─┬─┬─┬─┬─┬─┬─┬──────┬─┬─┐');
textout(' │ │I│A│A│A│C│M│C│ │3│$│');
textout(' │ M │B│m│p│t│o│a│o│ B R │0│P│');
textout(' │ E │M│i│p│a│m│c│C│ A A │0│A│');
textout(' │ G │ │g│l│r│m│ │o│ U T │ │Y│');
textout(' │ S │ │a│e│i│ │ │ │ D E │ │$│');
textout(' System Name Phone # │ │ │ │ │ │ │ │ │ │ │ │ Hours');
s:='';
copystring('─',s,31);
s:=s+'┼';
copystring('─',s,5);
s:=s+'┼─┼─┼─┼─┼─┼─┼─┼─────┼─┼─┼';
copystring('─',s,9);
s:=s+'┐';
textout(s);
reset(bbsfile);
while not eof(bbsfile) do begin;
read(bbsfile,bbs);
s:=' '+bbs.board_name;
while length(s)<23 do s:=s+' ';
s:=s+bbs.number;
while length(s)<31 do s:=s+' ';
s:=s+'│ ';
s2:=va(bbs.megs);
while length(s2)<3 do s2:=' '+s2;
s:=s+s2+' │';
for a:=1 to 7 do begin;
if bbs.computers[a]=1 then s:=s+'■│';
if bbs.computers[a]=0 then s:=s+' │';
if bbs.computers[a]=2 then s:=s+'▓│';
end;
str(bbs.max_baud,s2);
while length(s2)<4 do s2:=' '+s2;
s:=s+s2+' │';
if bbs.allow3 then s:=s+'■' else s:=s+' ';
s:=s+'│';
if bbs.pay then s:=s+'■' else s:=s+' ';
s:=s+'│';
s2:=bbs.hours;
while length(s2)<9 do s2:=s2+' ';
s:=s+s2+'│';
textout(s);
end;
end;
procedure display_80_asc;
var
a: integer;
s,s2: string;
begin;
textout(' ┌─┬─┬─┬─┬─┬─┬─┬─┬─┐');
textout(' │I│A│A│A│C│M│C│N│$│');
textout(' │B│m│p│t│o│a│o│O│P│');
textout(' │M│i│p│a│m│c│C│3│A│');
textout(' │ │g│l│r│m│ │o│0│Y│');
textout(' │ │a│e│i│ │ │ │0│$│');
textout(' System Name Phone # Megs │ │ │ │ │ │ │ │ │ │ Baud Hours');
s:='┌';
copystring('─',s,31);
s:=s+'┬';
copystring('─',s,6);
s:=s+'┼─┼─┼─┼─┼─┼─┼─┼─┼─┼';
copystring('─',s,6);
s:=s+'┬';
copystring('─',s,10);
s:=s+'┐';
textout(s);
reset(bbsfile);
while not eof(bbsfile) do begin;
read(bbsfile,bbs);
s:='│ '+bbs.board_name;
while length(s)<23 do s:=s+' ';
s:=s+bbs.number;
while length(s)<32 do s:=s+' ';
s:=s+'│ ';
s2:=va(bbs.megs);
while length(s2)<4 do s2:=' '+s2;
s:=s+s2+' │';
for a:=1 to 7 do begin;
if bbs.computers[a]=1 then s:=s+'■│';
if bbs.computers[a]=0 then s:=s+' │';
if bbs.computers[a]=2 then s:=s+'▓│';
end;
if not bbs.allow3 then s:=s+'■' else s:=s+' ';
s:=s+'│';
if bbs.pay then s:=s+'■' else s:=s+' ';
s:=s+'│';
str(bbs.max_baud,s2);
while length(s2)<5 do s2:=' '+s2;
s:=s+s2+' │ ';
s2:=bbs.hours;
while length(s2)<9 do s2:=s2+' ';
s:=s+s2+'│';
textout(s);
end;
s:='└';
copystring('─',s,31);
s:=s+'┴';
copystring('─',s,6);
s:=s+'┴─┴─┴─┴─┴─┴─┴─┴─┴─┴';
copystring('─',s,6);
s:=s+'┴';
copystring('─',s,10);
s:=s+'┘';
textout(s);
end;
procedure display_132_asc;
var
a: integer;
s,s2: string;
begin;
textout(' ┌─┬─┬─┬─┬─┬─┬─┬─┬─┐');
textout(' │I│A│A│A│C│M│C│N│$│');
textout(' │B│m│p│t│o│a│o│O│P│');
textout(' │M│i│p│a│m│c│C│3│A│');
textout(' │ │g│l│r│m│ │o│0│Y│');
textout(' │ │a│e│i│ │ │ │0│$│');
textout(' System Name Phone # Megs │ │ │ │ │ │ │ │ │ │ Baud Hours Software Sysop'+
' Network');
s:='┌';
copystring('─',s,31);
s:=s+'┬';
copystring('─',s,6);
s:=s+'┼─┼─┼─┼─┼─┼─┼─┼─┼─┼';
copystring('─',s,6);
s:=s+'┬';
copystring('─',s,10);
s:=s+'┬';
copystring('─',s,15);
s:=s+'┬';
copystring('─',s,20);
s:=s+'┬';
copystring('─',s,10);
s:=s+'┐';
textout(s);
reset(bbsfile);
while not eof(bbsfile) do begin;
read(bbsfile,bbs);
s:='│ '+bbs.board_name;
while length(s)<23 do s:=s+' ';
s:=s+bbs.number;
while length(s)<32 do s:=s+' ';
s:=s+'│ ';
s2:=va(bbs.megs);
while length(s2)<4 do s2:=' '+s2;
s:=s+s2+' │';
for a:=1 to 7 do begin;
if bbs.computers[a]=1 then s:=s+'■│';
if bbs.computers[a]=0 then s:=s+' │';
if bbs.computers[a]=2 then s:=s+'▓│';
end;
if not bbs.allow3 then s:=s+'■' else s:=s+' ';
s:=s+'│';
if bbs.pay then s:=s+'■' else s:=s+' ';
s:=s+'│';
str(bbs.max_baud,s2);
while length(s2)<5 do s2:=' '+s2;
s:=s+s2+' │ ';
s2:=bbs.hours;
while length(s2)<9 do s2:=s2+' ';
s:=s+s2+'│';
s2:=' '+bbs.software;
while length(s2)<15 do s2:=s2+' ';
s:=s+s2+'│';
s2:=' '+bbs.sysop_name;
while length(s2)<20 do s2:=s2+' ';
s:=s+s2+'│';
s2:=' '+bbs.network;
while length(s2)<10 do s2:=s2+' ';
s:=s+s2+'│';
textout(s);
end;
s:='└';
copystring('─',s,31);
s:=s+'┴';
copystring('─',s,6);
s:=s+'┴─┴─┴─┴─┴─┴─┴─┴─┴─┴';
copystring('─',s,6);
s:=s+'┴';
copystring('─',s,10);
s:=s+'┴';
copystring('─',s,15);
s:=s+'┴';
copystring('─',s,20);
s:=s+'┴';
copystring('─',s,10);
s:=s+'┘';
textout(s);
end;
procedure display_80_txt;
var
a: integer;
s,s2: string;
begin;
textout(' +-----------------+');
textout(' :I:A:A:A:C:M:C:N:$:');
textout(' :B:m:p:t:o:a:o:O:P:');
textout(' :M:i:p:a:m:c:C:3:A:');
textout(' : :g:l:r:m: :o:0:Y:');
textout(' : :a:e:i: : : :0:$:');
textout(' System Name Phone # Megs : : : : : : : : : : Baud Hours');
s:='';
copystring('-',s,32);
s:=s+'+';
copystring('-',s,6);
s:=s+'+-+-+-+-+-+-+-+-+-+';
copystring('-',s,6);
s:=s+'+';
copystring('-',s,10);
{s:=s+'┐';}
textout(s);
reset(bbsfile);
while not eof(bbsfile) do begin;
read(bbsfile,bbs);
s:=' '+bbs.board_name;
while length(s)<23 do s:=s+' ';
s:=s+bbs.number;
while length(s)<32 do s:=s+' ';
s:=s+': ';
s2:=va(bbs.megs);
while length(s2)<4 do s2:=' '+s2;
s:=s+s2+' :';
for a:=1 to 7 do begin;
if bbs.computers[a]=1 then s:=s+'*:';
if bbs.computers[a]=0 then s:=s+' :';
if bbs.computers[a]=2 then s:=s+'X:';
end;
if not bbs.allow3 then s:=s+'*' else s:=s+' ';
s:=s+':';
if bbs.pay then s:=s+'*' else s:=s+' ';
s:=s+':';
str(bbs.max_baud,s2);
while length(s2)<5 do s2:=' '+s2;
s:=s+s2+' : ';
s2:=bbs.hours;
while length(s2)<9 do s2:=s2+' ';
s:=s+s2 {+'│'};
textout(s);
end;
s:='';
copystring('-',s,32);
s:=s+'+';
copystring('-',s,6);
s:=s+'+-+-+-+-+-+-+-+-+-+';
copystring('-',s,6);
s:=s+'+';
copystring('-',s,10);
textout(s);
end;
procedure display_132_txt;
var
a: integer;
s,s2: string;
begin;
textout(' +-----------------+');
textout(' :I:A:A:A:C:M:C:N:$:');
textout(' :B:m:p:t:o:a:o:O:P:');
textout(' :M:i:p:a:m:c:C:3:A:');
textout(' : :g:l:r:m: :o:0:Y:');
textout(' : :a:e:i: : : :0:$:');
textout(' System Name Phone # Megs : : : : : : : : : : Baud Hours Software Sysop'+
' Network');
s:='+';
copystring('-',s,31);
s:=s+'+';
copystring('-',s,6);
s:=s+'+-+-+-+-+-+-+-+-+-+';
copystring('-',s,6);
s:=s+'+';
copystring('-',s,10);
s:=s+'+';
copystring('-',s,15);
s:=s+'+';
copystring('-',s,20);
s:=s+'+';
copystring('-',s,10);
s:=s+'+';
textout(s);
reset(bbsfile);
while not eof(bbsfile) do begin;
read(bbsfile,bbs);
s:=': '+bbs.board_name;
while length(s)<23 do s:=s+' ';
s:=s+bbs.number;
while length(s)<32 do s:=s+' ';
s:=s+': ';
s2:=va(bbs.megs);
while length(s2)<4 do s2:=' '+s2;
s:=s+s2+' :';
for a:=1 to 7 do begin;
if bbs.computers[a]=1 then s:=s+'*:';
if bbs.computers[a]=0 then s:=s+' :';
if bbs.computers[a]=2 then s:=s+'X:';
end;
if not bbs.allow3 then s:=s+'*' else s:=s+' ';
s:=s+':';
if bbs.pay then s:=s+'*' else s:=s+' ';
s:=s+':';
str(bbs.max_baud,s2);
while length(s2)<5 do s2:=' '+s2;
s:=s+s2+' : ';
s2:=bbs.hours;
while length(s2)<9 do s2:=s2+' ';
s:=s+s2+':';
s2:=' '+bbs.software;
while length(s2)<15 do s2:=s2+' ';
s:=s+s2+':';
s2:=' '+bbs.sysop_name;
while length(s2)<20 do s2:=s2+' ';
s:=s+s2+':';
s2:=' '+bbs.network;
while length(s2)<10 do s2:=s2+' ';
s:=s+s2+':';
textout(s);
end;
s:='+';
copystring('-',s,31);
s:=s+'+';
copystring('-',s,6);
s:=s+'+-+-+-+-+-+-+-+-+-+';
copystring('-',s,6);
s:=s+'+';
copystring('-',s,10);
s:=s+'+';
copystring('-',s,15);
s:=s+'+';
copystring('-',s,20);
s:=s+'+';
copystring('-',s,10);
s:=s+'+';
textout(s);
end;
procedure DisplayStats;
var
cstats: array[1..10] of byte;
a,b: integer;
numsystems: integer;
s,s2,s3: string;
begin;
numsystems:=0;
for b:=1 to 10 do cstats[b]:=0;
for a:=1 to filesize(bbsfile)-1 do begin;
seek(bbsfile,a);
read(bbsfile,bbs);
for b:=1 to 10 do if bbs.computers[b]=2 then inc(cstats[b]);
inc(numsystems);
end;
textout('System Statisics: ');
textout('');
s3:='';
for a:=1 to 7 do begin;
if length(s3)>40 then begin;
textout(s3);
s3:='';
end;
s:=compbig[a];
while length(s)<25 do s:=s+'.';
s2:=va(cstats[a]);
while length(s2)<2 do s2:=s2+' ';
s:=s+' '+s2+', ';
str(round(cstats[a]/numsystems*100),s2);
s:=s+s2+'%';
s3:=s3+s;
while length(s3)<40 do s3:=s3+' ';
end;
if length(s)<40 then textout(s);
end;
procedure write_to_disk;
begin;
assign(f,'BBS80.ASC');
rewrite(f);
todisk:=true;
display_80_asc;
close(f);
assign(f,'BBS132.ASC');
rewrite(f);
display_132_asc;
close(f);
assign(f,'BBS80.TXT');
rewrite(f);
display_80_txt;
close(f);
assign(f,'BBS132.TXT');
rewrite(f);
display_132_txt;
close(f);
assign(f,'STATS.TXT');
rewrite(f);
displaystats;
close(f);
todisk:=false;
end;
procedure display_thing(s,s2: string);
begin;
set_foreground(green);
swrite(s);
set_foreground(white);
swriteln(s2);
set_foreground(default_fore);
end;
function yn(b: boolean): string;
begin;
if b then yn:='Yes' else yn:='No';
end;
procedure display_rec;
var
a: integer;
begin;
display_thing('A. Board Name.......... ',bbs.board_name);
display_thing('B. Phone number........ ',bbs.number);
display_thing('C. Hours............... ',bbs.hours);
display_thing('D. Max baud............ ',va(bbs.max_baud));
display_thing('E. 300 allowed (Y/N)... ',yn(bbs.allow3));
display_thing('F. Megabytes storage... ',va(bbs.megs));
display_thing('G. Network address..... ',bbs.network);
display_thing('H. Sysop name.......... ',bbs.sysop_name);
display_thing('I. Software............ ',bbs.software);
display_thing('J. Pay required (Y/N).. ',yn(bbs.pay));
display_thing('K. Systems............. ','');
set_foreground(lightcyan);
swriteln('L. Comments:');
set_foreground(white);
for a:=1 to 5 do if bbs.comments[a]<>'' then swriteln(bbs.comments[a]);
set_foreground(default_fore);
end;
procedure edit_systems;
const
comptype: array[0..2] of string[10]=
('No','Yes','Main');
var
s: string;
ctype: string;
a,b: integer;
begin;
repeat;
sclrscr;
for a:=1 to 7 do begin;
ctype:=comps[a];
while length(ctype)<15 do ctype:=ctype+'.';
display_thing(va(a)+'. '+ctype,comptype[bbs.computers[a]]);
end;
swriteln('');
swrite('Enter option to change, or <9> to quit ? '); sread_num(a);
if (a>0) and (a<8) then begin;
swrite(comps[a]+' (Y/N/M) ? '); prompt(s,1,true); s:=stu(s);
if s='Y' then bbs.computers[a]:=1;
if s='N' then bbs.computers[a]:=0;
if s='M' then bbs.computers[a]:=2;
end;
until a=9;
end;
procedure edit_bbslist;
var
s: string;
num,oldnum: integer;
a: integer;
begin;
num:=0;
repeat;
seek(bbsfile,num);
read(bbsfile,bbs);
oldnum:=num;
repeat;
sclrscr;
display_rec;
swriteln('');
swrite('Enter letter to change, <N>ext, <P>rev, <Q>uit ? ');
sread(s);
s:=stu(s);
if s='A' then begin;
swrite('System name: '); prompt(bbs.board_name,20,true);
end;
if s='B' then begin;
swrite('Number: '); prompt(bbs.number,8,true);
end;
if s='C' then begin;
swrite('Hours: '); prompt(bbs.hours,9,true);
end;
if s='D' then begin;
swrite('Maximum baud: '); prompt(s,4,true);
val(s,bbs.max_baud,a);
end;
if s='E' then begin;
swrite('300 allowed (Y/N): '); prompt(s,1,true);
if (s='Y') or (s='y') then bbs.allow3:=true else bbs.allow3:=false;
end;
if s='F' then begin;
swrite('Megs storage: '); prompt(s,4,true);
val(s,bbs.megs,a);
end;
if s='G' then begin;
swrite('Network address: '); prompt(bbs.network,10,true);
end;
if s='H' then begin;
swrite('Sysop name: '); prompt(bbs.sysop_name,20,true);
end;
if s='I' then begin;
swrite('Software: '); prompt(bbs.software,10,true);
end;
if s='J' then begin;
swrite('Pay required (Y/N)? '); prompt(s,1,true);
if (s='Y') or (s='y') then bbs.pay:=true else bbs.pay:=false;
end;
if s='K' then edit_systems;
if s='N' then if num<filesize(bbsfile)-1 then num:=num+1;
if s='P' then if num>0 then num:=num-1;
until s[1] in ['N','P','Q'];
seek(bbsfile,oldnum);
write(bbsfile,bbs);
until s='Q';
end;
procedure DoMore;
var
ch: char;
begin;
swrite('<More>');
sread_char(ch);
end;
function Lower(rec1,rec2: bbsentry): boolean;
begin;
case sortmode of
1: if rec1.board_name<rec2.board_name then lower:=true else lower:=false;
2: if rec1.max_baud<rec2.max_baud then lower:=true else lower:=false;
3: if rec1.megs<rec2.megs then lower:=true else lower:=false;
end;
end;
procedure SortList;
type
sorttype= array[1..75] of bbsentry;
sortptr= ^sorttype;
var
i1,i2: sortptr;
numrecs: word;
a,nm2,lownum: byte;
begin;
new(i1);
new(i2);
sclrscr;
swrite('Sort mode: 1=Name, 2=Baud, 3=Megs ? ');
sread_num(sortmode);
numrecs:=0;
reset(bbsfile);
while not eof(bbsfile) do begin;
inc(numrecs);
read(bbsfile,i1^[numrecs]);
end;
nm2:=0;
repeat;
lownum:=0;
for a:=1 to numrecs do if i1^[a].active then begin;
if lownum=0 then lownum:=a else if lower(i1^[a],i1^[lownum]) then lownum:=a;
end;
if lownum<>0 then begin;
inc(nm2);
i2^[nm2]:=i1^[lownum];
i1^[lownum].active:=false;
end;
until lownum=0;
rewrite(bbsfile);
for a:=1 to nm2 do write(bbsfile,i2^[a]);
reset(bbsfile);
dispose(i1);
dispose(i2);
end;
procedure bbslist_menu;
var
n: integer;
ch: char;
begin;
repeat;
ch:=getansimenu(menu1);
if ch in ['C','D','E','F','I'] then sclrscr;
case ch of
'A': add_system;
'B': edit_bbslist;
'C': Display_80_asc;
'D': Display_80_txt;
'E': Display_132_asc;
'F': display_132_txt;
'G': write_to_disk;
'H': SortList;
'I': DisplayStats;
end;
if ch in ['C','D','E','F','I'] then DoMore;
until ch='Q';
end;
begin;
checkbreak:=true;
initdoordriver('doordriv.ctl');
todisk:=false;
filemode:=66;
assign(bbsfile,'bbslist.dat');
if not exist('bbslist.dat') then rewrite(bbsfile) else reset(bbsfile);
bbslist_menu;
close(bbsfile);
end.