Obdoba tetrisu ale musíte skladať 4 rovnaké farby

{ T1.PAS                                        Copyright (c) Sargo }
{                                                                   }
{ Jedna sa o hru, v ktorej musite skladat objekty do skupiny        }
{ minimalne troch stvorcekov vodorovne, zvislo alebo sikmo oba      }
{ smermi. Hra pocita skore a konci pri zaplneni hracej plochy tak   }
{ ze neni mozne pridat dalsi objekt.                                }
{                                                                   }
{ Hra sa ovlada 4-sipkami                                           }
{                                                                   }
{           Zmena poradia stvorcekov v objetke                      }
{           I                                                       }
{ do lava <- -> do prava                                            }
{           I                                                       }
{           Rychle posunutie objektu smerom dolu                    }
{                                                                   }
{ Author: Sargo                                                     }
{ Date  : 29.07.2006                           http://www.trsek.com }
 
program tetris;
uses crt;
var x,y,a,b,c,s :longint;
    p   :array[1..8,1..15] of longint;
    k   :array[1..3] of longint;
    d,e :boolean;
 
 
procedure vym;
begin
for a:=1 to 3 do begin
                 gotoxy(x+33,y+a+11);
                 write(' ')
                 end
end;
 
procedure vyj;
begin
for a:=1 to 3 do begin
                 gotoxy(x+33,y+a+11);
                 textcolor(k[a]);
                 write('Ű')
                 end
end;
 
procedure nova;
begin
for a:=1 to 3 do begin
                 k[a]:=random(4)+1;
                 if k[a]=3 then k[a]:=14
                 end;
x:=4;y:=1;
d:=true;
vyj;
if (p[x,y+1]<>0) or (p[x,y+1]<>0) or (p[x,y+1]<>0) then halt
end;
 
procedure vymazanie;
var z,y :longint;
begin
for z:=1 to 8  do
 for y:=1 to 13 do
   if (abs(p[z,y])=abs(p[z,y+1])) and (abs(p[z,y])=abs(p[z,y+2])) then
     begin
     if p[z,y  ]>0 then p[z,y  ]:=-p[z,y  ] ;
     if p[z,y+1]>0 then p[z,y+1]:=-p[z,y+1] ;
     if p[z,y+2]>0 then p[z,y+2]:=-p[z,y+2]
     end;
for z:=1 to 6  do
 for y:=1 to 15 do
   if (abs(p[z,y])=abs(p[z+1,y])) and (abs(p[z,y])=abs(p[z+2,y])) then
     begin
     if p[z  ,y]>0 then p[z  ,y]:=-p[z  ,y] ;
     if p[z+1,y]>0 then p[z+1,y]:=-p[z+1,y] ;
     if p[z+2,y]>0 then p[z+2,y]:=-p[z+2,y]
     end;
for z:=1 to 6  do
 for y:=1 to 13 do
   if (abs(p[z,y])=abs(p[z+1,y+1])) and (abs(p[z,y])=abs(p[z+2,y+2])) then
     begin
     if p[z  ,y  ]>0 then p[z  ,y  ]:=-p[z  ,y  ] ;
     if p[z+1,y+1]>0 then p[z+1,y+1]:=-p[z+1,y+1] ;
     if p[z+2,y+2]>0 then p[z+2,y+2]:=-p[z+2,y+2]
     end;
for z:=1 to 6  do
 for y:=1 to 13 do
   if (abs(p[z,y+2])=abs(p[z+1,y+1])) and (abs(p[z,y+2])=abs(p[z+2,y])) then
     begin
     if p[z  ,y+2]>0 then p[z  ,y+2]:=-p[z  ,y+2] ;
     if p[z+1,y+1]>0 then p[z+1,y+1]:=-p[z+1,y+1] ;
     if p[z+2,y  ]>0 then p[z+2,y  ]:=-p[z+2,y  ]
     end;
 
e:=false;
for z:=1 to 8  do
 for y:=1 to 15 do
   if p[z,y]<0 then
    begin
    gotoxy(z+33,y+11);
    write(' ')
    end;
delay(200);
for z:=1 to 8  do
 for y:=1 to 15 do
   if p[z,y]<0 then
    begin
    textcolor(abs(p[z,y]));
    gotoxy(z+33,y+11);
    write('Ű')
    end;
delay(200);
for z:=1 to 8  do
 for y:=1 to 15 do
   if p[z,y]<0 then
    begin
    gotoxy(z+33,y+11);
    write(' ');
    p[z,y]:=0;
    e:=true;
    textcolor(7);
    inc(s);
    gotoxy(10,12);write('Skore: ',s,0)
    end;
 
repeat
d:=false;
for z:=1 to 8  do
 for y:=15 downto 2 do
  if (p[z,y]=0) and (p[z,y-1]<>0) then
    begin
    d:=true;
    p[z,y]:=p[z,y-1];
    p[z,y-1]:=0;
    end;
 
for z:=1 to 8  do
 for y:=1 to 15 do
   begin
    gotoxy(z+33,y+11);
    textcolor(p[z,y]);
    write('Ű')
   end;
until not(d);
 
if e then vymazanie
 
end;
 
 
begin
textmode(CO80 + Font8x8);
randomize;
clrscr;
textcolor(7);
gotoxy(10,12);write('Skore: ',s);
for a := 1 to  9 do begin gotoxy(a+33,27);write(chr(219));end;
for a := 1 to 15 do begin gotoxy(33,12+a);write(chr(219));gotoxy(42,12+a);write(chr(219));end;
nova;
repeat
 
  for c:=1 to 200 do
     begin
     if d then delay(1);
     if keypressed then case ord(readkey) of
                        75:if (x>1) and (p[x-1,y+1]=0) and (p[x-1,y+2]=0) and (p[x-1,y+3]=0) then begin vym;dec(x);vyj end;
                        77:if (x<8) and (p[x+1,y+1]=0) and (p[x+1,y+2]=0) and (p[x+1,y+3]=0) then begin vym;inc(x);vyj end;
                        80:d:=false;
                        72:begin a:=k[1];k[1]:=k[2];k[2]:=k[3];k[3]:=a;vyj end;
                        end
     end;
 
  if (y<12) and (p[x,y+4]=0) then
     begin
     vym;
     inc(y);
     vyj
     end
 
     else
 
     begin
     for a:=1 to 3 do p[x,y+a]:=k[a];
     vymazanie;
     nova
     end;
 
until (false);
END.