home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol280 / german.lbr / GERMAN3.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-06-11  |  5.9 KB  |  170 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,german,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. GERMANTOENGLISH:  begin
  17.                          putstr(german,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. ENGLISHTOGERMAN:  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,german);
  41.                          end
  42.                          else answerok := false;
  43.                          if not answerok then
  44.                          begin
  45.                               write('     NO ... '); putstr(german,TRMOUT);
  46.                               writeln;
  47.                               wrong[k] := true;
  48.                               numwrong := numwrong + 1;
  49.                          end;
  50.                     end;
  51. GENDER:   begin
  52.                putstr(german,TRMOUT); write('? ');
  53.                repeat
  54.                     genderresponse := toupper(getc(c));
  55.                until genderresponse in [NEWLINE,ord('N'),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 ... MASCULINE')
  61.                     else if genderchar = ord('F') then
  62.                          writeln('     NO ... FEMININE')
  63.                     else
  64.                          writeln('     NO ... NEUTER');
  65.                     wrong[k] := true;
  66.                     numwrong := numwrong + 1;
  67.                end;
  68.           end;
  69.           end (* case *);
  70.      end (* for k *);
  71. end (* givequiz *);
  72.  
  73. procedure givescore(numquestions,numwrong:integer);
  74.  
  75. begin
  76.      writeln;
  77.      writeln(numquestions,' ITEMS GIVEN, ',numwrong,' WRONG.');
  78.      if numquestions > 0 then
  79.    writeln('SCORE = ',(numquestions-numwrong)*100/numquestions:3:0,
  80.              ' PERCENT.');
  81.      writeln;
  82. end;
  83.  
  84. procedure getrepeatoption(var option:repeatoption);
  85.  
  86. var  c       :character;
  87.      j,k     :integer;
  88. begin
  89.      writeln('SELECT ONE:'); writeln;
  90.      writeln('1 - REPEAT WITH SAME WORD LIST');
  91.      writeln('2 - REPEAT ONLY MISSED ITEMS');
  92.      writeln('3 - NEW QUIZ');
  93.      writeln('4 - EXIT PROGRAM');
  94.      repeat
  95.           writeln; write('? ');
  96.           c := getc(c);
  97.      until c in [ord('1')..ord('4')];
  98.      writeln;
  99.      option := SAMEWORDS;
  100.      j := c-ord('1');
  101.      for k := 1 to j do option := succ(option);
  102. end;
  103.  
  104. procedure reinit(var option: repeatoption; wrong: booleanarray;
  105.                   numwrong: integer; var numquizquestions: integer);
  106.  
  107. var
  108.      j,k    :integer;
  109.  
  110. begin
  111.      if option = WRONGWORDS then
  112.      begin
  113.           j := 1;
  114.           for k:=1 to numquizquestions do
  115.           if wrong[k] then
  116.           begin
  117.                order[j] := order[k];
  118.                j := j + 1;
  119.           end;
  120.           numquizquestions := numwrong;
  121.      end
  122.      else if option = SAMEWORDS then
  123.      begin
  124.           numquizquestions := numquestions;
  125.           for k:=1 to numquestions do order[k] := k;
  126.      end;
  127.      if option in [WRONGWORDS,SAMEWORDS] then clrscr;
  128. end;
  129.  
  130. begin (* main program *)
  131.      lowvideo; { Turbo intrinsic }
  132.      quit := false;
  133.      ioinit(2);
  134.      randomize; { Turbo intrinsic fn. }
  135.      while (not quit) do
  136.      begin
  137.           clrscr; { Turbo intrinsic fn. }
  138.           writeln('GERMAN VOCABULARY QUIZ PROGRAM');
  139.           writeln;
  140.           writeln('BY JON DART ... VERSION 2.0 (01-MAR-86)');
  141.           openfiles(nounfile,nonounfile);
  142.           getquiztype(quiz);
  143.           readsizes(numnouns,numnonouns);
  144.           if quiz = GENDER then
  145.                maxitems := numnouns
  146.           else
  147.                maxitems := numnouns + numnonouns;
  148.           getnumquestions(quiz,numquestions,maxitems);
  149.           if numquestions > 0 then
  150.           begin
  151.                fillarray(quiz,quizitems,numquestions,
  152.                          numnouns,numnonouns,maxitems);
  153.                for k:=1 to numquestions do order[k] := k;
  154.                numquizquestions := numquestions;
  155.                repeat
  156.                     scramble(order,numquizquestions);
  157.                     givequiz(quiz,order,numquizquestions,quizitems,
  158.                              wrong,numwrong);
  159.                     givescore(numquizquestions,numwrong);
  160.                     getrepeatoption(option);
  161.                     reinit(option,wrong,numwrong,
  162.                            numquizquestions);
  163.                until option in [NEWQUIZ,EXIT];
  164.                quit := option = EXIT;
  165.           end;
  166.           pclose(nounfile);
  167.           pclose(nonounfile);
  168.      end;
  169. end.
  170.