home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG121.ARC / FRENCH.ARK / FRENCH3.PAS < prev    next >
Pascal/Delphi Source File  |  1988-08-07  |  6KB  |  171 lines
  1. begin (* givequiz *)
  2.      numwrong := 0;
  3.      writeln;
  4.      for k := 1 to numquizquestions do
  5.      begin
  6.           wrong[k] := false;
  7.           line := quizitems[order[k]];
  8.           decode(line,french,english,genderchar,error);
  9.           if error then
  10.           begin
  11.                writeln('FORMAT ERROR IN DATA:');
  12.                putstr(line,TRMOUT);
  13.           end
  14.           else
  15.           case quiz of
  16. FRENCHTOENGLISH:  begin
  17.                          putstr(french,TRMOUT);
  18.                          write('? ');
  19.                          if getline(response,TRMIN,MAXSTR) then
  20.                          begin
  21.                               stripnl(response);
  22.                               ucline(response);
  23.                               answerok := match(response,english);
  24.                          end
  25.                          else answerok := false;
  26.                          if not answerok then
  27.                          begin
  28.                               write('     NO ... '); putstr(english,TRMOUT);
  29.                               writeln;
  30.                               wrong[k] := true;
  31.                               numwrong := numwrong + 1;
  32.                          end
  33.                     end;
  34. ENGLISHTOFRENCH:  begin
  35.                          putstr(english,TRMOUT); write('? ');
  36.                          if getline(response,TRMIN,MAXSTR) then
  37.                          begin
  38.                               stripnl(response);
  39.                               ucline(response);
  40.                               answerok := match(response,french);
  41.                          end
  42.                          else answerok := false;
  43.                          if not answerok then
  44.                          begin
  45.                               write('     NO ... '); putstr(french,TRMOUT);
  46.                               writeln;
  47.                               wrong[k] := true;
  48.                               numwrong := numwrong + 1;
  49.                          end;
  50.                     end;
  51. GENDER:   begin
  52.                putstr(french,TRMOUT); write('? ');
  53.                repeat
  54.                     genderresponse := toupper(getc(c));
  55.                until genderresponse in [NEWLINE,ord('M'),ord('F')];
  56.                if genderresponse <> NEWLINE then writeln;
  57.                if genderresponse <> genderchar then
  58.                begin
  59.                     if genderchar = ord('M') then
  60.                          writeln('     NO ... MASCULIN')
  61.                     else
  62.                          writeln('     NO ... FEMININ');
  63.                     wrong[k] := true;
  64.                     numwrong := numwrong + 1;
  65.                end;
  66.           end;
  67.           end (* case *);
  68.      end (* for k *);
  69. end (* givequiz *);
  70.  
  71. procedure givescore(numquestions,numwrong:integer);
  72.  
  73. begin
  74.      writeln;
  75.      writeln(numquestions,' ITEMS GIVEN, ',numwrong,' WRONG.');
  76.      if numquestions > 0 then
  77.    writeln('SCORE = ',(numquestions-numwrong)*100/numquestions:3:0,
  78.              ' PERCENT.');
  79.      writeln;
  80. end;
  81.  
  82. procedure getrepeatoption(var option:repeatoption);
  83.  
  84. var  c       :character;
  85.      j,k     :integer;
  86. begin
  87.      writeln('SELECT ONE:'); writeln;
  88.      writeln('1 - REPEAT WITH SAME WORD LIST');
  89.      writeln('2 - REPEAT ONLY MISSED ITEMS');
  90.      writeln('3 - NEW QUIZ');
  91.      writeln('4 - EXIT PROGRAM');
  92.      repeat
  93.           writeln;
  94.           write('? ');
  95.           c := getc(c);
  96.      until c in [ord('1')..ord('4')];
  97.      writeln;
  98.      option := SAMEWORDS;
  99.      j := c-ord('1');
  100.      for k := 1 to j do option := succ(option);
  101. end;
  102.  
  103. procedure reinit(var option: repeatoption; wrong: booleanarray;
  104.                   numwrong: integer; var numquizquestions: integer);
  105.  
  106. var
  107.      j,k    :integer;
  108.  
  109. begin
  110.      if option = WRONGWORDS then
  111.      begin
  112.           j := 1;
  113.           for k:=1 to numquizquestions do
  114.           if wrong[k] then
  115.           begin
  116.                order[j] := order[k];
  117.                j := j + 1;
  118.           end;
  119.           numquizquestions := numwrong;
  120.      end
  121.      else if option = SAMEWORDS then
  122.      begin
  123.           numquizquestions := numquestions;
  124.           for k:=1 to numquestions do order[k] := k;
  125.      end;
  126.      if option in [WRONGWORDS,SAMEWORDS] then clrscr;
  127. end;
  128.  
  129. begin (* main program *)
  130.      lowvideo; { Turbo intrinsic }
  131.      quit := false;
  132.      ioinit(2);
  133.      randomize; { Turbo intrinsic fn. }
  134.      while (not quit) do
  135.      begin
  136.           clrscr; { Turbo intrinsic fn. }
  137.           writeln('FRENCH VOCABULARY QUIZ PROGRAM');
  138.           writeln;
  139.           writeln('BY JON DART ... VERSION 1.9 (10-JUL-85)');
  140.           openfiles(nounfile,nonounfile);
  141.           getquiztype(quiz);
  142.           readsizes(numnouns,numnonouns);
  143.           if quiz = GENDER then
  144.                maxitems := numnouns
  145.           else
  146.                maxitems := numnouns + numnonouns;
  147.           getnumquestions(quiz,numquestions,maxitems);
  148.           if numquestions > 0 then
  149.           begin
  150.                fillarray(quiz,quizitems,numquestions,
  151.                          numnouns,numnonouns,maxitems);
  152.                for k:=1 to numquestions do order[k] := k;
  153.                numquizquestions := numquestions;
  154.                repeat
  155.                     scramble(order,numquizquestions);
  156.                     givequiz(quiz,order,numquizquestions,quizitems,
  157.                              wrong,numwrong);
  158.                     givescore(numquizquestions,numwrong);
  159.                     getrepeatoption(option);
  160.                     reinit(option,wrong,numwrong,
  161.                            numquizquestions);
  162.                until option in [NEWQUIZ,EXIT];
  163.                quit := option = EXIT;
  164.           end;
  165.           pclose(nounfile);
  166.           pclose(nonounfile);
  167.      end;
  168. end.
  169.  
  170.  
  171.