Localize file www.TrSek.com/pas/loyd15.pas{ LOYD15.PAS Copyright (c) VAV alias M. Vook }
{ Hra Loydova 15. Perfektne jednoducho urobena. }
{ Vyzaduje EGAVGA.OBJ a TRIP.CHR }
{ }
{ Datum:21.01.1995 http://www.trsek.com }
program loyd15;
uses crt,dos,graph,ovladace;
var loyd:array[1..4,1..4] of integer;
gd,gm,x,y,xp,yp,i:integer;
ch:char;
bol:boolean;
paleta:palettetype;
Procedure ikona(x,y,a:integer);
begin
if (a=1) then begin
setcolor (12);
setfillstyle (1,4);
bar (x,y,x+140,y+80);
setfillstyle (1,12);
bar (x,y,x+135,y+75);
bar (x,y+75,x+2,y+78); {ROHY IKON}
line (x,y+80,x+5,y+75);
line (x,y+79,x+4,y+75);
bar (x+136,y+2,x+138,y);
line (x+135,y+5,x+140,y);
line (x+135,y+4,x+139,y);
setfillstyle (1,1);
bar (x+5,y+5,x+135,y+75);
end;
end;
{ outtextxy (480,50,'Poskladaj cisla');
outtextxy (480,100,'od 1 do 15. ');
outtextxy (480,200,'Program od ');
outtextxy (480,250,'M. V O O K A ');
outtextxy (480,400,'Press ');
outtextxy (480,418,' Esc ');
outtextxy (480,436,' to ');
outtextxy (480,454,' Exit');}
settextstyle(1,0,6);
end;
Procedure gong;
var d,f:integer;
begin
for f:=50 to 150 do begin
sound (f);
end;
nosound;
end;
Procedure zamiesaj;
var x,y,i:integer;
ok:boolean;
begin
for x:=1 to 4 do for y:=1 to 4 do loyd[x,y]:=0;
for i:=1 to 15 do begin
x:=random (4)+1;
y:=random (4)+1;
ok:=false;
repeat
if loyd[x,y]=0 then begin
ok:=true;
loyd[x,y]:=i;
end;
if not(ok) and (x<4) then begin
x:=x+1;
if loyd [x,y]=0 then begin
ok:=true;
loyd[x,y]:=i;
end;
end;
if not(ok) and (x=4) and (y<4) then begin
x:=1;
y:=y+1;
if loyd[x,y]=0 then begin
ok:=true;
loyd[x,y]:=i;
end;
end;
if not(ok) and (x=4) and (y=4) then begin
x:=1;
y:=1;
if loyd[x,y]=0 then begin
ok:=true;
loyd[x,y]:=i;
end;
end;
until ok;
end;
end;
procedure policko (x,y:integer);
var s,t:string;
begin
setfillstyle (1,blue);
bar (20+(x-1)*110,20+(y-1)*110,15+x*110,15+y*110);
setcolor (14);
if loyd[x,y]<>0 then begin
str (loyd[x,y],s);
if length(s)=2 then outtextxy(30+(x-1)*110,30+(y-1)*110,s)
else outtextxy(60+(x-1)*110,30+(y-1)*110,s);
end;
end;
procedure vykresli;
var x,y:integer;
begin
setfillstyle (1,green);
bar (15,15,465,465);
for x:=1 to 4 do for y:=1 to 4 do policko(x,y);
end;
function poskladane:integer;
var x,y,i,posk:integer;
begin
posk:=1;
x:=0;
y:=1;
i:=0;
repeat
x:=x+1;
i:=i+1;
if x>4 then begin
x:=1;
y:=y+1;
end;
if loyd[x,y]<>i then posk:=2;
until (posk=2);
if (x=4) and (y=4) and (loyd[4,4]=0) then posk:=1;
poskladane:=posk;
end;
{*********************************************************************}
begin
RegisterBGIdriver(@EGAVGAOvladac);
randomize;
detectgraph(gd,gm);
initgraph (gd,gm,'');
getpalette (paleta);
setbkcolor (8);
cleardevice;
okraj;
settextstyle(1,0,6);
bol:=false;
ch:='`';
zamiesaj;
for x:=1 to 4 do for y:=1 to 4 do begin
if loyd[x,y]=0 then begin
xp:=x;
yp:=y;
end;
end;
vykresli;
settextstyle(1,0,6);
repeat
if keypressed then ch:=readkey;
if ch=#0 then begin
ch:=readkey;
if (ch=#75) and (xp<4) then begin
loyd[xp,yp]:=loyd[xp+1,yp];
loyd[xp+1,yp]:=0;
policko (xp,yp);
xp:=xp+1;
policko (xp,yp);
gong;
end;
if (ch=#77) and (xp>1) then begin
loyd[xp,yp]:=loyd[xp-1,yp];
loyd[xp-1,yp]:=0;
policko (xp,yp);
xp:=xp-1;
policko (xp,yp);
gong;
end;
if (ch=#80) and (yp>1) then begin
loyd[xp,yp]:=loyd[xp,yp-1];
loyd[xp,yp-1]:=0;
policko (xp,yp);
yp:=yp-1;
policko (xp,yp);
gong;
end;
if (ch=#72) and (yp<4) then begin
loyd[xp,yp]:=loyd[xp,yp+1];
loyd[xp,yp+1]:=0;
policko (xp,yp);
yp:=yp+1;
policko (xp,yp);
gong;
end;
end;
if poskladane=1 then bol:=true;
if ch=#27 then bol:=true;
until (bol);
delay (50);
setfillstyle (1,7);
bar (30,200,410,270);
setfillstyle (1,8);
bar (40,210,400,260);
setcolor (10);
settextstyle(1,0,5);
outtextxy (50,205,'CONGRATULATION');
for x:=30 downto 0 do begin
setrgbpalette (1,20,10,3*x);
delay(50);
end;
for x:=30 downto 0 do begin
setrgbpalette (2,x,x*2,x*3);
end;
for x:=30 downto 0 do begin
setrgbpalette (4,3*x,x,x);
end;
for x:=30 downto 0 do begin
setrgbpalette (8,x,3*x,x);
end;
for x:=30 downto 0 do begin
setrgbpalette (10,2*x,x,x);
end;
for x:=30 downto 0 do begin
setrgbpalette (12,x,x,x);
end;
for x:=30 downto 0 do begin
setrgbpalette (14,x,x,x);
end;
setallpalette(paleta);
closegraph;
end.