Klasické miny ako ich poznáme z windowsu s ukladaním štatistiky do súboru.

{ MINY.PAS                             Copyright (c)                }
{ Tak chcel by som v prvom rade napisat, ze toto je moj treti       }
{ pouzitelny program v pascale a preto prosim ospravedln nejake     }
{ zbytocne riadky alebo neefektivne algoritmy. Dalej si myslim, ze  }
{ popis velmi netreba, cele som to uz pri pisani rozdeloval do      }
{ podprogramov pre vacsiu prehladnost a aj ich nazvy myslim hovoria }
{ za vsetko. A este si nevsimaj (pripadne prepis) nazvy premennych  }
{ ako kill a win. neplanoval som to zverejnovat :)                  }
{                                                                   }
{ Author:                                                           }
{ Datum: 02.06.2009                           http://www.trsek.com  }
 
program miny;
uses crt,sysutils;
var a,b,polehraca:array[2..79,2..20]of integer;
    xos,yos,minky,x,y,kill,win,lvyh,lrem,lpreh,svyh,srem,spreh,tvyh,trem,tpreh:integer;
    c:char;
    f:file of integer;
    prvytah:boolean;
 
procedure instrukcie;
var i:integer;
    j:string;
begin
clrscr;
j:='MINY';
for i:=1 to 4 do begin
 if i mod 2=1 then begin
  textcolor(lightred);
  write(copy(j,i,1));
 end;
 if i mod 2=0 then begin
  textcolor(lightgreen);
  write(copy(j,i,1));
 end;
end;
textcolor(white);
writeln;
writeln;
textcolor(yellow);
writeln('Ovladanie:');
textcolor(white);
writeln('sipky -pohyb kurzora');
writeln('enter -slapnutie na dane policko');
writeln('del   -oznacenie miny');
writeln('Q     -ukoncenie aktualnej hry (prehra)');
writeln;
textcolor(cyan);
write('(potvrd enterom)');
textcolor(white);
repeat until readkey=chr(13);
end;
 
procedure prvytahvynulovanie;
var i,j:integer;
begin
for i:=2 to 79 do
 for j:=2 to 20 do begin
  a[i,j]:=0;
  b[i,j]:=0;
  polehraca[i,j]:=0;
 end;
end;
 
procedure vynulovanie;
var i,j:integer;
begin
clrscr;
for i:=2 to 79 do
 for j:=2 to 20 do begin
  a[i,j]:=0;
  b[i,j]:=0;
  polehraca[i,j]:=0;
 end;
x:=2;
y:=2;
kill:=0;
win:=0;
prvytah:=true;
textcolor(white);
end;
 
procedure vykrespole(xos,yos,minky:integer);
var i,j,r,s:integer;
begin
clrscr;
j:=0;
gotoxy(1,1); write(chr(201));
for i:=1 to xos do write(chr(205));
write(chr(187));
for i:=2 to yos+1 do begin
 gotoxy(1,i);
 write(chr(186));
 textbackground(7);
 for j:=1 to xos do write(' ');
 textbackground(black);
 write(chr(186));
end;
gotoxy(1,yos+2); write(chr(200));
for i:=1 to xos do write(chr(205));
write(chr(188));
j:=0;
repeat
 r:=random(xos)+2;
 s:=random(yos)+2;
 if a[r,s]=0 then begin
  a[r,s]:=1;
  inc(j);
  end;
until j=minky;
end;
 
procedure check(cx,cy:integer);
var i:integer;
begin
i:=0;
if polehraca[cx,cy]=0 then begin
 if a[cx,cy]=0 then begin
  if (cy<=yos)and(a[cx,cy+1]=1) then inc(i);
  if (cx>=3)and(cy<=yos)and(a[cx-1,cy+1]=1) then inc(i);
  if (cx>=3)and(a[cx-1,cy]=1) then inc(i);
  if (cx>=3)and(cy>=3)and(a[cx-1,cy-1]=1) then inc(i);
  if (cy>=3)and(a[cx,cy-1]=1) then inc(i);
  if (cx<=xos)and(cy>=3)and(a[cx+1,cy-1]=1) then inc(i);
  if (cx<=xos)and(a[cx+1,cy]=1) then inc(i);
  if (cx<=xos)and(cy<=yos)and(a[cx+1,cy+1]=1) then inc(i);
  case i of
  0:begin
     gotoxy(cx,cy);
     write(' ');
     polehraca[cx,cy]:=1;
     if cy<=yos then check(cx,cy+1);
     if (cx>=3)and(cy<=yos) then check(cx-1,cy+1);
     if cx>=3 then check(cx-1,cy);
     if (cx>=3)and(cy>=3) then check(cx-1,cy-1);
     if cy>=3 then check(cx,cy-1);
     if (cx<=xos)and(cy>=3) then check(cx+1,cy-1);
     if cx<=xos then check(cx+1,cy);
     if (cx<=xos)and(cy<=yos) then check(cx+1,cy+1);
    end;
  1:begin
     textcolor(lightblue);
     gotoxy(cx,cy);
     write('1');
     polehraca[cx,cy]:=1;
    end;
  2:begin
     textcolor(lightgreen);
     gotoxy(cx,cy);
     write('2');
     polehraca[cx,cy]:=1;
    end;
  3:begin
     textcolor(yellow);
     gotoxy(cx,cy);
     write('3');
     polehraca[cx,cy]:=1;
    end;
  4:begin
     textcolor(lightred);
     gotoxy(cx,cy);
     write('4');
     polehraca[cx,cy]:=1;
    end;
  5:begin
     textcolor(brown);
     gotoxy(cx,cy);
     write('5');
     polehraca[cx,cy]:=1;
    end;
  6:begin
     textcolor(magenta);
     gotoxy(cx,cy);
     write('6');
     polehraca[cx,cy]:=1;
    end;
  7:begin
     textcolor(red);
     gotoxy(cx,cy);
     write('7');
     polehraca[cx,cy]:=1;
    end;
  8:begin
     textcolor(blue);
     gotoxy(cx,cy);
     write('8');
     polehraca[cx,cy]:=1;
    end;
  end;
 end;
 if a[cx,cy]=1 then kill:=1;
end;
end;
 
procedure tahhraca;
var i:integer;
begin
i:=0;
gotoxy(x,y);
repeat
 repeat until keypressed;
 c:=readkey;
 if (ord(c)=72)and(y>2) then y:=y-1;
 if (ord(c)=80)and(y<=yos) then y:=y+1;
 if (ord(c)=75)and(x>2) then x:=x-1;
 if (ord(c)=77)and(x<=xos) then x:=x+1;
 if (ord(c)=83)and(polehraca[x,y]=0) then begin
  if b[x,y]=0 then begin
   gotoxy(x,y);
   textcolor(lightred);
   write(chr(219));
  end;
  if b[x,y]=1 then begin
   gotoxy(x,y);
   textbackground(7);
   write(' ');
   textbackground(black);
  end;
  if b[x,y]=0 then b[x,y]:=1
  else b[x,y]:=0;
 end;
 if (ord(c)=13)and(polehraca[x,y]=0)and(b[x,y]=0) then begin
  while (prvytah)and(a[x,y]=1) do begin
   prvytahvynulovanie;
   vykrespole(xos,yos,minky);
   if a[x,y]=0 then prvytah:=false;
  end;
  if prvytah then prvytah:=false;
  check(x,y);
  i:=1;
 end;
 if c='q' then i:=1;
 gotoxy(x,y);
until i=1;
end;
 
procedure kontvyt;
var i,j,k:integer;
begin
i:=0;
for k:=2 to yos+1 do
 for j:=2 to xos+1 do
  if not((a[j,k]=0)and(polehraca[j,k]=1)) then inc(i);
if i=minky then win:=1;
end;
 
procedure vyhodnotenie;
var i,j:integer;
begin
if win=1 then begin
 for i:=2 to 79 do
  for j:=2 to 20 do
   if a[i,j]=1 then begin
    gotoxy(i,j);
    textcolor(white);
    write('X');
   end;
 gotoxy(1,yos+4);
 textcolor(yellow);
 write('Vyhral si');
 textcolor(white);
 case random(4) of
  0:write(', uspesne si vycistil cele minove pole!');
  1:write(' dobry pocit!');
  2:write(', vdaka tebe sa uz nemusia afganske deti nicoho obavat!');
  3:write(', dokazal si objavit aj tu poslednu minu!');
 end;
 reset(f);
 read(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
 if (minky=10)and(xos=9)and(yos=9) then inc(lvyh);
 if (minky=40)and(xos=16)and(yos=16) then inc(svyh);
 if (minky=100)and(xos=30)and(yos=16) then inc(tvyh);
 rewrite(f);
 write(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
end;
if kill=1 then begin
 for i:=2 to 79 do
  for j:=2 to 20 do
   if a[i,j]=1 then begin
    gotoxy(i,j);
    textcolor(white);
    write('X');
   end;
 gotoxy(x,y);
 textbackground(lightred);
 write('X');
 textbackground(black);
 gotoxy(1,yos+4);
 textcolor(yellow);
 write('Prehral si');
 textcolor(white);
 case random(4) of
  0:write(', uz asi svoje lietajuce casti tela nepozbieras...');
  1:write(', tentoraz si sa trafil zle.');
  2:write(', je to az take tazke?');
  3:write(', posledne, na co si pamatas, je tiche cvaknutie.');
 end;
 reset(f);
 read(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
 if (minky=10)and(xos=9)and(yos=9) then inc(lpreh);
 if (minky=40)and(xos=16)and(yos=16) then inc(spreh);
 if (minky=100)and(xos=30)and(yos=16) then inc(tpreh);
 rewrite(f);
 write(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
end;
if c='q' then begin
 gotoxy(1,yos+4);
 textcolor(yellow);
 write('Prehral si');
 textcolor(white);
 case random(4) of
  0:write(', len tak odchadzas? Nejake miny este ostali neodhalene...');
  1:write(', naozaj si sklamal afganske deti.');
  2:write(', je tych min na teba prilis?');
  3:write(', zbytocne dalsia prehra.');
 end;
 reset(f);
 read(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
 if (minky=10)and(xos=9)and(yos=9) then inc(lpreh);
 if (minky=40)and(xos=16)and(yos=16) then inc(spreh);
 if (minky=100)and(xos=30)and(yos=16) then inc(tpreh);
 rewrite(f);
 write(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
end;
gotoxy(1,yos+5);
writeln('Pre zacatie novej hry stlac N, pre pole z predoslej hry P, pre zobrazenie');
write('statistiky S a pre ukoncenie Q.');
end;
 
procedure koniec;
begin
clrscr;
textcolor(cyan);
case random(5) of
 0:write('GOODBYE!');
 1:write('SEE YA!');
 2:write('SEE YOU LATER!');
 3:write('BYE BYE!');
 4:write('GOOD GAME!');
end;
delay(2000);
end;
 
procedure statistika;
begin
clrscr;
writeln('LAHKA');
writeln('Vyhry = ');
writeln('Prehry = ');
writeln('Hranych hier = ');
writeln;
writeln('STREDNA');
writeln('Vyhry = ');
writeln('Prehry = ');
writeln('Hranych hier = ');
writeln;
writeln('TAZKA');
writeln('Vyhry = ');
writeln('Prehry = ');
writeln('Hranych hier = ');
writeln;
writeln('Celkovo hranych hier = ');
writeln;
writeln('Pre vymazanie statistik stlac V, pre zacatie novej hry N, pre pole z predoslej');
write('hry P, pre ukoncenie Q.');
reset(f);
read(f,lvyh,lpreh,svyh,spreh,tvyh,tpreh);
textcolor(yellow);
gotoxy(9,2);
write(lvyh);
gotoxy(10,3);
write(lpreh);
gotoxy(9,7);
write(svyh);
gotoxy(10,8);
write(spreh);
gotoxy(9,12);
write(tvyh);
gotoxy(10,13);
write(tpreh);
textcolor(lightred);
gotoxy(16,4);
write(lvyh+lpreh);
gotoxy(16,9);
write(svyh+spreh);
gotoxy(16,14);
write(tvyh+tpreh);
gotoxy(24,16);
write(lvyh+lpreh+svyh+spreh+tvyh+tpreh);
textcolor(white);
gotoxy(24,19);
end;
 
 
begin
randomize;
assign(f,'minstats.dat');
if not(fileexists('minstats.dat')) then begin
 rewrite(f);
 write(f,0,0,0,0,0,0);
end;
xos:=9;
yos:=9;
minky:=10;
instrukcie;
repeat
 vynulovanie;
 if c<>'p' then begin
  writeln('Vyber si obtiaznost lahku, strednu, tazku alebo vlastne pole. (L/S/T/V)');
  repeat
   repeat until keypressed;
   c:=readkey;
   if c='l' then begin xos:=9; yos:=9; minky:=10; end;
   if c='s' then begin xos:=16; yos:=16; minky:=40; end;
   if c='t' then begin xos:=30; yos:=16; minky:=100; end;
   if c='v' then begin
    repeat
     clrscr;
     writeln('Zadaj sirku (max 78), vysku (max 19) a pocet min (max sirka*vyska) na poli:');
     read(xos,yos,minky);
    until (xos<79)and(xos>0)and(yos<20)and(yos>0)and(minky>0)and(minky<xos*yos);
   end;
  until (c='l')or(c='s')or(c='t')or(c='v');
  c:='0';
 end;
 vykrespole(xos,yos,minky);
 repeat
  tahhraca;
  kontvyt;
 until (kill=1)or(win=1)or(c='q');
 vyhodnotenie;
 repeat
  repeat until keypressed;
  c:=readkey;
 until (c='n')or(c='q')or(c='s')or(c='p');
 if c='s' then begin
  repeat
   statistika;
   repeat
    repeat until keypressed;
    c:=readkey;
   until (c='n')or(c='q')or(c='v')or(c='p');
   if c='v' then begin
    rewrite(f);
    write(f,0,0,0,0,0,0);
   end;
  until (c='n')or(c='q')or(c='p');
 end;
until c='q';
koniec;
end.