Program určený na testovanie žiakov z rôznych predmetov

{ TESTUJ.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Program urceny na testovanie ziakov z roznych predmetov.          }
{ Pre svoju cinnost potrebuje subor test.txt a vytvara subory s     }
{ koncovkou tes. Format suboru testuj.cfg najdete v subore          }
{ testuj.txt.                                                       }
{                                                                   }
{ Datum:08.11.2005                             http://www.trsek.com }
 
program testovanie_ziakov;
uses crt,dos;
 
const TST_MENO='testuj.cfg';       { takto sa vola subor s testom }
      ZIAK_ZOZ='ziaci.txt';        { zoznam testovanych ziakov    }
      TST_KON='.tes';              { koncovka s vysledkom testu   }
 
var o:char;
    cesta,test:string;                  { cesta odkial je spusteny program }
    mt1,mt2:string;                     { meno testu 1,2 riadok   }
    meno:string;                        { meno skusaneho ziaka    }
    znam:array[1..5,1..2] of byte;      { rozsah bodov pre znamky }
    odp :array[1..4] of byte;           { body za aktualne odpovede }
    pb:byte;                            { celkovy pocet bodov       }
    po:byte;                            { pocet otazok              }
    px,py:byte;            { pozicia vypisovania textu na obrazovku }
 
 
{ zisti ci existuje subor }
function JeSubor(txtfile:string):boolean;
var f:text;
begin
  {$I-} { - zakaze vypisovanie chyb }
  Assign(f,cesta+txtfile);
  Reset(f);
  Close(f);
  {$I+}
 
  if(IOResult<>0)then JeSubor:=false
                 else JeSubor:=true;
end;
 
 
{ zisti cestu odkial je program spustany }
function DajCestu:string;
var s:string;
    i:integer;
begin
  s:=ParamStr(0);
  i:=Length(s);
 
  while((i>0) and (s[i]<>'\')) do
   begin
    Delete(s,i,1);
    i:=i-1;
   end;
 
  DajCestu:=s;
end;
 
 
{ zlucuje textbackground a textcolor }
procedure farba(x,y:integer);
begin
  textbackground(x);
  textcolor(y);
end;
 
 
{ zlucuje procedury gotoxy() a write() }
procedure WriteXY(x,y:integer;tex:string);
begin
  gotoxy(x,y);
  write(tex);
end;
 
 
{ prevedie retazec na cislo }
function ToInt(s:string):integer;
var i,err:integer;
begin
  Val(s,i,err);
  ToInt:=i;
end;
 
 
{ prevedie cislo na retazec }
function ToStr(i:integer):string;
var s:string;
begin
  Str(i,s);
  ToStr:=s;
end;
 
 
{ prevedie vsetky znaky na velke pismena }
function SUpCase(s:string):string;
var i:integer;
begin
  for i:=1 to Length(s) do
    s[i]:=UpCase(s[i]);
 
  SUpCase:=s;
end;
 
 
{ pocka na stlaceni klavesu }
procedure Pause;
begin
  farba(black,lightgray);
  WriteXY(10,22, 'Stlac klaves <ENTER> pre pokracovanie.');
  ReadKey;
end;
 
 
{ oddeli od retazca prev slovo az po medzeru }
function DivPos(var s:string):string;
var pom:string;
    i:integer;
begin
  { najdeme prvu medzeru }
  i:=Pos(' ',s);
 
  if (i=0) then begin
    pom:=s;
    s:='';
  end
  else begin
    pom:=Copy(s,1,i-1);
    { zmazeme zaciatocne slovo }
    Delete(s,1,i);
  end;
 
  DivPos:=pom;
end;
 
 
{ precita zo suboru meno testu, pocet bodov }
{ znamkove hodnotenie, a spocita celkovy pocet bodov }
procedure AnalyzeTest;
var f:text;
    s:string;
    i,max:integer;
    odpoved:boolean;
begin
  if not(JeSubor(test)) then
  begin
     Writexy(10,5,'Subor s testom ' +test+ ' neexistuje.');
     Writexy(10,6,'Nebude mozne pokracovat v programe.');
     pause;
     exit;
  end;
 
  Assign(f,cesta+test);
  Reset(f);
 
  { meno testu }
  ReadLn(f,mt1);
  ReadLn(f,mt2);
 
  { znamky }
  ReadLn(f,i,znam[1,1],znam[1,2]);
  ReadLn(f,i,znam[2,1],znam[2,2]);
  ReadLn(f,i,znam[3,1],znam[3,2]);
  ReadLn(f,i,znam[4,1],znam[4,2]);
  ReadLn(f,i,znam[5,1],znam[5,2]);
 
  { znulujeme }
  po:=0;
  pb:=0;
  max:=0;
  odpoved:=false;
 
  { budeme hladat pocet otazok a spocitame maximalny pocet bodov }
  while (not(eof(f))) do
   begin
     ReadLn(f,s);
 
     { tu zacina otazka }
     if (s='+') then begin
       po:=po+1;
       pb:=pb+max;
       max:=0;
       odpoved:=false;
     end;
 
     { ak su to otazky zistujem pocet bodov }
     if (odpoved) then begin
        i:=ToInt(DivPos(s));
        if (i>max) then max:=i;
     end;
 
     { tu zacinu odpovede }
     if (s='-') then
       odpoved:=true;
   end;
 
  po:=po-1;     { posledne plus neratam }
  Close(f);
end;
 
 
{ podla mnozstva bodov urci znamku }
function Oznamkuj(body:integer):byte;
var i,zn:integer;
begin
  zn:=5;
 
  for i:=1 to 5 do
    if((znam[i,1]>=body) and (znam[i,2]<=body)) then
      zn:=i;
 
  Oznamkuj:=zn;
end;
 
 
{ uvodna obrazovka }
procedure Uvod(typ,ot,body,cbody:integer);
begin
  clrscr;
 
  { vypise nazov testu }
  farba(blue,yellow);
  writexy(10,4,mt1);
  writexy(10,5,mt2);
 
  farba(black,lightgray);
 
  if(typ=0) then begin
    writexy(10,7,'1. Spusti test');
    writexy(10,8,'2. Zobraz vysledky ziakov');
    writexy(10,9,'3. Koniec');
  end;
 
  if(typ=1) then begin
    writexy(10,6,'Otazka      : ' + ToStr(ot) + ' z '+ ToStr(po));
    writexy(10,7,'Pocet bodov : ' + 'spolu '+ ToStr(pb));
    writexy(10,8,'Meno ziaka  : ' + meno +'    ');
  end;
 
  if(typ=3) or (typ=4) then begin
    writexy(10,6,'Otazka      : ' + ToStr(ot) + ' z '+ ToStr(po));
    writexy(10,7,'Pocet bodov : ' + ToStr(body) + ' z '+ ToStr(cbody));
    writexy(10,8,'Meno ziaka  : ' + meno +'    ');
    Writexy(10,9,'Znamka      : ' + ToStr(Oznamkuj(cbody)));
  end;
 
  if(typ=4) then
    Writexy(10,9,'Znamka      : ' + ToStr(Oznamkuj(body)));
end;
 
 
{ zapise meno noveho ziaka a povie aky je v poradi }
function NovyZiak(s:string):integer;
var f:text;
    por:integer;
    pom:string;
begin
  { ak neexistuje zalozim novy }
  if not(JeSubor(ZIAK_ZOZ)) then begin
     Assign(f,cesta+ZIAK_ZOZ);
     ReWrite(f);
     Close(f);
  end;
 
  { otvorime subor pre spocitanie ziakov }
  por:=1;
  Assign(f,cesta+ZIAK_ZOZ);
  ReSet(f);
 
  { spocitame pocet ziakov }
  while( not(eof(f))) do begin
    ReadLn(f,pom);
    por:=por+1;
  end;
 
  Close(f);
 
  { na koniec pripoji noveho ziaka }
  Append(f);
  Write(f,por,' ');
  WriteLn(f,s);
  Close(f);
 
  { ma taketo poradove cislo }
  NovyZiak:=por;
end;
 
 
{ z cisel 1,2,3,4 urobi moznosti a,b,c,d }
function Moznost(i:byte):string;
begin
  Moznost:=chr(i+ ord('a') -1) +') ';
end;
 
 
{ na obrazovku vypise bud zadanie, alebo moznosti }
procedure NaObr(je_odp:boolean;s:string);
var dlz:integer;
    pom:string;
begin
  while (Length(s)>0) do begin
    pom:=DivPos(s);
    dlz:=Length(pom);
 
    { este sa vojde do riadku ? }
    if( px+dlz>65 ) then begin
       py:=py+1;
       px:=1;
 
       { ak to bude a,b,c,d zarovna az zane }
       if( je_odp )then px:=4;
    end;
 
    writexy(10+px,10+py,pom+' ');
    px:=px+dlz+1;
  end;
end;
 
 
{ na monitor vypise otazku cislo por }
{ tu ktoru urcil ziak oznaci cervenou, spravnu zelenou }
function NapisOtazku(por:integer;dobre,zle:byte):string;
var f:text;
    s:string;
    poc,i:integer;
    moz:array[1..4] of string;
begin
  Assign(f,cesta+test);
  Reset(f);
  { default }
  NapisOtazku:='';
  px:=1; py:=1;
  i:=0;
 
  { najdeme zaciatok otazky }
  while(i<por) do begin
    ReadLn(f,s);
    if(s='+')then i:=i+1;
  end;
 
  { precitame text zadania otazky }
  farba(blue,yellow);
  ReadLn(f,s);
  while(s<>'-') do begin
    NaObr(false,s);
    ReadLn(f,s);
  end;
 
  poc:=0; py:=py+1;
  ReadLn(f,s);
 
  { precitame otazky }
  while (s<>'+') do begin
    poc:=poc+1;
 
    { kolko bodov ma tato odpoved }
    odp[poc]:=ToInt(DivPos(s));
 
    { ulozime si tuto moznost }
    moz[poc]:=s;
 
    { citaj dalsiu odpoved }
    ReadLn(f,s);
  end;
 
  { bud vsetky moznosti vypiseme }
  { alebo to bude 1 moznost a potom nepiseme nic }
  if( poc>1 )then
    for i:=1 to poc do begin
       { akou farbou to vypisem, je to dobra/zla odpoved }
       farba(black,lightgray);
       if (i=zle)   then farba(red, lightgray);
       if (i=dobre) then farba(green, lightgray);
 
       px:=1; py:=py+1;
       NaObr(true,Moznost(i)+moz[i]);
     end
  else
   begin
     NapisOtazku:=moz[1];
     odp[2]:=0;
   end;
 
  farba(black,lightgray);
  Close(f);
end;
 
 
{ caka odpoved a,b,c,d alebo konkretny text? }
{ zarovan bude pocitat aj body }
function Odpoved(s:string;var body:integer):string;
var por:integer;
    sodp:string;
begin
  { caka a,b,c,d }
  if(s='')then
   begin
     repeat
       o:=readkey;
     until (o in ['a'..'d','A'..'D']);
 
     { pripocita body ak neake su }
     por:=ord(UpCase(o))-ord('A')+1;
     body:=body+odp[por];
     sodp:=ToStr(por);
   end
  else
   { caka text odpovede }
   begin
     px:=1; py:=py+1;
     NaObr(true,'Odpoved:');
     ReadLn(sodp);
 
     { vsetko dame velkym }
     if( SUpCase(s)=SUpCase(sodp)) then
        body:=body+odp[1];
   end;
 
   Odpoved:=sodp;
end;
 
 
{ zacne testovanie ziakov }
procedure Testuj;
var f:text;
    i,por:integer;
    body:integer;
    s,sodp:string;
    o:char;
begin
  Uvod(2,0,0,0);
  writexy(10,6,'Zadaj svoje meno: ');
  Readln(meno);
 
  { zapise do zoznamu studentov a dostane cislo }
  por:=NovyZiak(meno);
  body:=0;
 
  { otvori subor pre zapis }
  Assign(f, cesta+ToStr(por)+TST_KON);
  ReWrite(f);
  WriteLn(f,meno);
 
  { kladie otazky od 1 do n }
  for i:=1 to po do begin
    { vypise aky je stav }
    Uvod(1,i,body,0);
 
    { napise otazku a pocka na odpoved }
    s:=NapisOtazku(i,0,0);
    sodp:=Odpoved(s,body);
 
    { zapise do suboru cislo otazky a odpoved }
    WriteLn(f,i,' ',sodp);
  end;
 
  { zapiseme body/znamku zavrie subor }
  WriteLn(f,body);
  Close(f);
 
  { oznamkuj ho }
  Uvod(4,po,body,pb);
  Pause;
end;
 
 
{ najde najvacsie bodove ohodnotenie }
function NajdiOdpoved:integer;
var max,i,imax:integer;
begin
  imax:=1;
  max:=odp[imax];
 
  for i:=2 to 4 do
    if(odp[i]>max) then begin
      max:=odp[i];
      imax:=i;
    end;
 
  NajdiOdpoved:=imax;
end;
 
 
{ vyberie si ziaka z poradovnika }
function VyberZiaka:integer;
var f:text;
    por,zac:integer;
    spolu:integer;
    koniec:boolean;
    ch:char;
    i,x:integer;
    s:string;
begin
  Assign(f,cesta+ZIAK_ZOZ);
  ReSet(f);
 
  { zisti cislo posledneho ziaka }
  while (not(eof(f))) do
    ReadLn(f,spolu,meno);
 
  zac:=0; por:=1;
  koniec:=false;
 
  repeat
    Close(f);
    Reset(f);
 
    { precitam az po zaciatok }
    i:=0;
    Uvod(2,0,0,0);
    for x:=1 to zac do ReadLn(f,i,s);
 
    while (not(eof(f)) and (i<(zac+10))) do begin
      ReadLn(f,i,s);
      WriteXY(11,6+i-zac,ToStr(i) +'.' +s);
    end;
 
    WriteXY(10,22,'Stlac 0 az 9 pre vyber ziaka. o-stranka vpred, p-stranka vzad');
 
    ch:=ReadKey;
    { vybral si od 1..9 }
    if(ch in ['1'..'9','0']) then begin
       por:=zac+Ord(ch)-Ord('1')+1;
       koniec:=true;
    end;
 
    { vybral si 0 tam musim pripocitat 10 }
    if(ch='0') then por:=zac+10;
 
    { chce sa presunut o stranku o-vpred, p-vzad }
    if(ch='o') and (zac>0) then zac:=zac-10;
    if(ch='p') and ((zac+10)<spolu) then zac:=zac+10;
 
  until (koniec);
 
  VyberZiaka:=por;
end;
 
 
{ zobrazi vysledky testovania ziakov }
procedure Vysledky;
var f:text;
    por,i:integer;
    body:integer;
    o,dobre:integer;
    s,sodp:string;
begin
  { najprv vyberie ziaka zo zoznamu }
  por:=VyberZiaka;
 
  Assign(f, cesta+ToStr(por)+TST_KON);
  Reset(f);
 
  { precita meno ziaka }
  ReadLn(f,meno);
  { precita body/znamku }
  while not(eof(f)) do ReadLn(f,body);
 
  { znova na zaciatok suboru }
  Close(f);
  Reset(f);
  ReadLn(f,meno);
 
  for i:=1 to po do
  begin
    { precita odpoved na otazku }
    Read(f,o); Read(f,s);
    while(s[1]=' ') do Delete(s,1,1);
 
    sodp:=NapisOtazku(i,1,1);
    dobre:=NajdiOdpoved;
 
    if (sodp='') then begin
      o:=ToInt(s);
      Uvod(3,i,odp[o],body);
      NapisOtazku(i,dobre,o);
     end
    else
     begin
      if( SUpCase(s)=SUpCase(sodp))then o:=1
                                   else o:=2;
      Uvod(3,i,odp[o],body);
      NapisOtazku(i,1,1);
 
      farba(green,lightgray);
      px:=1; py:=py+1;
      NaObr(true,'Spravne: '+sodp);
 
      { ak bola zla odpoved }
      if(o=2)then begin
        farba(red,lightgray);
        px:=1; py:=py+1;
        NaObr(true,'Odpoved: '+s);
      end;
 
      { povodna farba }
      farba(black,lightgray);
     end;
 
    Pause;
  end;
 
  { zavrieme subor }
  Close(f);
end;
 
 
{ zisti ako sa vola test ak nezada nic tak default }
function DajMenoTestu:string;
begin
  if(ParamCount>0) then
     DajMenoTestu:=ParamStr(1)
  else
     DajMenoTestu:=TST_MENO;
end;
 
 
BEGIN
  cesta:=DajCestu;
  test:=DajMenoTestu;
  AnalyzeTest;
 
  repeat
    Uvod(0,0,0,0);
    o:=readkey;         { pocka na stlacenie 1,2,3 }
 
    if(o='1')then Testuj;
    if(o='2')then Vysledky;
 
  until(o='3');
 
  Clrscr;
END.