Программа «Тестирование»(проверка знаний) — Pascal(Паскаль)

{ При запуске требует параметр - имя файла теста }
program test;
uses Crt;
const
     N_LEV=4; { четыре уровня оценки }
     N_ANS=4; { четыре варианта ответов }
label
     kon;
var

     f:text;{ файл теста }
     fn:string[30];{ имя файла теста }

     level:array[1..N_LEV] of integer;{ сумма,определяющая уровнь }
     mes:array[1..N_LEV] of string[80];{ сообщение,соответствующее }
                                       { уровню }
     summa:integer;  { набрано очков }
     vopros:integer; { номер текущего вопроса }
     n_otv:integer;  { число вариантов ответа }
     otv:integer;    { номер выбранного ответа }
     score:array[1..N_ANS] of integer;{ очки за выбор ответа }

     buf:string[80];{ буфер для чтения из файла }

     i:integer;

{ начальная информация о предлагаемом тесте }
procedure info(var f:text);
var
     ch:string[1];{ первый символ прочитанной строки }
begin
     ClrScr;
     repeat
          readln(f,buf);
          ch:=copy(buf,1,1);
          if ch<>'.' then writeln(buf);
     until ch='.';
     writeln;
     write('Для продолжения нажмите <Enter>');
     ch:=readkey;
end;

{ прочитать информацию об оценках за тест }
Procedure GetLevel(var f:text);
var
     i:integer;
     ch:string[1];
begin { заполняем значения глобальных массивов }
     i:=1;
     repeat
          readln(f,buf);
          ch:=copy(buf,1,1);
          if ch<>'.' then begin
               mes[i]:=buf;
               readln(f,level[i]);
               i:=i+1;
          end;
     until ch='.';
end;

{ вывод вопроса на экран }
function VoprosToScr(var f:text;var vopros:integer):integer;
var
     ch:string[1];
     i:integer;
     code:integer;
begin
     clrscr;
     vopros:=vopros+1;
     writeln('Вопрос ',vopros,'.');
     { Выведем текст вопроса }
     repeat
          readln(f,buf);
          ch:=copy(buf,1,1);
          if ch<>'.' then writeln(buf);
     until ch='.';
     for i:=1 to 77 do write(chr(196));
     writeln;
     { Выводим варианты ответов }
     i:=1;
     repeat
          readln(f,buf);
          writeln(i,'.',buf);{ первая строка вопроса }
          repeat { остальные строки вопроса }
               readln(f,buf);
               ch:=copy(buf,1,1);
               if(ch<>'.')and(ch<>',')
                    then writeln(' ',buf)
               else begin { определим, сколько очков за выбор ответа }
                    delete(buf,1,1);
                    val(buf,score[i],code);
                    i:=i+1;
                    writeln;
               end;
          until(ch=',')or(ch='.');
     until ch='.';{ последний ответ вопроса }
     i:=i-1;
     VoprosToScr:=i;{ прочитано i вариантов ответа }
end;

function GetAns(max:integer):integer;
const
     K_ENTER=13;
     K_BACKSPACE=8;
     K_0=48;
var
     ch:char;{ символ }
     dec:integer;{ десятичный код символа }
     maxdec:integer;
     x,y:integer;{ положение курсора }
     code:integer;
     i:integer;{ счетчик введенных цифр }
     n:integer;
begin
     maxdec:=K_0+max;{ 48 ■ код единицы }
     i:=0;
     write('Ваш ответ(1..',max,')-> ');
     repeat
          ch:=readkey;
          dec:=ord(ch);
          if(dec>K_0) and (dec<=maxdec) and (i=0)
               then begin { нажата допустимая цифра }
                         write(ch);
                         val(ch,n,code);
                         i:=i+1;
               end
          else
               if(dec=K_BACKSPACE)and(i=1)
                    then begin
                         i:=0;
                         { сотрем введенную ранее цифру }
                         x:=whereX;
                         y:=whereY;
                         gotoXY(x-1,y);
                         write(' ');
                         gotoXY(x-1,y);
                    end;
     until(i=1)and(dec=K_ENTER);
     GetAns:=n;
end;

procedure Itog(summa:integer);
var
     i:integer;
     ch:char;
begin
     ClrScr;
     writeln('Результаты тестирования');
     for i:=1 to 77 do write(chr(196));
     writeln;
     writeln('Набранная сумма: ',summa);
     i:=1;{ пусть набранная сумма достаточна для первого уровня }
     while (summa<level[i]) and (i<N_LEV) do
          i:=i+1;{ понизим уровень оценки }
     writeln(mes[i]);writeln;
     write('Для завершения нажмите <Enter>');
     ch:=readkey;
end;

begin { главная процедура }
     if ParamCount=0
          then begin
               writeln('Ошибка! Не задан файл вопров теста.');
               writeln('Командная строка:tester ИмяФайла ');
               goto kon;
          end;

     fn:=ParamStr(1);{ получить имя файла теста из командной строки }
     assign(f,fn);
     {$I-}
     reset(f);
     {$I+}
     if IOResult<>0
          then begin
               writeln('Ошибка! Не найден файл тестов:',fn);
               goto kon;
          end;

     { здесь файл текста теста открыт }
     TextBackground(BLUE);
     TextColor(LIGHTGRAY);
     info(f);{ вывести начальное сообщение }
     GetLevel(f);{ читаем уровни и оценки }
     
     summa:=0;{ набрано очков }
     vopros:=0;{ предложено вопросов }

     while not EOF(f) do
     begin { пока есть вопросы в файле }
          n_otv:=VoprosToScr(f,vopros);{ вывести вопрос }
          { n_otv - число вариантов ответа на выведенный вопрос }
          otv:=GetAns(n_otv);{ получить ответ }
          summa:=summa+score[otv];{ добавить очки за ответ }
     end;
     close(f);
     itog(summa);{ вывести результат }
kon:
end.