((0,1,0,0), { dlhe I }
(0,1,0,0),
(0,1,0,0),
(0,1,0,0)),
((0,1,0,0), { opacne T }
(0,1,1,0),
(0,1,0,0),
(0,0,0,0)),
((0,0,0,0), { Z vpravo }
(0,1,1,0),
(1,1,0,0),
(0,0,0,0)),
((0,0,0,0), { Z vlavo }
(1,1,0,0),
(0,1,1,0),
(0,0,0,0)),
((0,0,1,0), { L vpravo }
(0,0,1,0),
(0,1,1,0),
(0,0,0,0)),
((0,1,0,0), { L vlavo }
(0,1,0,0),
(0,1,1,0),
(0,0,0,0)));
type t_option = (Put, Clr, Sav);
{ moznosti Put - nakreslit kocku }
{ Clr - zmaze kocku }
{ Save - ulozit kocku do pola }
{ pre ukladania rebricka }
t_top = record
meno:string[10];
body:integer;
end;
var pole:array[1..WIDTH,1..HEIGHT] of byte;
body:integer; { pocet bodov }
tlev:integer; { pocitanie do dalsieho lavelu }
level:byte; { v akom levely sa nachadza }
typ:byte; { typ kocky, dalsi typ kocky }
otoc:byte; { otocenie kocky }
col:byte; { farba kocky }
x,y:integer;
ch:char;
{ zlucenie GotoXY a Write }
procedure WriteXY(x,y:integer;s:string);
begin
GotoXY(LEFT+2*x,y);
Write(s);
end;
{ nastavi prazdne pole }
procedure ClrPole;
var x,y:integer;
begin
for x:=1 to WIDTH do
for y:=1 to HEIGHT do
Pole[x,y]:=0;
end;
{ urci predchadzajuci prvok }
function TPred(otoc:byte):byte;
begin
TPred:=otoc-1;
if(otoc=1)then TPred:=4;
end;
{ urci nasledujuci prvok }
function TSucc(otoc:byte):byte;
begin
TSucc:=otoc+1;
if(otoc=4)then TSucc:=1;
end;
{ urci mensi prvok }
function Min(a,b:integer):integer;
begin
if(a<b)then
Min:=a
else
Min:=b;
end;
{ zapne/vypne zobrazenie kurzora }
procedure KurzorZap(ZapVyp:boolean);
var Regs : Registers;
begin
with Regs do
begin
AH := $03;
BH := $00;
Intr($10,Regs);
If not (Zapvyp) then
CH := CH or $20
else
CH := CH and $DF;
AH := $01;
Intr($10,Regs);
end;
end;
{ precita zo suboru podklad }
procedure Podklad;
var f:text;
s:string;
x,y:integer;
begin
{$I-}
assign(f, F_PODKLAD);
reset(f);
TextColor(LightGray);
while( not(eof(f))) do
begin
ReadLn(f,s);
Write(s);
if(not(eof(f)))then WriteLn;
end;
close(f);
{$I+}
{ vynulujem pripadne chyby }
x:=IOResult;
{ vykresli vodiace ciary }
for y:=1 to HEIGHT do
for x:=1 to WIDTH do
begin
TextColor(FOOT[x mod 2]);
WriteXY(x,y,S_FOOT);
end;
end;
{ vykresli, zmaz, uloz kocku, alebo urci ci je mozne kocku polozit }
procedure Kocka(xp,yp,typ,otoc,col:integer;option:t_option);
var x,y: integer;
bod: byte;
begin
{ v cykle vygenerujeme jednotlive prvky kocky }
for y:=1 to 4 do
for x:=1 to 4 do
begin
case otoc of
1: bod := CUBE[typ,x,y];
2: bod := CUBE[typ,5-y,x];
3: bod := CUBE[typ,5-x,5-y];
4: bod := CUBE[typ,y,5-x];
end;
case option of
clr: { zmaze kocku }
if( bod=1 )then
begin
TextColor( FOOT[(x+xp) mod 2]);
WriteXY(xp+x,yp+y,S_FOOT);
end;
sav: { ulozi kocku do pola }
if( bod=1 )then
pole[x+xp,y+yp]:=col;
end; { case }
end; { for }
{ vypnem kurzor }
KurzorZap(false);
end;
{ zisti ci je mozne polozit kocku }
function KockaOK(xp,yp,typ,otoc:integer):boolean;
var x,y: integer;
bod: byte;
res: boolean;
begin
{ zatial si mysli ze kocku je mozne polozit }
res:=true;
{ v cykle vygenerujeme jednotlive prvky kocky }
for y:=1 to 4 do
for x:=1 to 4 do
begin
case otoc of
1: bod := CUBE[typ,x,y];
2: bod := CUBE[typ,5-y,x];
3: bod := CUBE[typ,5-x,5-y];
4: bod := CUBE[typ,y,5-x];
end;
{ este ci je tam volne miesto }
if( res )then
if( pole[x+xp,y+yp]<>0 )then
res:=false;
end; { if }
end; { for }
{ moja odpoved }
kockaOK:=res;
end;
{ zmaze zaplneny riadok }
{ a ostane posunie nadol }
procedure ZmazRiadok(yr:integer);
var x,y:integer;
begin
TextColor(Black);
{ efekt postupneho mazania }
for x:=1 to WIDTH do
begin
WriteXY(x,yr,S_CUBE);
Delay(20);
end;
{ efekt padu riadkov }
for y:=yr downto 2 do
for x:=1 to WIDTH do
begin
pole[x,y]:=pole[x,y-1];
if( pole[x,y]=0 )then
begin
TextColor(FOOT[x mod 2]);
WriteXY(x,y,S_FOOT);
end
else begin
TextColor(pole[x,y]);
WriteXY(x,y,S_CUBE);
end
end;
end;
{ skontroluje ktore riadky ma zmazat }
procedure Skontroluj(yr:integer);
var x,y:integer;
del:boolean;
begin
for y:=yr to Min(yr+4, HEIGHT) do
begin
del:=true;
for x:=1 to WIDTH do
if( pole[x,y]=0 )then
del:=false;
if( del )then
begin
ZmazRiadok(y);
body:=body+level;
tlev:=tlev+1;
end;
end;
{ ideme do dalsieho levelu }
if( tlev>=TO_LEV )then
begin
tlev:=0;
level:=level+1;
end;
end;
{ precita stlacenu klavesu }
function GetKey(level:byte):char;
var i:integer;
ch:char;
begin
ch:=#0;
for i:=1 to 200-level*5 do
begin
{ ak stlacil precitam klaves }
if( keypressed )then
begin
ch:=readkey;
if( ch=#0 )then
ch:=readkey;
end;
delay(1);
end;
GetKey:=ch;
end;
BEGIN
ClrScr;
Randomize;
ClrPole;
Podklad;
body :=0;
tlev :=0;
level:=1;
y :=1;
ch:=#0;
repeat
{ generuj kocku a next typ }
if( y=1 )then
begin
x := (WIDTH div 2)-2;
otoc := random(4)+1;
typ := random(7)+1;
col := random(15)+1;
end;
{ nakresli }
Kocka(x,y,typ,otoc,col,put);
{ bud rychlo pada alebo citam klaves }
if( ch<>#32 )then
ch:=GetKey(level);
{ zmaz staru }
Kocka(x,y,typ,otoc,Black,clr);
{ podmienky otocit, vlavo, vpravo }
if(ch='K') and KockaOK(x-1,y,typ,otoc) then x:=x-1;
if(ch='M') and KockaOK(x+1,y,typ,otoc) then x:=x+1;
if(ch='P') and KockaOK(x,y,typ,TPred(otoc)) then otoc:=TPred(otoc);
if(ch='H') and KockaOK(x,y,typ,TSucc(otoc)) then otoc:=TSucc(otoc);
{ posuniem o riadok nizsie }
if( KockaOK(x,y+1,typ,otoc))then
y:=y+1
else
{ kocka spadla }
begin
Kocka(x,y,typ,otoc,col,put);
Kocka(x,y,typ,otoc,col,sav);
Skontroluj(y);
ch:=#0;
if(y=1) then ch:=#27; { niet kam polozit koncim }
y :=1;
end;