ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/EDUCATIN/FRENCH.LBR/FRENCH1.PZS/FRENCH1.PAS

Pascal/Delphi Source File | 2000-06-30 | 6KB | 200 lines

(* French vocabulary test program *)
(* by Jon Dart, 1866 Diamond St., San Diego, CA 92109 *)
(* Version 1.9, 10-JUL-85 *)

const
    maxquestions   = 50;     (* max. num of questions/quiz *)

type
    quiztype       = (FRENCHTOENGLISH,ENGLISHTOFRENCH,GENDER);
    repeatoption   = (SAMEWORDS,WRONGWORDS,NEWQUIZ,EXIT);
    stringarray    = array[1..maxquestions] of textline;
    integerarray   = array[1..maxquestions] of integer;
    booleanarray   = array[1..maxquestions] of boolean;

var
     nounfile, nonounfile     :filedesc;
     numquizquestions         :integer;
     numquestions             :integer;
     numnouns,numnonouns      :integer;
     numwrong                 :integer;
     maxitems,k               :integer;
     quizitems                :stringarray;
     order                    :integerarray;
     wrong                    :booleanarray;
     quit                     :boolean;
     quiz                     :quiztype;
     option                   :repeatoption;

procedure openfiles(var nounfile,nonounfile:filedesc);
var
     name1,name2    :textline;
begin
     setstring(name1,'FRNOUN.DAT');
     nounfile := open(name1,IOREAD);
     if nounfile = IOERROR then
          error('Can''t Open FRNOUN.DAT');
     setstring(name2,'FRNONOUN.DAT');
     nonounfile := open(name2,IOREAD);
     if nonounfile = IOERROR then
          error('Can''t Open FRNONOUN.DAT');
end;

procedure readsizes(var numnouns,numnonouns: integer);
 (* read the first lines of NOUN.DAT and NONOUN.DAT, which should contain
    the num of lines in each file *)

var
     s    :textline;
     c    :character;
     i    :integer;
begin
     if getline(s,nounfile,MAXSTR) then
     begin
          i:=1;
          numnouns := ctoi(s,i);
     end;
     if getline(s,nonounfile,MAXSTR) then
     begin
          i := 1;
          numnonouns := ctoi(s,i);
     end;
end;

procedure getquiztype(var quiz:quiztype);

var  c    :character;
     junk :character;
     j,k  :integer;

begin
     writeln;
     writeln('SELECT ONE:');
     writeln;
     writeln('1 - WORD QUIZ: FRENCH TO ENGLISH');
     writeln('2 - WORD QUIZ: ENGLISH TO FRENCH');
     writeln('3 - GENDER QUIZ (NOUNS ONLY)');
     writeln;
     repeat
          write('? ');
          junk := getc(c);
          if not (c in [ord('1'),ord('2'),ord('3')]) then writeln;
     until c in [ord('1'),ord('2'),ord('3')];
     j := c-ord('1');
     quiz := FRENCHTOENGLISH;
     for k:=1 to j do quiz := succ(quiz);
     writeln;
end;

procedure getnumquestions(var quiz:quiztype; var numquestions,
                               maxitems:integer);

var
     ok        :boolean;
     s         :textline;
     i         :integer;
begin
     repeat
          write('HOW MANY QUESTIONS (50 MAX.)? ');
          if getline(s,TRMIN,MAXSTR) then
          begin
               i := 1;
               numquestions := ctoi(s,i);
          end;
          if not numquestions in [0..50] then
          begin
               writeln('ERROR - MUST BE 0-50');
               ok := false;
          end
          else if numquestions > maxitems then
          begin
               writeln('ONLY ',maxitems,' AVAILABLE.');
               ok := false;
          end
          else ok:=true;
     until ok;
end (* getnumquestions *);

procedure ucline(var s:textline);

{ makes line upper-case }

var
     k   :integer;
begin
     k := 1;
     while s[k] <> EOS do
     begin
          s[k] := toupper(s[k]);
          k := k + 1;
     end;
end;

procedure fillarray(var quiz:quiztype;var quizitems:stringarray;
                     numquestions,numnouns,numnonouns,
                     maxitems :integer);

var
     line            :textline;
     t,k,numfilled   :integer;
     endoffile       :boolean;
begin
     writeln;
     writeln('READING DATA FILES');
     numfilled := 0;
     if quiz <> GENDER then
     begin
          t := (numquestions*numnonouns) div maxitems;
          k := 0;  endoffile := false;
          while (t > 0) and (k < numnonouns) and (not endoffile) do
          begin
               if getline(line,nonounfile,MAXSTR) then
               begin
                    k := k + 1;
                    if random <= (t/(numnonouns - k + 1)) then
                    begin
                         numfilled := numfilled + 1;
                         ucline(line);
                         quizitems[numfilled] := line;
                         write('.');
                         t := t - 1;
                    end;
               end
               else endoffile := true;
          end;
     end;
     t := numquestions - numfilled;
     k := 0;  endoffile := false;
     while (t > 0) and (k < numnouns) and (not endoffile) do
     begin
          if getline(line,nounfile,MAXSTR) then
          begin
               k := k + 1;
               if random <= (t/(numnouns - k + 1)) then
               begin
                    numfilled := numfilled + 1;
                    ucline(line);
                    quizitems[numfilled] := line;
                    write('.');
                    t := t - 1;
               end;
          end
          else endoffile := true;
     end;
     writeln;
end (* fillarray *);

procedure scramble(var order:integerarray; numquestions: integer);

var  k,k1,k2,temp  :integer;

begin
     for k:=1 to numquestions*3 do
     begin
          k1 := random(numquestions) + 1;
          k2 := random(numquestions) + 1;
          temp := order[k1]; order[k1] := order[k2]; order[k2] := temp;
     end;
end;