Hra autíčko - musíte se vyhýbat příšerám

{ AUTICKO.PAS                              Copyright (c) Ales Kucik }
{ Hra auticko v grafickem rezimu - musite se vyhybat priseram.      }
{                                                                   }
{ Datum:29.11.2002                             http://www.trsek.com }
 
program Auticko;
{$G+}
uses Crt;
const
  Sirka= 15;
  Delka= 12;   {Zalezi na grafickem modu}
  RelX=30; {Vzdalenost od leveho kraje obrazovky}
  Hustota=50; {Cislo udava s jakou pravdepodobnosti padne zed 1:Hustota}
  Dvoji=0;
  PocitadloX=60;
  PocitadloY=10;
  VGA =$a000;
  uber=1;
 
 
 
type
  tBunka = (empty, wall);
  tHLmenu = (start,credit,konci);
  tOvladani = (levo,pravo,esc);
  tAuto = record
           xStary,x,y:byte;
          end;
  tPlocha = array[1..Delka, 1..Sirka] of tBunka;
  tVirtual = array [1..64000] of byte;
  VirtPtr  = ^tVirtual;
  icon = array [1..15*15] of byte;
  tPal= array [0..255,1..3] of byte;  {Typ pro uchivani palety}
 
 
const  fauto : icon =(
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
2,0,0,0,0,2,2,2,2,2,0,0,0,0,2,
2,0,0,0,0,0,2,2,2,0,0,0,0,0,2,
2,2,0,0,0,0,2,2,2,0,0,0,0,2,2,
0,0,0,0,0,2,2,2,2,2,0,0,0,0,0,
0,0,0,0,0,2,4,4,4,2,0,0,0,0,0,
0,0,0,0,0,2,2,2,2,2,0,0,0,0,0,
2,0,0,0,0,2,2,2,2,2,0,0,0,0,2,
2,0,0,0,0,0,2,2,2,0,0,0,0,0,2,
2,0,0,0,0,2,2,2,2,2,0,0,0,0,2,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
2,2,0,0,2,2,2,2,2,2,2,0,0,2,2,
2,0,0,0,0,2,2,2,2,2,0,0,0,0,2,
2,2,0,0,0,0,2,2,2,0,0,0,0,2,2);
 
 
fwall : icon =(
0,3,3,0,0,3,3,0,0,3,3,0,0,0,0,
0,3,3,3,0,3,3,3,3,3,3,3,0,0,0,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
0,3,3,3,3,3,3,3,3,3,3,3,0,0,3,
0,0,3,3,3,3,3,3,3,3,3,3,3,0,0,
0,3,3,3,3,3,3,3,3,3,3,3,0,0,0,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,0,0,3,
0,0,3,3,3,3,3,3,3,3,3,3,3,0,0,
0,0,0,3,3,3,3,3,3,3,3,3,3,0,0,
0,0,3,3,3,3,3,3,3,3,3,3,0,0,3,
3,3,3,3,3,3,0,0,3,3,3,3,3,3,3,
0,3,0,0,3,3,0,0,0,3,3,3,0,0,3,
0,0,0,0,3,0,0,0,3,3,0,0,0,0,0,
0,0,0,3,3,0,0,0,0,3,3,0,0,0,0);
 
 
var
  konec:boolean;
  VirScr:VirtPtr;
  Vaddr:word;
  font:pointer;
  height:byte;
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
BEGIN
  asm
     mov        ax,0013h
     int        10h
  end;
END;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure SetText;  { This procedure returns you to text mode.  }
BEGIN
  asm
     mov        ax,0003h
     int        10h
  end;
END;
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Cls (Col : Byte; Where:word);
   { This clears the screen to the specified color }
BEGIN
     asm
        push    es
        mov     cx, 32000;
        mov     es,[where]
        xor     di,di
        mov     al,[col]
        mov     ah,al
        rep     stosw
        pop     es
     End;
END;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
  { This puts a pixel on the screen by writing directly to memory. }
BEGIN
  Asm
    push    ds
    push    es
    mov     ax,[where]
    mov     es,ax
    mov     bx,[X]
    mov     dx,[Y]
    push    bx                      {; and this again for later}
    mov     bx, dx                  {; bx = dx}
    mov     dh, dl                  {; dx = dx * 256}
    xor     dl, dl
    shl     bx, 1
    shl     bx, 1
    shl     bx, 1
    shl     bx, 1
    shl     bx, 1
    shl     bx, 1                   {; bx = bx * 64}
    add     dx, bx                  {; dx = dx + bx (ie y*320)}
    pop     bx                      {; get back our x}
    add     bx, dx                  {; finalise location}
    mov     di, bx
    {; es:di = where to go}
    xor     al,al
    mov     ah, [Col]
    mov     es:[di],ah
    pop     es
    pop     ds
  End;
END;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure WaitRetrace; assembler;
  {  This waits for a vertical retrace to reduce snow on the screen }
label
  l1, l2;
asm
    mov dx,3DAh
l1:
    in al,dx
    and al,08h
    jnz l1
l2:
    in al,dx
    and al,08h
    jz  l2
end;
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure SetUpVirtual;
   { This sets up the memory needed for the virtual screen }
BEGIN
  GetMem (VirScr,64000);
  vaddr := seg (virscr^);
  {GetMem (VirScr2,64000);
  vaddr2 := seg (virscr2^);}
END;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure ShutDown;
   { This frees the memory used by the virtual screen }
BEGIN
  FreeMem (VirScr,64000);
  {FreeMem (VirScr2,64000);}
END;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure flip(source,dest:Word);
  { This copies the entire screen at "source" to destination }
begin
  asm
    push    ds
    mov     ax, [Dest]
    mov     es, ax
    mov     ax, [Source]
    mov     ds, ax
    xor     si, si
    xor     di, di
    mov     cx, 32000
    rep     movsw
    pop     ds
  end;
end;
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte);
  { This reads the values of the Red, Green and Blue values of a certain
    color and returns them to you. }
