home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 189.img / TCS120S.ZIP / TRIVIA.PAS < prev    next >
Pascal/Delphi Source File  |  1989-03-30  |  16KB  |  498 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,'AWARDS',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 pts '+
  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.  
  258.           {
  259.            if 0=1  then begin
  260.             writeln('You answered this category already, try tomorrow.');
  261.             exit;
  262.           end;
  263.           }
  264.           seekrec(tfile,catnum,error,trec);
  265.           if trec.correct then
  266.           begin
  267.             writeln(trec.winner+' answered this question correctly already!');
  268.             exit;
  269.           end;
  270.  
  271.           writeln('This will be this questions attempt #'+strr(trec.numanswers+1));
  272.           write('This question will be ');
  273.  
  274.           if trec.check then writeln('Checked by the BBS!')
  275.           else writeln('Checked by the Trivia Sysop!');
  276.           writeln;
  277.           writeln ('The Trivia Question is :');
  278.           writeln(trec.question);
  279.           buflen:=40;
  280.           writestr ('Enter your Guess/Answer: &');
  281.           temp:=input;
  282.           if length(temp)=0 then exit;
  283.           if trec.check then begin
  284.            i:=0;
  285.            correct:=false;
  286.            repeat
  287.              i:=i+1;
  288.              if match(temp,trec.answer[i]) then correct:=true;
  289.            until (i=3) or (trec.answer[i]='-') or (correct);
  290.            trec.numanswers:=trec.numanswers+1;
  291.            seekwrite(tfile,catnum,error,trec);
  292.              if correct then begin
  293.              trec.correct:=true;
  294.              trec.winner:=urec.handle;
  295.              seekwrite(tfile,catnum,error,trec);
  296.              writeln('Congratulations, you answered it correctly!');
  297.              writeln('This question took '+strr(trec.numanswers-1)+' tries!');
  298.              urec.udpoints:=urec.udpoints+3;
  299.              writeln('You won'^S' 3 '^R' File pts. for a total of '^S+strr(urec.udpoints)+^R'.');
  300.              end else writeln('Too bad, that''s wrong!')
  301.           end else
  302.           begin
  303.             assign (ansfile,'Answers');
  304.            if exist ('Answers') then  append(ansfile) else rewrite(ansfile);
  305.             writeln (ansfile,'[Trivia Question:# ',catnum,']');
  306.             writeln (ansfile,'Question:',trec.question);
  307.             writeln (ansfile,'Guessed Answer: ',temp);
  308.             writeln (ansfile,'By: ',urec.handle);
  309.             writeln (ansfile,'On: ',datestr(now),' at ',timestr(now));
  310.             writeln (ansfile,'--------------------');
  311.             textclose (ansfile);
  312.           end;
  313.         { curuser.trivia:=curuser.trivia+[catnum]; }
  314.           atrivia_answers:=atrivia_answers+1
  315.         end
  316.       else writeln ('Invalid category!');
  317.     end;
  318.  
  319.     procedure recentwinners;
  320.     begin
  321.       i:=1;
  322.      if (ansigraphics in urec.config) then write (#27+'[2J');
  323.       writeln (^R'[Category]         [Winner]');
  324.       ansicolor(urec.statcolor);
  325.       while (i<=maxcat)  do
  326.         begin
  327.           seekrec(tfile,i,error,trec);
  328.           tab(strr(i)+': '+trec.catname,20);
  329.           i:=i+1;
  330.           writeln(trec.winner);
  331.         end;
  332.       ansireset;
  333.       if (asciigraphics in urec.config) then
  334.       writeln ('───────────────────────────') else
  335.       writeln ('---------------------------');
  336.     end;
  337.  
  338.     procedure triviahelp;
  339.     begin
  340.       writeln(^B^M^S'Trivia Commands:'^M);
  341.       writeln(^S'[A]:'^R'Answer a trivia question  '^S'[R]:'^R'See Recent winners');
  342.       writeln(^S'[S]:'^R'Trivia Question status    '^S'[C]:'^R'Collect Prizes from T.M.');
  343.       writeln(^S'[Q]:'^R'Quit                      '^S'[?]:'^R'Help');
  344.       writeln;
  345.     end;
  346.  
  347.     procedure triviasysop;
  348.     var choice:anystr;
  349.         erasefile:text;
  350.  
  351.       procedure enterquestion;
  352.       begin
  353.         repeat
  354.           writestr('Question Category [1-'+strr(maxcat)+']:');
  355.           if length(input)>0 then catnum:=valu(input);
  356.         until (catnum>0) and (catnum<=maxcat);
  357.         seekrec(tfile,catnum,error,trec);
  358.         writeln('Category: '+trec.catname);
  359.         Writestr('Enter New Category [CR/no change]: *');
  360.         if length(input)>0 then trec.catname:=input;
  361.         writeln('Question: '+trec.question);
  362.         writestr('Change Question [y/n]? *');
  363.         if yes then
  364.         begin
  365.           writeln('Enter the new Question:');
  366.           writestr(':');
  367.           if length(input)=0 then else
  368.            trec.question:=input;
  369.           writestr('Check Answer On-line [y/n]? *');
  370.           if yes then
  371.           begin
  372.             trec.check:=true;
  373.             writeln('Possible Answers [Max 3 / CR=No more Answers]');
  374.             answernum:=0;
  375.             repeat
  376.               answernum:=answernum+1;
  377.               writestr ('Answer #'+strr(answernum)+': ');
  378.               trec.answer[answernum]:=input;
  379.               if trec.answer[answernum]='' then trec.answer[answernum]:='-'
  380.             until (trec.answer[answernum]='-') or (answernum=3);
  381.           end else trec.check:=false;
  382.           trec.numanswers:=0;
  383.           trec.correct:=false;
  384.           trec.date:=datestr(now);
  385.             Well:=timestr(now);
  386.           trec.time:=well;
  387.           trec.winner:='No one';
  388.           seekwrite(tfile,catnum,error,trec);
  389.          end;
  390.        end;
  391.  
  392.        procedure awards;
  393.        var maxawards : integer;
  394.        begin
  395.          openfile(afile,'Awards',error,sizeof(arec));
  396.          maxawards:=trunc(bigfilesize(afile));
  397.          if maxawards=0 then i:=0 else
  398.          begin
  399.            i:=-1;
  400.            repeat
  401.              i:=i+1;
  402.              seekrec(afile,i,error,arec);
  403.            until (arec.name='-') or (i=maxawards-1);
  404.            if i=maxawards then i:=maxawards;
  405.          end;
  406.          writestr ('Name of User to award: *');
  407.          if length(input)<1 then exit;
  408.          arec.name:=input;
  409.          writestr ('Number of File Points to award him: *');
  410.          arec.award:=valu(input);
  411.          seekwrite (afile,i,error,arec);
  412.          closefile (afile,error);
  413.        end;
  414.  
  415.        procedure tm_editor_help;
  416.        begin
  417.          if exist('Tmeditor.Hlp') then
  418.            printfile('Tmeditor.Hlp') else
  419.            begin
  420.            if (ansigraphics in urec.config) then write (#27+'[2J');
  421.              writeln(^B^M^S'Trivia Editor:'^M);
  422.              writeln(^S'[E]:'^R'Enter a question '^S'[L]:'^R'List answers');
  423.              writeln(^S'[A]:'^R'Award winners    '^S'[D]:'^R'Delete Question');
  424.              writeln(^S'[Q]:'^R'Quit             '^S'[C]:'^R'Create a category ');
  425.              writeln;
  426.            end;
  427.        end;
  428.  
  429.     begin
  430.       repeat
  431.         writestr (^B'Trivia Sysop Command [?/Help]: *');
  432.         if hungupon then exit;
  433.         choice:=upcase(input[1]);
  434.         if (choice='E') then
  435.          if maxcat>0 then enterquestion;
  436.         if (choice='A') then
  437.          awards;
  438.         if (choice='D') then
  439.          begin
  440.           if exist('Answers') then begin
  441.            writestr('Delete ANSWERS File [y/n]? *');
  442.            if yes then begin
  443.             assign(erasefile,'Answers');
  444.             erase(erasefile);
  445.             writeln('ANSWERS file no longer exist.');
  446.            end;
  447.           end else writeln('ANSWERS file does not exist yet!');
  448.          end;
  449.          if (choice='L') then
  450.           printfile('Answers');
  451.          if (choice='C') then
  452.           if maxcat<8 then createcategory else
  453.            writeln('You can not create anymore, maximum is 8 categories.');
  454.          if (choice='?') then
  455.           tm_editor_help;
  456.          if (upcase(choice[1])='Q') then exit;
  457.       until (choice='Q');
  458.     end;
  459.  
  460. begin
  461.   openfile (tfile,'Records',error,sizeof(trec));
  462.   if bigfilesize (tfile)=0 then begin
  463.     trec.numanswers:=0;
  464.     maxcat:=0;
  465.     writerec(tfile,error,trec)
  466.   end else begin
  467.     seekrec (tfile,0,error,trec);
  468.     maxcat:=trec.numanswers;
  469.   end;
  470.   writehdr ('The Trivia Section');
  471.   writeln;
  472.   writeln (^R'Number of Trivia questions: '^S+strr(maxcat)+^R);
  473.   writeln;
  474.   repeat
  475.     writestr (^B'Trivia Command [?/Help]: *');
  476.     if hungupon then exit;
  477.    if ((input[1]='A') or (input[1]='a')) then
  478.     answerquestion;
  479.    if ((input[1]='R') or (input[1]='r')) then
  480.     recentwinners;
  481.    if ((input[1]='C') or (input[1]='c')) then
  482.     collectawards;
  483.    if ((input[1]='S') or (input[1]='s')) then
  484.     categorystatus;
  485.    if (input[1]='%') then
  486.     if ((urec.level>=sysoplevel) or (jsysop in urec.config))
  487.      then triviasysop;
  488.    if (input[1]='?') then
  489.     if exist(textfiledir+'Trivia.Hlp') then
  490.      printfile(textfiledir+'Trivia.Hlp')
  491.       else triviahelp;
  492.   until ((input[1]='Q') or (input[1]='q'));
  493.   closefile(tfile,error);
  494. end;
  495.  
  496. begin
  497. end.
  498.