home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
f
/
faq-s.zip
/
TRIVIA.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-07
|
16KB
|
494 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
{$M 65500,0,0 }
unit trivia;
interface
uses crt,dos,turbo3,
gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2,textret,
mailret,userret,flags,mainr1,ansiedit,lineedit,chatstuf,
mainr2,overret1;
procedure playtrivia;
implementation
procedure playtrivia;
type namestr=string[28];
type string255=string[255];
const isopened=true;
const isclosed=false;
type filetype=record
thefile:file;
open:boolean
end;
var well:anystr;
atrivia_answers:integer;
function fileposit (var filevar:filetype):integer;
begin
fileposit:=filepos(filevar.thefile)
end;
function bigfilesize (var filevar:filetype):real;
begin
bigfilesize:=longfilesize(filevar.thefile)
end;
function eofile (var filevar:filetype):boolean;
begin
eofile:=eof(filevar.thefile)
end;
procedure openfile(var filevar:filetype;filename:string255;
var error:boolean;recsize:integer);
begin
assign(filevar.thefile,filename);
if exist(filename) then
reset(filevar.thefile,recsize)
else
rewrite(filevar.thefile,recsize);
error:=(ioresult<>0);
if not error then filevar.open:=isopened;
end;
procedure writerec(var filevar:filetype;var error:boolean;var readrec);
var therecord:array [0..1000] of integer absolute readrec;
begin
blockwrite(filevar.thefile,therecord,1);
error:=(ioresult<>0)
end;
procedure readrec(var filevar:filetype;var error:boolean;var readrec);
var therecord:array [0..1000] of integer absolute readrec;
begin
blockread(filevar.thefile,therecord,1);
error:=(ioresult<>0)
end;
procedure seekwrite(var filevar:filetype;number:integer;
var error:boolean;var readrec);
var therecord:array [0..1000] of integer absolute readrec;
begin
seek(filevar.thefile,number);
error:=(ioresult<>0);
if not error then
begin
blockwrite(filevar.thefile,therecord,1);
error:=(ioresult<>0)
end
end;
procedure seekrec(var filevar:filetype;number:integer;
var error:boolean;var readrec);
var therecord:array [0..1000] of integer absolute readrec;
begin
seek(filevar.thefile,number);
error:=(ioresult<>0);
if not error then
begin
blockread(filevar.thefile,therecord,1);
error:=(ioresult<>0)
end
end;
procedure closefile(var filevar:filetype;var error:boolean);
begin
close(filevar.thefile);
error:=ioresult<>0;
filevar.open:=isclosed
end;
type triviacategory = record
winner : namestr;
catname : string[20];
date,
time : sstr;
numanswers : integer;
correct,
check : boolean;
question : string255;
answer : array[1..3] of string[40];
end;
awardrecord = record
name : string[28];
award : integer;
end;
var trec : triviacategory;
afile,
tfile : filetype;
arec : awardrecord;
error : boolean;
maxcat : integer;
select : char;
answernum,
catnum : integer;
i : integer;
temp,
scrapstr: string255;
procedure createcategory;
var ii:integer;
begin
writestr(^M'Create Category #'+strr(maxcat+1)+'? [y/n]: *');
if not yes then exit;
writestr(^M'Category Name: *');
buflen:=20;
trec.catname:=input;
trec.question:='';
for ii := 1 to 3 do trec.answer[ii]:='-';
trec.numanswers:=0;
trec.check:=false;
seekwrite(tfile,trunc(bigfilesize(tfile)),error,trec);
seekrec(tfile,0,error,trec);
trec.numanswers:=trec.numanswers+1;
maxcat:=maxcat+1;
seekwrite(tfile,0,error,trec);
end;
procedure categorystatus;
var x : byte;
ans : boolean;
begin
i:=1;
ansicolor (urec.regularcolor);
writeln('[Category] [Ans.] [Date Entered] [Online Check]');
while (i<=maxcat) {and not (cancelled) }
do
begin
writeln;
ansicolor(urec.statcolor);
seekrec(tfile,i,error,trec);
tab(strr(i)+': '+trec.catname,20);
tab(strr(trec.numanswers),7);
tab(trec.date+' at '+trec.time,23);
if 0=0 then begin
if trec.check then
begin
writeln('Online Check');
ansicolor(urec.regularcolor);
begin
ans:=false;
writeln(' Current Question/answer and winner[if there is one]:');
writeln(' Q: '+trec.question);
if trec.winner <> 'No one' then begin
write(' A: ');
for x:=1 to 3 do if trec.answer[x]<>'-' then
begin
if not ans then write(trec.answer[x])
else write(', '+trec.answer[x]);
ans:=true;
end;
writeln(' Winner: '+trec.winner);
end;
end;
ansicolor(urec.statcolor);
end else writeln('No');
end else Write(' ');
i:=i+1;
end;
ansireset;
end;
procedure collectawards;
var maxawards : integer;
collected : boolean;
begin
writeln ('Checking to see if you have any Awards from Trivia Sysop ');
openfile(afile,bbsdatadir+'AWARDS.dat',error,sizeof(arec));
maxawards:=trunc(bigfilesize(afile));
if maxawards=0 then begin
writeln('There are no Prizes from Trivia Sysop (yet)!');
exit;
end;
i:=-1;
collected:=false;
repeat
i:=i+1;
seekrec(afile,i,error,arec);
if match(arec.name,urec.handle) then
begin
urec.udpoints:=urec.udpoints+arec.award;
writeln('You collect '+strr(arec.award)+' file points '+
'for a total of '+strr(urec.udpoints) );
arec.name:='-';
arec.award:=0;
seekwrite(afile,i,error,arec);
collected:=true;
end;
until i=maxawards-1;
closefile(afile,error);
if not collected then writeln('You have no awards!');
end;
procedure answerquestion;
var ansfile : text;
correct : boolean;
cmd : char;
begin
repeat
writestr ('Category [1-'+strr(maxcat)+',Q,?]: *');
cmd:=input[1];
if cmd='?' then
begin
writeln('?');
categorystatus;
end;
if upcase(cmd) in [#13,'Q','A'] then
begin
writeln(cmd);
exit;
end;
until ord(cmd)-48 in [1..maxcat];
catnum:=ord(cmd)-48;
if (catnum>0) and (catnum<=maxcat) then
begin
writeln(strr(catnum));
seekrec(tfile,catnum,error,trec);
if trec.correct then
begin
writeln(trec.winner+' answered this question correctly already!');
exit;
end;
writeln('This will be this questions attempt #'+strr(trec.numanswers+1));
write('This question will be ');
if trec.check then writeln('Checked by the BBS!')
else writeln('Checked by the Trivia Sysop!');
writeln;
writeln ('The Trivia Question is :');
writeln(trec.question);
buflen:=40;
writestr ('Enter your Guess/Answer: &');
temp:=input;
if length(temp)=0 then exit;
if trec.check then begin
i:=0;
correct:=false;
repeat
i:=i+1;
if match(temp,trec.answer[i]) then correct:=true;
until (i=3) or (trec.answer[i]='-') or (correct);
trec.numanswers:=trec.numanswers+1;
seekwrite(tfile,catnum,error,trec);
if correct then begin
trec.correct:=true;
trec.winner:=urec.handle;
seekwrite(tfile,catnum,error,trec);
writeln('Congratulations, you answered it correctly!');
writeln('This question took '+strr(trec.numanswers-1)+' tries!');
urec.udpoints:=urec.udpoints+3;
writeln('You won'^S' 3 '^R' File points for a total of '^S+strr(urec.udpoints)+^R'.');
end else writeln('Too bad, that''s wrong!')
end else
begin
assign (ansfile,bbsdatadir+'Answers.dat');
if exist (bbsdatadir+'Answers.dat') then append(ansfile) else rewrite(ansfile);
writeln (ansfile,'[Trivia Question:# ',catnum,']');
writeln (ansfile,'Question:',trec.question);
writeln (ansfile,'Guessed Answer: ',temp);
writeln (ansfile,'By: ',urec.handle);
writeln (ansfile,'On: ',datestr(now),' at ',timestr(now));
writeln (ansfile,'--------------------');
textclose (ansfile);
end;
{ curuser.trivia:=curuser.trivia+[catnum]; }
atrivia_answers:=atrivia_answers+1
end
else writeln ('Invalid category!');
end;
procedure recentwinners;
begin
i:=1;
if (ansigraphics in urec.config) then write (#27+'[2J');
writeln (^R'[Category] [Winner]');
ansicolor(urec.statcolor);
while (i<=maxcat) do
begin
seekrec(tfile,i,error,trec);
tab(strr(i)+': '+trec.catname,20);
i:=i+1;
writeln(trec.winner);
end;
ansireset;
if (asciigraphics in urec.config) then
writeln ('───────────────────────────') else
writeln ('---------------------------');
end;
procedure triviahelp;
begin
writeln(^B^M^S'Trivia Commands:'^M);
writeln(^S'[A]:'^R'Answer a trivia question '^S'[R]:'^R'See Recent winners');
writeln(^S'[S]:'^R'Trivia Question status '^S'[C]:'^R'Collect Prizes from T.M.');
writeln(^S'[Q]:'^R'Quit '^S'[?]:'^R'Help');
writeln;
end;
procedure triviasysop;
var choice:anystr;
erasefile:text;
procedure enterquestion;
begin
repeat
writestr('Question Category [1-'+strr(maxcat)+']:');
if length(input)>0 then catnum:=valu(input);
until (catnum>0) and (catnum<=maxcat);
seekrec(tfile,catnum,error,trec);
writeln('Category: '+trec.catname);
Writestr('Enter New Category [CR/no change]: *');
if length(input)>0 then trec.catname:=input;
writeln('Question: '+trec.question);
writestr('Change Question? [y/n]: *');
if yes then
begin
writeln (^R'Enter the new Question:');
writestr (': &');
if length(input)=0 then else
trec.question:=input;
{ writestr('Check Answer On-line? [y/n]: *');
if yes then }
if 0=0 then begin
trec.check:=true;
writeln (^R'Possible Answers ['^S'Max 3'^R'] ['^S'CR/No more Answers'^R']');
answernum:=0;
repeat
answernum:=answernum+1;
writestr (^R'Answer #'^S+strr(answernum)+^R': &');
trec.answer[answernum]:=input;
if trec.answer[answernum]='' then trec.answer[answernum]:='-'
until (trec.answer[answernum]='-') or (answernum=3);
end else trec.check:=false;
trec.numanswers:=0;
trec.correct:=false;
trec.date:=datestr(now);
Well:=timestr(now);
trec.time:=well;
trec.winner:='No one';
seekwrite(tfile,catnum,error,trec);
end;
end;
procedure awards;
var maxawards:integer;
begin
openfile(afile,bbsdatadir+'AWARDS.dat',error,sizeof(arec));
maxawards:=trunc(bigfilesize(afile));
if maxawards=0 then i:=0 else
begin
i:=-1;
repeat
i:=i+1;
seekrec (afile,i,error,arec);
until (arec.name='-') or (i=maxawards-1);
if i=maxawards then i:=maxawards;
end;
writestr ('Name of User to award: *');
if length(input)<1 then exit;
arec.name:=input;
writestr (^P'Number of File Points to award '^S+arec.name+^P': *');
arec.award:=valu(input);
seekwrite (afile,i,error,arec);
closefile (afile,error);
end;
procedure tm_editor_help;
begin
begin
if (ansigraphics in urec.config) then write (#27+'[2J');
writeln(^B^M^S'Trivia Editor:'^M);
writeln(^S'[E]:'^R'Enter a question '^S'[L]:'^R'List answers');
writeln(^S'[A]:'^R'Award winners '^S'[D]:'^R'Delete Question');
writeln(^S'[Q]:'^R'Quit '^S'[C]:'^R'Create a category ');
writeln;
end;
end;
begin
if ((urec.level<sysoplevel) and not (jsysop in urec.config)) then exit;
repeat
writestr (^B'Trivia Sysop Command [?/Help]: *');
if hungupon then exit;
choice:=upcase(input[1]);
if (choice='E') then
if maxcat>0 then enterquestion;
if (choice='A') then
awards;
if (choice='D') then
begin
if exist(bbsdatadir+'Answers.dat') then begin
writestr('Delete Answers File? [y/n]: *');
if yes then begin
assign(erasefile,bbsdatadir+'Answers.dat');
erase(erasefile);
writeln('Answer file no longer exist.');
end;
end else writeln('Answer file does not exist yet!');
end;
if (choice='L') then
printfile('Answers');
if (choice='C') then
if maxcat<8 then createcategory else
writeln('You can not create anymore, maximum is 8 categories.');
if (choice='?') then
tm_editor_help;
if (upcase(choice[1])='Q') then exit;
until (choice='Q');
end;
procedure printtriviahelp;
begin
writeln(^B^M^S'Trivia Commands:'^M);
writeln(^S'[A]:'^R'Answer a trivia question '^S'[R]:'^R'See Recent winners');
writeln(^S'[S]:'^R'Trivia Question status '^S'[C]:'^R'Collect Prizes from T.M.');
writeln(^S'[Q]:'^R'Quit '^S'[?]:'^R'Help');
writeln;
end;
var cc:char;
begin
openfile (tfile,bbsdatadir+'Records.dat',error,sizeof(trec));
if bigfilesize (tfile)=0 then begin
trec.numanswers:=0;
maxcat:=0;
writerec(tfile,error,trec)
end else begin
seekrec (tfile,0,error,trec);
maxcat:=trec.numanswers;
end;
writehdr ('Trivia Section');
writeln;
writeln (^R'Number of Trivia questions: '^S+strr(maxcat)+^R);
writeln;
repeat
writestr (^B'Trivia Command [?/Help]: *');
if hungupon then exit;
cc:=upcase(input[1]);
case cc of
'A':answerquestion;
'R':recentwinners;
'C':collectawards;
'S':categorystatus;
'?':printtriviahelp;
'%':triviasysop;
end;
until cc='Q';
closefile (tfile,error);
end;
begin
end.