Begin
   Port[$3c7] := ColorNo;
   R := Port[$3c9];
   G := Port[$3c9];
   B := Port[$3c9];
End;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure Pal(ColorNo : Byte; R,G,B : Byte);
  { This sets the Red, Green and Blue values of a certain color }
Begin
   Port[$3c8] := ColorNo;
   Port[$3c9] := R;
   Port[$3c9] := G;
   Port[$3c9] := B;
End;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure GrabPalette(var XPalette : tPal);
{Naplni zvolenou promenou typu tPal paletou jakou chci}
var loop1:integer;
begin
  for loop1:=0 to 255 do
   GetPal(loop1, XPalette[loop1,1], XPalette[loop1,2], XPalette[loop1,3]);
end;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure RestorePalette(XPalette : tPal);
{Nastavy paletu jakou chci}
var loop1:integer;
begin
  for loop1:=0 to 255 do
    Pal(loop1, XPalette[loop1,1], XPalette[loop1,2], XPalette[loop1,3]);
end;
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
Procedure XYText(const Font: Pointer;const X,Y: Word;
                 const Color: Byte;const S: String; where:word);Assembler;
 
var
 FirstChar,
 CharHeight   :Byte;
 CharNr,
 ScreenPTR    :Word;
 
asm
 push ds
 
 mov ax,where     { Setup ES:[BX] = X,Y to plot at }
 mov es,ax
 mov bx,x
 mov ax,y
 xchg ah,al
 add bx,ax
 shr ax,2
 add bx,ax
 lds di,font
 mov dl,[di]       { height of font goes into dh }
 mov CharHeight,dl
 inc di
 mov dl,[di]
 mov FirstChar,dl
 mov CharNr,0     { Ugh! Character counter, not a very }
                  { good method, but I'm all out of registers :-( }
 
@nextchar:
 inc CharNr       { also skips lengthbyte! }
 push ds          { This I don't like, pushing and popping. }
 lds si,[S]       { But unfortunately I can't seem to find }
 add si,CharNr    { any spare registers? Intel, can you help? }
 lodsb            { load asciivalue into al }
 pop ds
 cmp al,0         { check for null-termination }
 je @exit         { exit if end of string }
 
 mov ScreenPTR,BX { save bx }
 mov dh,CharHeight
 xor ah,ah
 mov cl,firstchar { firstchar }
 sub al,cl        { al = currentchar - firstchar }
 mov si,ax        { di = scrap register }
 mul dh           { ax * fontheight }
 add ax,si        { ax + characters to skip }
 
 lds di,font      { This can be omptimized I think (preserve DI) }
 add di,3         { skip header }
 add di,ax        { Point into structure }
 mov cl,[di]      { get character width }
 
@nextline:
 mov ch,cl        { ch is the height counter. cl is the original. }
 inc di           { .. now points to bitmap }
 mov dl,[di]      { get bitmap byte }
 
@nextpixel:
 rol dl,1         { rotate bitmap and prepare for next pixel }
 mov al,dl        { mov bitmap into al for manipulation }
 and al,1         { mask out the correct bit }
 jz @masked       { jump if transperent }
 mov al,color
 mov byte ptr es:[bx],al { Set the pixel on the screen }
@masked:
 inc bx           { increment X-offset }
 dec ch           { are we done? last byte in character? }
 jnz @nextpixel   { nope, out with another pixel }
 add bx,320       { Go to next line on the screen }
 sub bx,cx        { X-alignment fixup }
 dec dh           { are we done with the character? }
 jnz @nextline
 mov bx,ScreenPTR { restore screen offset and prepare for next character }
 add bx,cx
 inc bx           { A little gap between the letters, thank you... }
 jmp @nextchar
 
@exit:
 pop ds
end;
 
 
 
 
 
 
{ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ}
procedure Game;
var
  loopG:integer;
  GameOver:boolean;
  Auto:tAuto;
  Plocha:tPlocha;
  Counter:longint;
  Xxloop:byte;
{*************** Procedurky a Fce ****************}
  procedure PutFrame(x,y:integer;XFrame:icon; where:word);
  var i,j:integer;
  begin
    for i:=1 to 15 do
     for j:=1 to 15 do
      if XFrame[(i-1)*15+j]<>0 then
                   putpixel(x*15+j-1,y*15+i-1,XFrame[(i-1)*15+j],where);
  end;
 
  procedure initFirst(var xAuto:tAuto; var xPlocha:tPlocha);
  var i,j:byte;
  begin
    xAuto.x:=10;
    xAuto.xStary:=xAuto.x;
    xAuto.y:=Delka;
    for i:=1 to delka do
      begin
        xPlocha[i,1] :=wall;
        xPlocha[i,sirka]:=wall;
        for j:=2 to sirka-1 do xPlocha[i,j]:=empty;
      end;
  end;
 
  procedure ZobrazG (var xPlocha:tPlocha; var XCount: longint);
  var i,j:byte;
      ss:string[8];
  begin
    Cls(16,Vaddr);
    for i:=1 to delka do
      for j:=1 to sirka do
        if xPlocha[i,j]=wall then PutFrame((j-1),(i-1),fWall,Vaddr);
     str(XCount,ss);
     XYText(font,240,10,35,'SCORE:'+#0,vaddr);
     XYText(font,240,10+height,38,ss+#0,vaddr);
     WaitRetrace;
     flip(Vaddr,VGA);
  end;
 
  procedure ZobrazA (var xAuto:tAuto);
 
  var i,j:integer;
 
  begin
    if xAuto.x <> xAuto.xStary then
     for i:=(delka-1)*15 to (delka)*15 do
      for j:= (xAuto.xStary-1)*15 to xAuto.xStary*15 do PutPixel(j,i,0,VGA);
    PutFrame(xAuto.x-1,delka-1,fAuto,VGA);
    xAuto.xStary:=xAuto.x;
  end;
 
  procedure Vlevo (var xAuto:tAuto; var xPlocha:tPlocha);
  begin
    if xPlocha[xAuto.y,xAuto.x-1]=empty then xAuto.x:=xAuto.x-1;
  end;
 
  procedure Vpravo(var xAuto:tAuto; var xPlocha:tPlocha);
  begin
    if xPlocha[xAuto.y,xAuto.x+1]=empty then xAuto.x:=xAuto.x+1;
  end;
 
  procedure Dalsi (var xPlocha:tPlocha);
  var i,j:byte;
  begin
    for i:=delka downto 2 do
      for j:= 2 to sirka-1 do xPlocha[i,j]:=xPlocha[i-1,j];
    for j:=2 to sirka-1 do
      begin
        if random(Hustota)=0 then xPlocha[1,j]:=wall
        else xPlocha[1,j]:=empty;
      end;
  end;
 
 
  function Ovladani:tOvladani;
  var
    Znak:char;
  begin
    Znak:=readkey;
    if ord(Znak)=Dvoji then     {Cteni znaku s dvojim nacitanim}
      begin
        Znak:=readkey;
        case ord(Znak) of
          75: Ovladani:= levo;
          77: Ovladani:= pravo;
        end;
      end
    else
      if ord(Znak)= 27 then Ovladani:= Esc;
  end;
 
  procedure KonecHrac;
  begin
    cls(0,VGA);
    XYText(font,30,100-height,42,'*************************'+#0,VGA);
    XYText(font,30,100,38,       '**** !!!  KONEC  !!! ****'+#0,VGA);
    XYText(font,30,100+height,42,'*************************'+#0,VGA);
    repeat until keypressed;
  end;
 
 
  function Koncis(xAuto:tAuto;xPlocha:tPlocha):boolean;
  begin
    if xPlocha[delka-1,xAuto.x]= wall then koncis:=true
    else koncis:= false;
  end;
 
 
begin      {Main GAME}
  initFirst(Auto,Plocha);
  GameOver:=false;
  Counter:=0;
  XxLoop:=10;
  SetUpVirtual;
  Cls(0,VGA);
  Cls(0,Vaddr);
  repeat
    ZobrazG(Plocha,Counter);
    ZobrazA(Auto);
    for loopG:=1 to XxLoop do
      begin
        WaitRetrace;
        ZobrazA(Auto);
        if keypressed then
          begin
            case Ovladani of
              levo : Vlevo (Auto,Plocha);
              pravo: Vpravo(Auto,Plocha);
              esc  : GameOver:=true;
            end;
          end;
      end;
    Counter:=Counter+1;
    if ((counter mod 30)=0)and(XxLoop > 2)then XxLoop:=Xxloop-1;
 
    if GameOver then KonecHrac{Ukonceno uzivatelem}
    else
      if Koncis(Auto,Plocha) then
        begin
          GameOver:=true; {Uzivatel prohral}
          XYText(font,30,100,45,'Ha Ha NARAZILS !!!!'+#0,VGA);
          readln;
        end
      else Dalsi(Plocha); {Pokracovani hry}
  until GameOver;
  ShutDown;
end;      {Main GAME}
 
 
 
 
 
 
{*************************** INTRO *********************************}
procedure Intro;
 
type
  iconlogo=array[1..15*66] of byte;
 
const
  waitx=20;
 
  logo:iconLOGO=(
0,0,0,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,1,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,1,0,0,0,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,1,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,1,1,1,1,1,0,0,0,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,
0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,
0,0,0,0,0,1,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,
0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,
0,0,0,0,1,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,
0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,
0,0,0,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,
0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,1,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
 
 
{15X66}
 
var
  OldPal,NewPal:tPal;
  i,j:integer;
 
procedure PutLogo;
  var i,j:integer;
  begin
    for i:=1 to 15 do
     for j:=1 to 66 do
      if logo[(i-1)*66+j]<>0 then
           putpixel(ROUND((320-66)/2)+j-1,ROUND((200-15)/2)+i-1,51,VGA);
  end;
 
 
procedure HLine (y:integer; col:byte; where:word);
var loop:integer;
begin
  for loop:=0 to 319 do putpixel(loop,y,col,where);
end;
 
 
procedure PalPlay;
var
  loop1,loop2:integer;
  R,G,B:byte;
 
 
begin
  for loop1:=1 to 50 do
    begin
     delay(waitx+50);
     waitretrace;
     for loop2:=1 to loop1 do
      begin
        GetPal(loop2,R,G,B);
        Pal(loop2,R+1,0,0);
      end;
    end;
 
end;
 
procedure RedUp;
var loop1,loop2:integer;
    Tmp : Array [1..3] of byte;
      { This is temporary storage for the values of a color }
BEGIN
  For loop1:=1 to 64 do
   BEGIN
      { A color value for Red, green or blue is 0 to 63, so this loop only
        need be executed a maximum of 64 times }
    waitretrace;
    For loop2:=1 to 50 do
     BEGIN
      Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
      If Tmp[1]<63 then inc (Tmp[1]);
      Pal (loop2,Tmp[1],0,0);
        { Set the new, altered pallette color. }
     END;
    delay(waitx);
   END;
END;
 
 
Procedure Fadeup;
  { This procedure slowly fades up the new screen }
VAR loop1,loop2:integer;
    Tmp : Array [1..3] of byte;
      { This is temporary storage for the values of a color }
BEGIN
  For loop1:=1 to 64 do
   BEGIN
      { A color value for Red, green or blue is 0 to 63, so this loop only
        need be executed a maximum of 64 times }
    waitretrace;
    For loop2:=1 to 50 do
     BEGIN
      Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
      If Tmp[1]<63 then inc (Tmp[1]);
      If Tmp[2]<63 then inc (Tmp[2]);
      If Tmp[3]<63 then inc (Tmp[3]);
      Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
        { Set the new, altered pallette color. }
     END;
   delay(waitx);
  END;
END;
 
Procedure FadeOut;
  { This procedure slowly fades up the new screen }
VAR loop1,loop2:integer;
    Tmp : Array [1..3] of byte;
      { This is temporary storage for the values of a color }
BEGIN
  For loop1:=1 to 64 do
   BEGIN
      { A color value for Red, green or blue is 0 to 63, so this loop only
        need be executed a maximum of 64 times }
    waitretrace;
    For loop2:=1 to 50 do
     BEGIN
      Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
      If Tmp[1]>0 then dec (Tmp[1]);
      If Tmp[2]>0 then dec (Tmp[2]);
      If Tmp[3]>0 then dec (Tmp[3]);
      Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
        { Set the new, altered pallette color. }
     END;
   delay(waitx);
  END;
END;
 
procedure Obdelniky1;
var
  loop1,loop2,loop3:integer;
  helpX,helpY,x,y:integer;
 
begin
  for loop1:=0 to 48 do
    begin
      y:=200-loop1*4;
      x:=round(8*y/5);
      helpX:=round((320-x)/2);
      helpY:=loop1*2;
      for loop2:=helpy to Helpy+y-1 do
        for loop3:=helpx to helpx+x-1 do putpixel(loop3,loop2,loop1+1,VGA);
    end;
end;
 
 
begin
  SetUpVirtual;
  Cls(0,Vaddr);
  Cls(0,VGA);
  GrabPalette(OldPal);
  for i:=1 to 51 do pal(i,0,0,0);
  for i:=0 to 49 do
    for j:=0 to 3 do
      HLine(i*4+j,i+1,VGA);
  PutLogo;
  Palplay;
  RedUp;
  FadeUp;
  Obdelniky1;
  for i:=1 to 50 do
    begin
      waitretrace;
      pal(i,64-i,64-i,64-i);
      delay(30);
    end;
  fadeout;
  for i:=1 to 50 do
    begin
      waitretrace;
      pal(i,64-i,64-i,0);
      delay(30);
    end;
  for i:=1 to 25 do
    begin
      waitretrace;
      pal(i,0,0,64-i);
      delay(30);
    end;
  for i:=26 to 50 do
    begin
      waitretrace;
      pal(i,0,0,14+i);
      delay(30);
    end;
  j:=0;
  pal(51,0,0,0);
  pal(52,0,0,0);
  XYText(font,round((320-5*9)/2),80,51, 'FUNNY'+#0,VGA);
  XYText(font,round((320-5*9)/2),100,52,'SPACE'+#0,VGA);
  for i:=0 to 63 do
    begin
      pal(51,i,0,0);
      pal(52,i,i,0);
      delay(20);
    end;
  fadeout;
  delay(500);
  waitretrace;
  cls(0,VGA);
  RestorePalette(OldPal);
  ShutDown;
end;
 
 
procedure JaJenJA;
begin
  cls(0,VGA);
  XYText(font,120+4,1*height,32,'WRITTEN'+#0,VGA);
  delay(500);
  XYText(font,120,3*height,35,'DESIGNED'+#0,VGA);
  delay(500);
  XYText(font,120,5*height,38,'ANIMATED'+#0,VGA);
  delay(500);
  XYText(font,120,7*height,41,'   BY   '+#0,VGA);
  delay(500);
  XYText(font,120,9*height,44,' ALESEK '+#0,VGA);
  repeat until keypressed;
  readkey;
end;
 
procedure ZobrazHLm;
begin
  XYText(font,0,0,32,'Start hry.........s'+#0,VGA);
  XYText(font,0,Height,33,'Credits...........c'+#0,VGA);
  XYText(font,0,2*Height,34,'Konec...........ESC'+#0,VGA);
end;
 
function HLmenu:tHLmenu;
var
  Znak:char;
begin
  Znak:=readkey;
  case Znak of
    's','S': HLmenu:= start;
    'c','C': HLmenu:= credit;
    chr(27): HLmenu:= konci;
  end;
end;
 
 
var f:file;
    fsize:word;
 
 
begin    {Main program}
  clrscr;
  Assign(f,'rose.dat');{Mozna bude potreba upravit tuto cesu k danemu souboru}
  {$I-}
  Reset(f,1);
  {$I+}
  if IOresult <> 0 then
    begin
      writeln('Nenasel jsem soubor s fontem - rose.dat');
      writeln('Nejspis bude potreba upravit cestu na radku 766 nebo ->');
      writeln('Pokud spoustite program v kompilatoru musi byt soubor');
      writeln('umisten v c:\rose.dat.');
      writeln('Jinak jestli spoustite zkompilovanou verzi (*.exe) musi');
      writeln('byt rose.dat ve stejnem adresari jako dany soubor!');
      writeln;writeln;
      writeln('Stisknete klavesu');
      repeat until keypressed;
      halt;
    end;
  fsize:=filesize(f);
  getmem(font,fsize);
  BlockRead(f,Font^,FileSize(F));
  Close(f);
  reset(f,1);
  blockread(f,height,sizeof(height));
  close(f);
  randomize;
  SetMCGA;
  intro;
  repeat
    waitretrace;
    cls(0,VGA);
    ZobrazHLm;
    case HLmenu of
      start : Game;
      credit: JaJenJA;
      konci : konec:=true;
    end;
  until konec;
  settext;
  freemem(font,fsize);
end.