Game Loyd15 in pascal use graphics

{ 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;
 
  Procedure okraj;
    var a,b:integer;
    begin
      ikona(480,20,1);
      ikona(480,110,1);
      ikona(480,200,1);
      ikona(480,290,1);
      ikona(480,380,1);
      setcolor (10);
      settextstyle(1,0,4);
      outtextxy (490,20,'Time:  ');
      outtextxy (490,50,' 00:00 ');
      outtextxy (490,130,'F1:Help');
      outtextxy (490,220,'F2: New');
      outtextxy (490,290,'F3:    ');
      outtextxy (490,320,'Options');
      outtextxy (490,400,'Esc:Exit');
 
 
{      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.