Program sare;
Uses Crt, Graph;
type
    hjk=array[1..12] of integer;
const
  ste:hjk=(3,4,5,6,4,12,11,7,13,2,9,10);
Var Gd, Gm : Integer;
    A, b, p, d, l : Pointer;
    sizeq:Array[1..5] Of Integer;
    x,y4,dx,dy,y0,bi,ai,i1,te,x0:integer;
    at1:real;
Procedure EGAVGADriver; External; {$L EGAVGA.obj}
Procedure SimpChr; External; {$L Simp.obj}

Procedure InitPointers;
Var Size : Integer;
Begin
     SetActivePage(0);
     SetVisualPage(1);
     SetTextStyle(6, 0, 8);
     OutTextXY(10, 10, 'Sfarsit');
     Size := ImageSize(10, 45, 225, 100);
     GetMem(a, Size);
     GetImage(10, 45, 225, 100, a^);
     sizeq[1]:= Size;
     OutTextXY(226, 10, 'Graphics');
     Size := ImageSize(226, 40, 505, 115);
     GetMem(b, Size);
     GetImage(226, 40, 505, 115, b^);
     sizeq[2] := Size;
     OutTextXY(10, 90, 'by');
     Size := ImageSize(10, 100, 205, 195);
     GetMem(p, Size);
     GetImage(10, 100, 205, 195, p^);
     sizeq[3] := Size;
     OutTextXY(320, 90, 'Cris');
     Size := ImageSize(320, 115, 585, 195);
     GetMem(d, Size);
     GetImage(320, 115, 585, 195, d^);
     sizeq[4] := Size;
     fillellipse(300, 250, 20,20);
     Size := ImageSize(280, 230, 320, 270);
     GetMem(l, Size);
     GetImage(280, 230, 320, 270, l^);
     sizeq[5] := Size;
     ClearDevice;
     SetVisualPage(0);
End;
Procedure misca(X, Y : Word; P : Pointer);
Var I, J, YDir : Word;
Begin
     ClearDevice;
     YDir := 1;
     I := X;
     J := Y;
     Repeat
        SetActivePage(0);
        SetVisualPage(1);
        ClearDevice;
        Inc(i, 3);
        YDir := YDir+2;
        j := j+ydir;if i>250 then i:=i-20;
        If (j>250) Then YDir := -YDir;
        Putimage(j, i, P^, NormalPut);
        SetActivePage(1);
        SetVisualPage(0);
        ClearDevice;
        Inc(i, 3);
        YDir := YDir+2;
        j := j+ydir;if i>250 then i:=i-20;
        If (j>250) Then YDir := -YDir;
        Putimage(j, i, P^, NormalPut);
     Until (j>300);
     ClearDevice;
End;
Procedure misca_te(X, Y : Word; P : Pointer);
Var I, J, YDir : Word;
Begin
     ClearDevice;
     YDir := 1;
     I := X;
     J := Y;
     Repeat
        SetActivePage(0);
        SetVisualPage(1);
        ClearDevice;
        Inc(i, 3);
        YDir := YDir+2;
        j := j+ydir;
        If (j>250) Then YDir := -YDir;
        Putimage(i, j, P^, NormalPut);
        SetActivePage(1);
        SetVisualPage(0);
        ClearDevice;
        Inc(i, 3);
        YDir := YDir+2;
        j := j+ydir;
        If (j>250) Then YDir := -YDir;
        Putimage(i, j, P^, NormalPut);
     Until (j>300);
     ClearDevice;
End;
Procedure ping_pong;
Var X, Y, XDir, YDir : Word;
Begin
    SetRGBPalette(1, 63, 63, 63);
    X := 320;
    Y := 200;
    XDir := 1;
    YDir := 1;
    Repeat
        SetActivePage(0);
        SetVisualPage(1);
        ClearDevice;
        X := X+XDir;
        Y := Y+YDir;
        YDir := YDir+1;
        XDir := XDir+1;
        If (X<15) Then XDir := -XDir;
        If (X>600) Then XDir := -XDir;
        If (Y<15) Then YDir := -YDir;
        If (Y>315) Then YDir := -YDir;
        Putimage(X, Y, l^, NormalPut);
        Delay(20);
        SetActivePage(1);
        SetVisualPage(0);
        ClearDevice;
        X := X+XDir;
        Y := Y+YDir;
        YDir := YDir+1;
        XDir := XDir+1;
        If (X<15) Then XDir := -XDir;
        If (X>600) Then XDir := -XDir;
        If (Y<15) Then YDir := -YDir;
        If (Y>315) Then YDir := -YDir;
        Putimage(X, Y, l^, NormalPut);
        Delay(20);
    Until (X<10) Or KeyPressed;
End;
Procedure ce_ar_fi;
Var I : Integer;
Begin
    SetActivePage(0);
    SetVisualPage(0);
    ClearDevice;
    SetRGBPalette(1, 0, 0, 0);
    SetTextStyle(0, 0, 1);
    OutTextXy(80, 100, '...   Peace be with you! ');
    OutTextXy(80, 110, '      Lebe wohl!    astept <Enter>!!');
    For I := 1 To 63 Do
        SetRGBPalette(1, I, I, I);
    ReadLn;
    For I := 63 DownTo 1 Do
        SetRGBPalette(1, I, I, I);
    ClearDevice;
End;
Procedure atat;
Var I : Integer;
Begin
    SetActivePage(0);
    SetVisualPage(0);
    ClearDevice;
    SetRGBPalette(1, 0, 0, 0);
    SetTextStyle(0, 0, 1);
    OutTextXy(270, 100, '.. atat deocamdata!..');
    For I := 1 To 63 Do
        SetRGBPalette(1, I, I, I);
    Delay(1000);
    For I := 63 DownTo 1 Do
        SetRGBPalette(1, I, I, I);
End;
Procedure ClearPointers;
Begin
    FreeMem(a, sizeq[1]);
    FreeMem(b, sizeq[2]);
    FreeMem(p, sizeq[3]);
    FreeMem(d, sizeq[4]);
    FreeMem(l, sizeq[5]);
End;
procedure cer;
var j,x,y4:integer;
begin
  randomize;te:=te+1 ;
  for j:=1 to 5000 do
     begin
       x:=random(639);y4:=random(479);
       putpixel(x,y4,ste[te]);
     end;
end;
BEGIN
     ClearPointers;
   Gd := vga;gm:=2;
      Initgraph(Gd,Gm,'d:\limbaje\tp7\bgi');
     Gd := VGA;
     Gm := VGAMed;  {640x350, 16 sz¡n}
     RegisterBGIFont(@SimpChr);
     RegisterBGIDriver(@EGAVGADriver);
     Initgraph(Gd,Gm,'');
     ClearDevice;
     SetRGBPalette(1, 63, 63, 63);
     SetColor(1);
     InitPointers;
     misca(1, 1, a);
     misca_te(1, 1, b);
     misca_te(1, 1, p);
     misca_te(1, 1, d);
     ce_ar_fi;
     ping_pong;
     atat;
     ClearPointers;
     CloseGraph;
END.
