Umístnení souboru www.TrSek.com/pas/kpn.pas

{ KPN.PAS                   Copyright (c) TrSek alias Zdeno Sekerak }
{ Program simuluje hru kamen-papier-noznice.                        }
{ Hraci zadavaju svoju volbu pismenami k-kamen, p-papier, n-noznice }
{ Program vyhodnocuje ich uspesnost a uklada si jednotlive hry do   }
{ suboru. Po skonceni zobrazi graf uspesnosti jednotlivych hracov.  }
{                                                                   }
{ Datum:28.01.2005                            http://www.trsek.com  }

program kpn;
uses crt,dos,graph,mycrt;

const SCORE='score.txt';
      MAX=10;

var   q:char;                           { question }
   mena:array[1..MAX] of string;        { uchova mena hracov }
   scor:array[1..MAX,1..2] of integer;  { uchova score hracov }

{ hra: kamen, papier, noznice }
procedure hra;
var meno1,meno2:string;
    v1,v2:string;
    s:char;
    i:integer;
    w:integer;
    f:text;
begin
  clrscr;
  textcolor(yellow);

  { opyta sa na mena hracov }
  write('Prosim hraca cislo 1 aby zadal svoje meno:');
  readln(meno1);
  write('Prosim hraca cislo 2 aby zadal svoje meno:');
  readln(meno2);

  { bude opakovat az pokial nepovie n }
  repeat
    textcolor(lightgray);
    writeln('Zaciname hru, prosim premyslite si svoju volbu.');

    for i:=1 to 2 do writeln;

    zvuk(200,800);
    zvuk(  0,250);
    zvuk(300,600);
    zvuk(  0,300);
    zvuk(400,800);
    zvuk(  0,200);
    nosound;

    textcolor(green);
    write(meno1 ,' zadaj svoju volbu [k-kamen, p-papier, n-noznice]:');
    v1:=readkey;
    WriteLn;

    write(meno2 ,' zadaj svoju volbu [k-kamen, p-papier, n-noznice]:');
    v2:=readkey;
    WriteLn;

    for i:=1 to 2 do writeln;

    { nespravne typy }
    textcolor(red);
    if (v1)=(v2)then
       writeln('Vase typy boli rovnake, prosim opakujte hru.');

    if(v1<>'k') and (v1<>'p') and (v1<>'n')then
       writeln(meno1, ' nestlacil si pozadovany klaves skus znova');

    if(v2<>'k')and (v2<>'p')and (v2<>'n')then
       writeln(meno2, ' nestlacil si pozadovany klaves skus znova.');

    { vyhodnotenie kto to vyhral }
    w:=0;
    textcolor(white);
    if(v1='p') and (v2='k')then w:=1;
    if(v1='n') and (v2='p')then w:=1;
    if(v1='k') and (v2='n')then w:=1;
    if(v1='k') and (v2='p')then w:=2;
    if(v1='p') and (v2='n')then w:=2;
    if(v1='n') and (v2='k')then w:=2;

    { vypiseme ze vyhral 1 a ulozime do suboru }
    if(w=1)then
    begin
      writeln('Gratulujem ',meno1 ,' vyhral si!');

      { otvori subor na zapis, zapise, zatvori }
      assign(f,SCORE);
      append(f);
      writeln(f,'1',meno1);
      writeln(f,'0',meno2);
      close(f);
    end;

    { vypiseme ze vyhral 2 a ulozime do suboru }
    if(w=2)then
    begin
      writeln('Gratulujem ',meno2 ,' vyhral si!');

      { otvori subor na zapis, zapise, zatvori }
      assign(f,SCORE);
      append(f);
      writeln(f,'1',meno2);
      writeln(f,'0',meno1);
      close(f);
    end;

    zvuk(200,250);
    zvuk(300,300);
    zvuk(400,200);
    nosound;

    textcolor(green);
    writeln('Prajete si hru opakovat? [a/n]');
    s:=readkey;
  until(s<>'a');

  textcolor(red);
  writeln('Koniec hry');
end;

{ zisti to aky v poradi v poli je hrac }
{ ak nieje urci posledne volne pole    }
function Poradie(meno:string):integer;
var i:integer;
begin
  Poradie:=0;

  for i:=MAX downto 1 do
  begin
    if(UpWord(mena[i])=UpWord(meno))then Poradie:=i;
    if(mena[i]='')then Poradie:=i;
  end;
end;

{ otvori subor score a spocita score }
procedure CalcScore;
var f:text;
    i:integer;
meno:string;
  bod:integer;
begin
  assign(f,SCORE);
  reset(f);

  { precita vsetky mena }
  repeat
    Readln(f,meno);

    bod:=ord(meno[1])-ord('0');
    meno:=copy(meno,2,length(meno));

    { zisti poradie }
    i:=Poradie(meno);

    { ak je medzi prvymi 10 }
    if(i<>0)then begin
      mena[i]:=meno;

      { ak vyhral tak pripocitame }
      if(bod=1)then scor[i,1]:=scor[i,1]+1;
      if(bod=0)then scor[i,2]:=scor[i,2]+1;
    end;

  until(eof(f));

  close(f);
end;

{ zisti maximalnu hodnotu }
function CalcMax:integer;
var m,i:integer;
begin
  m:=scor[1,1];         { pociatocna hodnota }

  for i:=1 to MAX do
  begin
    { ak je hodnota vacsia ako doterajsie maximum }
    if(scor[i,1]>m)then m:=scor[i,1];
    if(scor[i,2]>m)then m:=scor[i,2];
  end;

  CalcMax:=m;
end;

{ zmaze pole score }
procedure ClrScore;
var i:integer;
begin
  for i:=1 to MAX do
  begin
    scor[i,1]:=0;
    scor[i,2]:=0;
    mena[i]:='';
  end;
end;

{ vykresli graf funkcie }
procedure graf;
var i:integer;
    m:integer;
    y:integer;
begin
  ClrScore;     { zmaze pole score }
  CalcScore;    { vypocita ake maju score }
  m:=CalcMax;   { zisti maximalnu hodnotu }

  OpenGraph;

  { nakreslime osi }
  line(40,20,40,450);
  line(30,440,620,440);

  { pocet na osi y }
  for i:=1 to 10 do begin
    line(35,440-i*40,45,440-i*40);
    outtextxy(5,437-i*40,ToStr(i*10)+'%');
  end;

  { mena na osi x }
  for i:=1 to MAX do
    outtextxy(i*55,450,mena[i]);

  { nastavime pre vyhral vzor vyplnovania }
  SetFillStyle(XHatchFill, Green);
  { popis }
  bar3d(550,20,570,30,0,TopOff);
  outtextxy(575,20,'vyhral');

  { vykreslime jednotlive hodnoty vyhral }
  for i:=1 to MAX do begin
    y:=round((400*scor[i,1])/m);
    { stlpec a cislo nad nim }
    bar3d(i*55,440-y,i*55+20,440,0,TopOff);
    outtextxy(i*55+4,430-y,ToStr(scor[i,1]));
  end;

  { nastavime pre prehral vzor vyplnovania }
  SetFillStyle(XHatchFill, Red);
  { popis }
  bar3d(550,40,570,50,0,TopOff);
  outtextxy(575,40,'prehral');

  { vykreslime jednotlive hodnoty prehral }
  for i:=1 to MAX do begin
    y:=round((400*scor[i,2])/m);
    { stlpec a cislo nad nim }
    bar3d(i*55+20,440-y,i*55+40,440,0,TopOff);
    outtextxy(i*55+24,430-y,ToStr(scor[i,2]));
  end;

  readln;
  CloseGraph;
end;

{ hlavne menu programu }
BEGIN
  TestFile(SCORE);    { otestuje subor }

  repeat
    clrscr;
    textcolor(green);
    writexy(26, 7,'Ponuka cinnosti:');

    textcolor(red);
    writexy(26, 8,'1. Hrat kamen,papier,noznice');
    writexy(26, 9,'2. Prezriet graf');
    writexy(26,10,'3. Koniec');

    q:=readkey;           { precita stlaceni eklavesu }
    if(q='1') then hra;   { spusti hru }
    if(q='2') then graf;  { ukaze graf }

  until(q='3');    {  if(q=3) then koniec;}
END.

Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com