Klasické piškvorky proti počítaču v pascale - neporaziteľné

{ 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;
 
label cyk,dalej,hra,konec;
 
 
begin
 
textmode(CO80 + Font8x8);
clrscr;
gotoxy(52,49);write('Navrhol a naprogramoval:Sargo');
textcolor(15);
gotoxy(36,15);
write('Piskvorky');
gotoxy(29,20);
write('Stlac lubovolnu klavesu');
readkey;
clrscr;
 
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.