Localize file www.TrSek.com/cover/sargo/piskvor.pas{ PISKVOR.PAS Copyright (c) Sargo }
{ }
{ Klasicke piskvorky proti pocitacu. Logika pocitaca nie je uplne }
{ stopercenta (bolo by nutne prepisat program s inymi alogritmami }
{ overovania). Jedna sa o 4 verziu tohto programu a verte ze sa }
{ potrapite, a budete sa cudovat ako je mozne ze sa v pascali nieco }
{ take da naprogramovat... :) Najdenie toho spravneho postupu medzi }
{ obrannou a utokom zabral cas, pri zistovani parametrov som nechal }
{ pocitac hrat proti sebe a tak som vybral pre vas favorita. }
{ (je mozne vyhrat !!!) }
{ }
{ ovladanie sipkami (klasika hore dole doprava dolava) }
{ space bar - potvrdenie tahu }
{ escape - ihned ukonci program ... stav oznaci ako remiza }
{ }
{ Author: Sargo }
{ Date : 29.07.2006 http://www.trsek.com }
program piskvorky;
uses crt;
var a,b,c,s,d,e,g,
x,y,
f:longint;
p:array[-10..10,-10..10] of 0..2;
vx,vy :array[0..4] of -10..10;
pod: boolean;
mp,jp:array[-10..10,-10..10] of real;
n:real;
px,py:longint;
procedure nastav;
begin
pod:=true;
for c:=0 to 4 do if p[vx[c],vy[c]]<>1 then pod:=false;
if pod then s:=1;
pod:=true;
for c:=0 to 4 do if p[vx[c],vy[c]]<>2 then pod:=false;
if pod then s:=2
end;
procedure stav;
begin
for a:=-10 to 6 do
for b:=-10 to 6 do
begin
for f:=0 to 1 do begin
for c:=0 to 4 do begin
case f of
0:begin vx[c]:=a+c;vy[c]:=b+c end;
1:begin vx[c]:=a+c;vy[c]:=b-c+4 end;
end;
end;
nastav;
end;
end;
for a:=-10 to 6 do
for b:=-10 to 10 do begin
for c:=0 to 4 do begin
vx[c]:=a+c;
vy[c]:=b
end;
nastav;
end;
for a:=-10 to 10 do
for b:=-10 to 6 do begin
for c:=0 to 4 do begin
vx[c]:=a;
vy[c]:=b+c
end;
nastav;
end;
end;
procedure overenie;
begin
pod:=true;
for c:=0 to 4 do if p[vx[c],vy[c]]=2 then pod:=false;
if pod then begin
d:=1;
for c:=0 to 4 do if p[vx[c],vy[c]]=1 then inc(d);
for c:=0 to 4 do if p[vx[c],vy[c]]=0 then jp[vx[c],vy[c]]:=jp[vx[c],vy[c]]+3*d*d*d+3*d*d+3*d;
end;
pod:=true;
for c:=0 to 4 do if p[vx[c],vy[c]]=1 then pod:=false;
if pod then begin
d:=1;
for c:=0 to 4 do if p[vx[c],vy[c]]=2 then inc(d);
for c:=0 to 4 do if p[vx[c],vy[c]]=0 then mp[vx[c],vy[c]]:=mp[vx[c],vy[c]]+3*d*d*d+3*d*d+3*d;
end;
end;
function je_volne: boolean;
begin
je_volne:=false;
for a:=-10 to 10 do for b:=-10 to 10 do if p[a,b]=0 then je_volne:=true
end;
procedure povodne;
begin
gotoxy(x+39,y+20);
case p[x,y] of
0:write(' ');
1:begin textcolor(2);write('X')end;
2:begin textcolor(4);write('O')end;
end;
gotoxy(28,9);textcolor(15);
end;
procedure bod;
begin
gotoxy(x+39,y+20);
write('Û');
gotoxy(28,9)
end;
for a:=-11 to 11 do for b:=-11 to 11 do if 11 in [abs(a),abs(b)] then begin
gotoxy(a+39,b+20);
write('Û')
end;
x:=0;y:=0;
hra:;
stav;
if (not(je_volne)) or (s>0) then goto konec;
cyk:
case f of
0:bod;
1:povodne;
end;
for a:=1 to (f*10+50) do begin
if keypressed then case ord(readkey) of
72:if y>-10 then begin povodne;dec(y) end;
77:if x<10 then begin povodne;inc(x) end;
80:if y<10 then begin povodne;inc(y) end;
75:if x>-10 then begin povodne;dec(x) end;
32:if p[x,y]=0 then begin p[x,y]:=1;povodne;goto dalej end;
27:goto konec;
end;
delay(2);
end;
f:=abs(f-1);
goto cyk;dalej:;
sound(100);delay(10);nosound;delay(200);
stav;
if (not(je_volne)) or (s>0) then goto konec;
for a:=-10 to 6 do
for b:=-10 to 6 do
begin
for f:=0 to 1 do begin
for c:=0 to 4 do begin
case f of
0:begin vx[c]:=a+c;vy[c]:=b+c end;
1:begin vx[c]:=a+c;vy[c]:=b-c+4 end;
end;
end;
overenie;
end;
end;
for a:=-10 to 6 do
for b:=-10 to 10 do begin
for c:=0 to 4 do begin
vx[c]:=a+c;
vy[c]:=b
end;
overenie;
end;
for a:=-10 to 10 do
for b:=-10 to 6 do begin
for c:=0 to 4 do begin
vx[c]:=a;
vy[c]:=b+c
end;
overenie;
end;
n:=-1;
for a:=-10 to 10 do for b:=-10 to 10 do if (jp[a,b]>n) and (p[a,b]=0) then begin
n:=jp[a,b];
px:=a;
py:=b;
end;
for a:=-10 to 10 do for b:=-10 to 10 do if (mp[a,b]>n) and (p[a,b]=0) then begin
n:=mp[a,b];
px:=a;
py:=b;
end;
p[px,py]:=2;
gotoxy(px+39,py+20);
textcolor(4);write('O');
textcolor(15);
for a:=-10 to 10 do for b:=-10 to 10 do begin
jp[a,b]:=0;
mp[a,b]:=0;
end;
goto hra;
konec:
textcolor(9);
gotoxy(29,33);
case s of
0:write(' ***Remiza***');
2:write(' ***Prehrali ste !!!***');
1:write(' ***Vyhrali ste !!!***');
end;
readkey;
end.