home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / FAQ-S.ZIP / TRIVIA.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-07  |  15.2 KB  |  494 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+,O+ }
  2. {$M 65500,0,0 }
  3.  
  4. unit trivia;
  5.  
  6. interface
  7.  
  8. uses crt,dos,turbo3,
  9.      gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2,textret,
  10.      mailret,userret,flags,mainr1,ansiedit,lineedit,chatstuf,
  11.      mainr2,overret1;
  12.  
  13. procedure playtrivia;
  14.  
  15. implementation
  16.  
  17. procedure playtrivia;
  18.  
  19. type namestr=string[28];
  20. type string255=string[255];
  21.  
  22. const isopened=true;
  23. const isclosed=false;
  24. type filetype=record
  25.                thefile:file;
  26.                open:boolean
  27.               end;
  28. var well:anystr;
  29.     atrivia_answers:integer;
  30.  
  31. function fileposit (var filevar:filetype):integer;
  32. begin
  33.  fileposit:=filepos(filevar.thefile)
  34. end;
  35.  
  36. function bigfilesize (var filevar:filetype):real;
  37. begin
  38.  bigfilesize:=longfilesize(filevar.thefile)
  39. end;
  40.  
  41. function eofile (var filevar:filetype):boolean;
  42. begin
  43.  eofile:=eof(filevar.thefile)
  44. end;
  45.  
  46. procedure openfile(var filevar:filetype;filename:string255;
  47.                    var error:boolean;recsize:integer);
  48. begin
  49.   assign(filevar.thefile,filename);
  50.   if exist(filename) then
  51.     reset(filevar.thefile,recsize)
  52.   else
  53.     rewrite(filevar.thefile,recsize);
  54.   error:=(ioresult<>0);
  55.   if not error then filevar.open:=isopened;
  56. end;
  57.  
  58. procedure writerec(var filevar:filetype;var error:boolean;var readrec);
  59. var therecord:array [0..1000] of integer absolute readrec;
  60.  
  61. begin
  62.  blockwrite(filevar.thefile,therecord,1);
  63.  error:=(ioresult<>0)
  64. end;
  65.  
  66. procedure readrec(var filevar:filetype;var error:boolean;var readrec);
  67. var therecord:array [0..1000] of integer absolute readrec;
  68.  
  69. begin
  70.   blockread(filevar.thefile,therecord,1);
  71.   error:=(ioresult<>0)
  72. end;
  73.  
  74. procedure seekwrite(var filevar:filetype;number:integer;
  75.                   var error:boolean;var readrec);
  76.  
  77. var therecord:array [0..1000] of integer absolute readrec;
  78.  
  79. begin
  80.   seek(filevar.thefile,number);
  81.   error:=(ioresult<>0);
  82.   if not error then
  83.   begin
  84.     blockwrite(filevar.thefile,therecord,1);
  85.     error:=(ioresult<>0)
  86.   end
  87. end;
  88.  
  89. procedure seekrec(var filevar:filetype;number:integer;
  90.                   var error:boolean;var readrec);
  91.  
  92. var therecord:array [0..1000] of integer absolute readrec;
  93.  
  94. begin
  95.   seek(filevar.thefile,number);
  96.   error:=(ioresult<>0);
  97.   if not error then
  98.   begin
  99.     blockread(filevar.thefile,therecord,1);
  100.     error:=(ioresult<>0)
  101.   end
  102. end;
  103.  
  104. procedure closefile(var filevar:filetype;var error:boolean);
  105. begin
  106.   close(filevar.thefile);
  107.   error:=ioresult<>0;
  108.   filevar.open:=isclosed
  109. end;
  110.  
  111. type triviacategory = record
  112.                        winner     : namestr;
  113.                        catname    : string[20];
  114.                        date,
  115.                        time       : sstr;
  116.                        numanswers : integer;
  117.                        correct,
  118.                        check      : boolean;
  119.                        question   : string255;
  120.                        answer     : array[1..3] of string[40];
  121.                       end;
  122. awardrecord = record
  123.                name  : string[28];
  124.                award : integer;
  125.               end;
  126.  
  127. var trec    : triviacategory;
  128.     afile,
  129.     tfile   : filetype;
  130.     arec    : awardrecord;
  131.     error   : boolean;
  132.     maxcat  : integer;
  133.     select  : char;
  134.     answernum,
  135.     catnum  : integer;
  136.     i       : integer;
  137.     temp,
  138.     scrapstr: string255;
  139.  
  140.     procedure createcategory;
  141.     var ii:integer;
  142.     begin
  143.       writestr(^M'Create Category #'+strr(maxcat+1)+'? [y/n]: *');
  144.       if not yes then exit;
  145.       writestr(^M'Category Name: *');
  146.       buflen:=20;
  147.       trec.catname:=input;
  148.       trec.question:='';
  149.       for ii := 1 to 3 do trec.answer[ii]:='-';
  150.       trec.numanswers:=0;
  151.       trec.check:=false;
  152.       seekwrite(tfile,trunc(bigfilesize(tfile)),error,trec);
  153.       seekrec(tfile,0,error,trec);
  154.       trec.numanswers:=trec.numanswers+1;
  155.       maxcat:=maxcat+1;
  156.       seekwrite(tfile,0,error,trec);
  157.     end;
  158.  
  159.     procedure categorystatus;
  160.     var x   : byte;
  161.         ans : boolean;
  162.     begin
  163.       i:=1;
  164.       ansicolor (urec.regularcolor);
  165.       writeln('[Category]         [Ans.] [Date Entered]          [Online Check]');
  166.       while (i<=maxcat) {and not (cancelled) }
  167.       do
  168.         begin
  169.           writeln;
  170.           ansicolor(urec.statcolor);
  171.           seekrec(tfile,i,error,trec);
  172.           tab(strr(i)+': '+trec.catname,20);
  173.           tab(strr(trec.numanswers),7);
  174.           tab(trec.date+' at '+trec.time,23);
  175.           if 0=0 then begin
  176.             if trec.check then
  177.             begin
  178.               writeln('Online Check');
  179.               ansicolor(urec.regularcolor);
  180.               begin
  181.                 ans:=false;
  182.                 writeln(' Current Question/answer and winner[if there is one]:');
  183.                 writeln(' Q: '+trec.question);
  184.                 if  trec.winner <> 'No one' then begin
  185.                  write(' A: ');
  186.                  for x:=1 to 3 do if trec.answer[x]<>'-' then
  187.                  begin
  188.                   if not ans then write(trec.answer[x])
  189.                   else write(', '+trec.answer[x]);
  190.                   ans:=true;
  191.                  end;
  192.                  writeln('   Winner: '+trec.winner);
  193.                 end;
  194.                end;
  195.               ansicolor(urec.statcolor);
  196.             end else writeln('No');
  197.           end else Write(' ');
  198.           i:=i+1;
  199.         end;
  200.       ansireset;
  201.     end;
  202.  
  203.     procedure collectawards;
  204.     var maxawards : integer;
  205.         collected : boolean;
  206.     begin
  207.       writeln ('Checking to see if you have any Awards from Trivia Sysop ');
  208.       openfile(afile,bbsdatadir+'AWARDS.dat',error,sizeof(arec));
  209.       maxawards:=trunc(bigfilesize(afile));
  210.       if maxawards=0 then begin
  211.         writeln('There are no Prizes from Trivia Sysop (yet)!');
  212.         exit;
  213.       end;
  214.       i:=-1;
  215.       collected:=false;
  216.       repeat
  217.         i:=i+1;
  218.         seekrec(afile,i,error,arec);
  219.         if match(arec.name,urec.handle) then
  220.         begin
  221.           urec.udpoints:=urec.udpoints+arec.award;
  222.           writeln('You collect '+strr(arec.award)+' file points '+
  223.                      'for a total of '+strr(urec.udpoints) );
  224.           arec.name:='-';
  225.           arec.award:=0;
  226.           seekwrite(afile,i,error,arec);
  227.           collected:=true;
  228.         end;
  229.       until i=maxawards-1;
  230.       closefile(afile,error);
  231.       if not collected then writeln('You have no awards!');
  232.     end;
  233.  
  234.     procedure answerquestion;
  235.     var ansfile : text;
  236.         correct : boolean;
  237.         cmd     : char;
  238.     begin
  239.       repeat
  240.         writestr ('Category [1-'+strr(maxcat)+',Q,?]: *');
  241.         cmd:=input[1];
  242.         if cmd='?' then
  243.         begin
  244.           writeln('?');
  245.           categorystatus;
  246.         end;
  247.         if upcase(cmd) in [#13,'Q','A'] then
  248.         begin
  249.           writeln(cmd);
  250.           exit;
  251.         end;
  252.       until ord(cmd)-48 in [1..maxcat];
  253.       catnum:=ord(cmd)-48;
  254.       if (catnum>0) and (catnum<=maxcat) then
  255.         begin
  256.           writeln(strr(catnum));
  257.           seekrec(tfile,catnum,error,trec);
  258.           if trec.correct then
  259.           begin
  260.             writeln(trec.winner+' answered this question correctly already!');
  261.             exit;
  262.           end;
  263.  
  264.           writeln('This will be this questions attempt #'+strr(trec.numanswers+1));
  265.           write('This question will be ');
  266.  
  267.           if trec.check then writeln('Checked by the BBS!')
  268.           else writeln('Checked by the Trivia Sysop!');
  269.           writeln;
  270.           writeln ('The Trivia Question is :');
  271.           writeln(trec.question);
  272.           buflen:=40;
  273.           writestr ('Enter your Guess/Answer: &');
  274.           temp:=input;
  275.           if length(temp)=0 then exit;
  276.           if trec.check then begin
  277.            i:=0;
  278.            correct:=false;
  279.            repeat
  280.              i:=i+1;
  281.              if match(temp,trec.answer[i]) then correct:=true;
  282.            until (i=3) or (trec.answer[i]='-') or (correct);
  283.            trec.numanswers:=trec.numanswers+1;
  284.            seekwrite(tfile,catnum,error,trec);
  285.              if correct then begin
  286.              trec.correct:=true;
  287.              trec.winner:=urec.handle;
  288.              seekwrite(tfile,catnum,error,trec);
  289.              writeln('Congratulations, you answered it correctly!');
  290.              writeln('This question took '+strr(trec.numanswers-1)+' tries!');
  291.              urec.udpoints:=urec.udpoints+3;
  292.              writeln('You won'^S' 3 '^R' File points for a total of '^S+strr(urec.udpoints)+^R'.');
  293.              end else writeln('Too bad, that''s wrong!')
  294.           end else
  295.           begin
  296.             assign (ansfile,bbsdatadir+'Answers.dat');
  297.            if exist (bbsdatadir+'Answers.dat') then  append(ansfile) else rewrite(ansfile);
  298.             writeln (ansfile,'[Trivia Question:# ',catnum,']');
  299.             writeln (ansfile,'Question:',trec.question);
  300.             writeln (ansfile,'Guessed Answer: ',temp);
  301.             writeln (ansfile,'By: ',urec.handle);
  302.             writeln (ansfile,'On: ',datestr(now),' at ',timestr(now));
  303.             writeln (ansfile,'--------------------');
  304.             textclose (ansfile);
  305.           end;
  306.         { curuser.trivia:=curuser.trivia+[catnum]; }
  307.           atrivia_answers:=atrivia_answers+1
  308.         end
  309.       else writeln ('Invalid category!');
  310.     end;
  311.  
  312.     procedure recentwinners;
  313.     begin
  314.       i:=1;
  315.      if (ansigraphics in urec.config) then write (#27+'[2J');
  316.       writeln (^R'[Category]         [Winner]');
  317.       ansicolor(urec.statcolor);
  318.       while (i<=maxcat)  do
  319.         begin
  320.           seekrec(tfile,i,error,trec);
  321.           tab(strr(i)+': '+trec.catname,20);
  322.           i:=i+1;
  323.           writeln(trec.winner);
  324.         end;
  325.       ansireset;
  326.       if (asciigraphics in urec.config) then
  327.       writeln ('───────────────────────────') else
  328.       writeln ('---------------------------');
  329.     end;
  330.  
  331.     procedure triviahelp;
  332.     begin
  333.       writeln(^B^M^S'Trivia Commands:'^M);
  334.       writeln(^S'[A]:'^R'Answer a trivia question  '^S'[R]:'^R'See Recent winners');
  335.       writeln(^S'[S]:'^R'Trivia Question status    '^S'[C]:'^R'Collect Prizes from T.M.');
  336.       writeln(^S'[Q]:'^R'Quit                      '^S'[?]:'^R'Help');
  337.       writeln;
  338.     end;
  339.  
  340.     procedure triviasysop;
  341.     var choice:anystr;
  342.         erasefile:text;
  343.  
  344.       procedure enterquestion;
  345.       begin
  346.         repeat
  347.           writestr('Question Category [1-'+strr(maxcat)+']:');
  348.           if length(input)>0 then catnum:=valu(input);
  349.         until (catnum>0) and (catnum<=maxcat);
  350.         seekrec(tfile,catnum,error,trec);
  351.         writeln('Category: '+trec.catname);
  352.         Writestr('Enter New Category [CR/no change]: *');
  353.         if length(input)>0 then trec.catname:=input;
  354.         writeln('Question: '+trec.question);
  355.         writestr('Change Question? [y/n]: *');
  356.         if yes then
  357.         begin
  358.           writeln (^R'Enter the new Question:');
  359.           writestr (': &');
  360.           if length(input)=0 then else
  361.            trec.question:=input;
  362.         { writestr('Check Answer On-line? [y/n]: *');
  363.           if yes then }
  364.           if 0=0 then begin
  365.             trec.check:=true;
  366.             writeln (^R'Possible Answers ['^S'Max 3'^R'] ['^S'CR/No more Answers'^R']');
  367.             answernum:=0;
  368.             repeat
  369.               answernum:=answernum+1;
  370.               writestr (^R'Answer #'^S+strr(answernum)+^R': &');
  371.               trec.answer[answernum]:=input;
  372.               if trec.answer[answernum]='' then trec.answer[answernum]:='-'
  373.             until (trec.answer[answernum]='-') or (answernum=3);
  374.           end else trec.check:=false;
  375.           trec.numanswers:=0;
  376.           trec.correct:=false;
  377.           trec.date:=datestr(now);
  378.             Well:=timestr(now);
  379.           trec.time:=well;
  380.           trec.winner:='No one';
  381.           seekwrite(tfile,catnum,error,trec);
  382.          end;
  383.        end;
  384.  
  385.        procedure awards;
  386.        var maxawards:integer;
  387.        begin
  388.       openfile(afile,bbsdatadir+'AWARDS.dat',error,sizeof(arec));
  389.       maxawards:=trunc(bigfilesize(afile));
  390.          if maxawards=0 then i:=0 else
  391.          begin
  392.            i:=-1;
  393.            repeat
  394.              i:=i+1;
  395.              seekrec (afile,i,error,arec);
  396.            until (arec.name='-') or (i=maxawards-1);
  397.            if i=maxawards then i:=maxawards;
  398.          end;
  399.          writestr ('Name of User to award: *');
  400.          if length(input)<1 then exit;
  401.          arec.name:=input;
  402.          writestr (^P'Number of File Points to award '^S+arec.name+^P': *');
  403.          arec.award:=valu(input);
  404.          seekwrite (afile,i,error,arec);
  405.          closefile (afile,error);
  406.        end;
  407.  
  408.        procedure tm_editor_help;
  409.        begin
  410.            begin
  411.            if (ansigraphics in urec.config) then write (#27+'[2J');
  412.              writeln(^B^M^S'Trivia Editor:'^M);
  413.              writeln(^S'[E]:'^R'Enter a question '^S'[L]:'^R'List answers');
  414.              writeln(^S'[A]:'^R'Award winners    '^S'[D]:'^R'Delete Question');
  415.              writeln(^S'[Q]:'^R'Quit             '^S'[C]:'^R'Create a category ');
  416.              writeln;
  417.            end;
  418.        end;
  419.  
  420.     begin
  421.      if ((urec.level<sysoplevel) and not (jsysop in urec.config)) then exit;
  422.       repeat
  423.         writestr (^B'Trivia Sysop Command [?/Help]: *');
  424.         if hungupon then exit;
  425.         choice:=upcase(input[1]);
  426.         if (choice='E') then
  427.          if maxcat>0 then enterquestion;
  428.         if (choice='A') then
  429.          awards;
  430.         if (choice='D') then
  431.          begin
  432.           if exist(bbsdatadir+'Answers.dat') then begin
  433.            writestr('Delete Answers File? [y/n]: *');
  434.            if yes then begin
  435.             assign(erasefile,bbsdatadir+'Answers.dat');
  436.             erase(erasefile);
  437.             writeln('Answer file no longer exist.');
  438.            end;
  439.           end else writeln('Answer file does not exist yet!');
  440.          end;
  441.          if (choice='L') then
  442.           printfile('Answers');
  443.          if (choice='C') then
  444.           if maxcat<8 then createcategory else
  445.            writeln('You can not create anymore, maximum is 8 categories.');
  446.          if (choice='?') then
  447.           tm_editor_help;
  448.          if (upcase(choice[1])='Q') then exit;
  449.       until (choice='Q');
  450.     end;
  451.  
  452. procedure printtriviahelp;
  453. begin
  454.       writeln(^B^M^S'Trivia Commands:'^M);
  455.       writeln(^S'[A]:'^R'Answer a trivia question  '^S'[R]:'^R'See Recent winners');
  456.       writeln(^S'[S]:'^R'Trivia Question status    '^S'[C]:'^R'Collect Prizes from T.M.');
  457.       writeln(^S'[Q]:'^R'Quit                      '^S'[?]:'^R'Help');
  458.       writeln;
  459. end;
  460.  
  461. var cc:char;
  462. begin
  463.   openfile (tfile,bbsdatadir+'Records.dat',error,sizeof(trec));
  464.   if bigfilesize (tfile)=0 then begin
  465.     trec.numanswers:=0;
  466.     maxcat:=0;
  467.     writerec(tfile,error,trec)
  468.   end else begin
  469.     seekrec (tfile,0,error,trec);
  470.     maxcat:=trec.numanswers;
  471.   end;
  472.   writehdr ('Trivia Section');
  473.   writeln;
  474.   writeln (^R'Number of Trivia questions: '^S+strr(maxcat)+^R);
  475.   writeln;
  476.   repeat
  477.     writestr (^B'Trivia Command [?/Help]: *');
  478.     if hungupon then exit;
  479.     cc:=upcase(input[1]);
  480.     case cc of
  481.      'A':answerquestion;
  482.      'R':recentwinners;
  483.      'C':collectawards;
  484.      'S':categorystatus;
  485.      '?':printtriviahelp;
  486.      '%':triviasysop;
  487.     end;
  488.   until cc='Q';
  489.   closefile (tfile,error);
  490. end;
  491.  
  492. begin
  493. end.
  494.