Testovanie pravdepodobnosti a rýchlosti hry v kocky

{ kostky.pas                            Copyright (c) Petr Masopust  }
{ Testovani pravdepodobnosti (pro me) a rychlosti (pro hrace).       }
{                                                                    }
{ Datum:07.09.2018                              http://www.trsek.com }
 
uses dos,crt,graph;
const veltecky=5;
      sl=11000;
      zaccas=100;
      ra=101000;
      zpomaleni=100;
type database=record
                spusteni,radku,uhadnutoradku,sloupcu,uhadnutosloupcu:word;
                pokusu,vyhra,her:longint;
              end;
var f:file of database;
    d:database;
    unlimited:boolean;
    c:char;
    zmenascore:boolean;
    cas:word;
    aktscore:longint;
    a:array[0..7,0..3] of byte;
    gd,gm:integer;
    Dir: DirStr;
    N: NameStr;
    E: ExtStr;
 
 
procedure egavgaovladac;external;
{$L egavga.obj}
 
procedure triplexfontovladac;external;
{$L trip.obj}
 
function inttostr(i:longint):string;
var
  S: string[11];
begin
  Str(I, S);
  IntToStr := S;
end;
 
procedure clearta;assembler;
asm
  mov ah,0ch
  mov al,6
  mov dl,0ffh
  int 21h
end;
 
procedure onekostka(x,y,tecky:byte;b:boolean);
begin
  if b then begin
    setcolor(yellow);
    setfillstyle(solidfill,yellow);
  end else begin
    setcolor(white);
    setfillstyle(solidfill,white);
  end;
  {50 x 50,mezera 20}
  bar3d(50+x*70,120+y*70,100+x*70,170+y*70,10,topon);
  if b then begin
    setcolor(blue);
    setfillstyle(solidfill,blue);
  end else begin
    setcolor(black);
    setfillstyle(solidfill,black);
  end;
  case tecky of
  1: FillEllipse(75+x*70,145+y*70,veltecky,veltecky);
  2: begin
       FillEllipse(65+x*70,135+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,155+y*70,veltecky,veltecky);
     end;
  3: begin
       FillEllipse(65+x*70,135+y*70,veltecky,veltecky);
       FillEllipse(75+x*70,145+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,155+y*70,veltecky,veltecky);
     end;
  4: begin
       FillEllipse(65+x*70,135+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(65+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,135+y*70,veltecky,veltecky);
     end;
  5: begin
       FillEllipse(65+x*70,135+y*70,veltecky,veltecky);
       FillEllipse(75+x*70,145+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(65+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,135+y*70,veltecky,veltecky);
     end;
  6: begin
       FillEllipse(65+x*70,135+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(65+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(85+x*70,135+y*70,veltecky,veltecky);
       FillEllipse(75+x*70,155+y*70,veltecky,veltecky);
       FillEllipse(75+x*70,135+y*70,veltecky,veltecky);
     end;
  end;
end;
 
procedure vyhra;
var x,y:byte;
begin
  {Sloupce}
  for x:=0 to 7 do if (a[x,0] = a[x,1]) and(a[x,1] = a[x,2]) and(a[x,2] = a[x,3]) then begin
    begin
      for y:=0 to 3 do onekostka(x,y,a[x,y],true);
      inc(d.uhadnutosloupcu);
      inc(d.vyhra,sl);
      inc(aktscore,sl);
      zmenascore:=true;
      clearta;
      repeat until keypressed;
    end;
  end;
  {Radky}
  for y:=0 to 3 do if (a[0,y] = a[1,y]) and (a[1,y] = a[2,y]) and(a[2,y] = a[3,y]) and(a[3,y] = a[4,y]) and(a[4,y] = a[5,y])
    and(a[5,y] = a[6,y]) and(a[6,y] = a[7,y]) then begin
    begin
      for x:=0 to 7 do onekostka(x,y,a[x,y],true);
      inc(d.uhadnutoradku);
      inc(d.vyhra,ra);
      inc(aktscore,ra);
      zmenascore:=true;
      clearta;
      repeat until keypressed;
    end;
  end;
end;
 
 
procedure prekresli;
var x,y,t:byte;
 
begin
  for x:=0 to 7 do for y:= 0 to 3 do begin
    t:=random(6)+1;
    a[x,y]:=t;
   { vyhra(false);}
    onekostka(x,y,t,false);
  end;
  for x:=0 to 7 do if (a[x,0] = a[x,1]) and(a[x,1] = a[x,2]) and(a[x,2] = a[x,3]) then inc(d.sloupcu);
  for y:=0 to 3 do if (a[0,y] = a[1,y]) and (a[1,y] = a[2,y]) and(a[2,y] = a[3,y]) and(a[3,y] = a[4,y]) and(a[4,y] = a[5,y])
    and(a[5,y] = a[6,y]) and(a[6,y] = a[7,y]) then inc(d.radku);
  if zmenascore then begin
    zmenascore:=false;
    settextstyle(triplexfont,horizdir,3);
    setcolor(black);
    setfillstyle(solidfill,black);
    bar(textWidth('Score: '),20,textWidth('Score: '+inttostr(aktscore))+120,textheight('Score: '+inttostr(aktscore))+20);
    setcolor(white);
    outtextxy(20,20,'Score: '+inttostr(aktscore));
  end;
  if cas / 10 = cas div 10 then begin
    settextstyle(triplexfont,horizdir,3);
    setcolor(black);
    setfillstyle(solidfill,black);
    bar(textWidth('Cas: ')+490,20,textWidth('Cas: '+inttostr(aktscore))+540,textheight('Cas: '+inttostr(cas div 10))+20);
    setcolor(white);
    outtextxy(500,20,'Cas: '+inttostr(cas div 10));
  end;
end;
 
procedure konec(s:string);
begin
  clrscr;
  writeln(s);
  halt;
end;
 
procedure center(kolik:byte;s:string);
begin
  gotoxy((lo(windmax)-length(s)) div 2,kolik);
  write(s);
end;
 
begin
  unlimited:=false;
  clrscr;
  center(2,'Testovani pravdepodobnosti (pro me) a rychlosti (pro hrace)');
  center(4,'Naprogramoval Empty Head');
  center(7,'Snazte se stisknout mezernik,');
  center(8,'prave kdyz bude v celem sloupci nebo radku stejna hodnota.');
  center(10,'Mate na 1 hru priblizne 20 sekund (podle rychlosti pocitace),');
  center(11,'klavesou Q se hra predcasne ukonci.');
  center(13,'Mnoho stesti !');
  clearta;
  repeat until keypressed;
  readkey;
  FSplit(paramstr(0),dir,n,e);
  assign(f,dir+'kostky.dat');
  if paramcount =1 then begin
  n:=paramstr(1);
  case n[1] of
  'n': begin
          with d do begin
           radku:=0;sloupcu:=0;spusteni:=0;uhadnutoradku:=0;uhadnutosloupcu:=0;pokusu:=0;
           vyhra:=0;her:=0;
          end;
          {$I-}
          rewrite(F);
          if ioresult <> 0 then konec('Nemohu vytvorit databasovy soubor !');
          write(f,d);
          if ioresult <> 0 then konec('Nemohu vytvorit databasovy soubor !');
          close(f);
          if ioresult <> 0 then konec('Nemohu uzavrit databasovy soubor !');
          {$I+}
        end;
  'd': begin
         {$I-}
         reset(f);
         if ioresult <> 0 then konec('Nemohu otevrit databasovy soubor !');
         read(f,d);
         if ioresult <> 0 then konec('Nemohu cist z databasoveho souboru !');
         close(f);
         if ioresult <> 0 then konec('Nemohu uzavrit databasovy soubor !');
         {$I+}
         clrscr;
         with d do begin
         writeln('Radku celkem: ',radku);
         writeln('Radku uhadnuto: ',uhadnutoradku);
         writeln('Sloupcu celkem: ',sloupcu);
         writeln('Sloupcu uhadnuto: ',uhadnutosloupcu);
         writeln('Celkem pokusu: ',pokusu);
         writeln('Celkova vyhra: ',vyhra);
         writeln('Her celkem: ',her);
         writeln('Spusteno: ',spusteni,' x');
         writeln('Vyhra-pokusy: ',(vyhra-(pokusu*1000)));
         end;
         clearta;
         repeat until keypressed;
       end;
  'u': unlimited:=true;
  end;
  end;
  zmenascore:=true;
  cas:=zaccas;
  aktscore:=0;
  a[0,0]:=1;
  a[1,1]:=1;
  a[2,2]:=1;
  a[3,3]:=1;
  a[4,0]:=1;
  a[5,1]:=1;
  a[6,2]:=1;
  a[7,3]:=1;
  randomize;
  {$I-}
  reset(f);
  if ioresult <> 0 then konec('Nemohu otevrit databasovy soubor !');
  read(f,d);
  if ioresult <> 0 then konec('Nemohu cist z databasoveho souboru !');
  close(f);
  if ioresult <> 0 then konec('Nemohu uzavrit databasovy soubor !');
  {$I+}
  if registerbgidriver(@egavgaovladac) <0 then konec('Nemohu nainstalovat graf. driver !');
  if RegisterBGIfont(@triplexfontovladac) < 0 then konec('Chyba pri inicializaci fontu !');
  randomize;
  gd:=9;
  gm:=2;
  initgraph(gd,gm,'');
  if graphresult <> grok then konec('Nemohu nastavit graficky rezim !');
  inc(d.spusteni);
  repeat
  repeat
  repeat
    clearta;
    prekresli;
    inc(d.her);
    dec(cas);
    delay(zpomaleni);
  until keypressed or (cas < 0) or (cas > zaccas);
  if keypressed then c:=upcase(readkey)
  else c:=#0;
  if c=' ' then begin
    vyhra;
    inc(d.pokusu);
    dec(aktscore,1000);
    zmenascore:=true;
    c:=#0;
  end;
  until (c='Q') or (cas < 0) or (cas > zaccas);
  cas:=zaccas;
  until not unlimited or (c='Q');
  closegraph;
  {$I-}
  rewrite(f);
  if ioresult <> 0 then konec('Nemohu otevrit databasovy soubor !');
  write(f,d);
  if ioresult <> 0 then konec('Nemohu zapsat do databasoveho souboru !');
  close(f);
  if ioresult <> 0 then konec('Nemohu uzavrit databasovy soubor !');
  {$I+}
  clearta;
end.