{$E+,N+}
Program ScreenSaverType;
Uses Graph,CRT;
const
  NB = 5;
  MaxVx = 30;
  MaxVy = 21;
  Pause = 150;
  NC = 13;
{Цвета звеньев}
  BlockColors :array[1..NC] of Byte =(
    Brown, Red, Magenta, Blue, Cyan, Green, LightRed, LightMagenta,
    LightBlue, LightCyan, LightGreen, Yellow, White);
type
  Blk=  array [1..NB] of Byte;
  Coo=  array [1..NB] of Integer;
var
  Vx, Vy                           : Coo;
  Color, fnclbl, Hmuw, NumberBlock : Blk;
  GMX, GMY, Select, q              : Integer;
  BlocksFar                        : Boolean;
  NotFarNums                       : array[1..2,1..NB*NB] of Byte;
  UnitedBlocks                     : array [1..NB, 1..NB] of Boolean;
  Xs, Ys                           : array [0..1,1..NB] of Integer;
{----------------------------}
Function B(var O:Integer):Integer;
begin
  if O>13 then B:=13
	  else if O<1 then B:=1
		      else B:=O;
end;
{-------------}
Function len1(a,b:Integer):Single;
begin
  len1 := sqrt(sqr(1.0*a)+sqr(1.0*b));
end;
{----------------}
Function len2(X1,Y1,X2,Y2:Integer):Integer;
begin
  len2 := Round(sqrt(sqr(X1*1.0-X2*1.0)+sqr(Y1*1.0-Y2*1.0)));
end;
{------------}
Procedure NewVelCoo;
var
  i,j :Integer;
  MaxVvec,Vvec:Single;
begin
  MaxVvec :=len1(MaxVx,MaxVy);
  for i:=1 to NB do
    begin
      Xs[1,i]:=GetMaxX shr 1;
      Ys[1,i]:=GetMaxY shr 1;
      Vx[i] := Round(Random(2*MaxVx))-MaxVx;
      Vy[i] := Round(Random(2*MaxVy))-MaxVy;
      Vvec:=len1(Vx[i],Vy[i]);
      q:=Round(Vvec/MaxVvec*NC);
      Color[i]:= BlockColors[B(q)];
      NumberBlock[i]:=i;
      Hmuw[i]:=1; {----------}
      for j:=1 to NB do
       begin
	 UnitedBlocks[i,j]:= false;
	 if i=j then UnitedBlocks[i,j]:= true;
       end;
    end;
end;
{-----------------}
Procedure NewCoo;
var
   j,i,k,z       : Integer;
begin
   for i:=1 to NB do
    begin
      Xs[0,i]:=Xs[1,i];
      Ys[0,i]:=Ys[1,i];
    end;
  for i:=1 to NB do
   begin
     Xs[1,i]:=Xs[1,i]+Vx[i] ;
     Ys[1,i]:=Ys[1,i]+Vy[i] ;
     if (Xs[1,i]<=10) or (Xs[1,i]>=GetMaxX-10) then
       begin
	 Vx[i]:=-Vx[i];
	 if Xs[1,i]<=10 then Xs[1,i]:=11
			else Xs[1,i]:=GetMaxX-11;
       end;
     if (Ys[1,i]<=10) or (Ys[1,i]>=GetMaxY-10) then
       begin
	 Vy[i]:=-Vy[i];
	 if Ys[1,i]<=10 then Ys[1,i]:=11
			else Ys[1,i]:=GetMaxY-11;
       end;
   end;{for i:=1 to NB ...}
end;{NewCoo}
{---------------}
Procedure Init;
var
  D,R,e:Integer;
begin
  Randomize;
  D:=Detect;
  InitGraph(D,R,'');
  e:=GraphResult;
  if e<>grOk then
    begin
      Writeln(GraphErrorMsg(e));
      Halt;
    end;
  GMX:=GetMaxX+1;
  GMY:=GetMaxY+1;
  NewVelCoo;
  Select:=3;
  NewCoo;
end;
{----------d--------}
Procedure Done;
begin
  CloseGraph;
  {}
  Halt;
end;
{-----------------}
Procedure PutBlock(n:Integer);
begin
  SetColor(DarkGray);
  SetFillStyle(SolidFill,Color[n]);
  Bar3D(Xs[1,n],Ys[1,n],Xs[1,n]+20,Ys[1,n]+20,10,TopOn);
end;
{-----------------}
Procedure DelBlock(n:Integer);
begin
  SetColor(Black);
  SetFillStyle(EmptyFill,Black);
  Bar3D(Xs[0,n],Ys[0,n],Xs[0,n]+20,Ys[0,n]+20,10,TopOn);
end;
{----------------}
Procedure PutBlocks;
var
 i:Integer;
begin
  for i := 1 to NB do PutBlock(i);
end;
{-----------------}
Procedure DelBlocks;
var
  i : Integer;
begin
   for i := 1 to NB do DelBlock(i);
end;
{-----------------}
Procedure DifColorBoom;
var
  i :Integer;
begin
  for i:= 1 to NC do
    begin
      SetColor(DarkGray);
      SetFillStyle(SolidFill,BlockColors[i]);
      Bar3D(GMX shr 1,GMY shr 1, GMX shr 1 +20, GMY shr 1+20, 10, TopOn);
      Delay((Pause-150)*i);
    end;
  Delay(Pause*5);
end;
{----------------}
Procedure Play;
begin
  PutBlocks;
  NewCoo;
   Delay(Pause );
  DelBlocks;
  if KeyPressed then Done;
end;
{----------------}
Procedure Boom;
var
  j,i    : Integer;
  X0,Y0  : Integer;
  Xv,Yv  : Single{Real};
begin
  PutBlocks;
  Delay(5*Pause);
  for i := 1 to NB do
    begin
      X0:=Xs[1,i];
      Y0:=Ys[1,i];
      Xv:=(GMX shr 1 - X0)/len2(X0,Y0,GMX shr 1, GMY shr 1);
      Yv:=(GMY shr 1 - Y0)/len2(X0,Y0,GMX shr 1, GMY shr 1);
      for j := 1 to len2(X0,Y0,GMX shr 1,GMY shr 1) do
       begin
	 PutBlock(i);
	 Xs[0,i]:= Xs[1,i];
	 Ys[0,i]:= Ys[1,i];
	 Xs[1,i]:=Round(j*Xv)+X0;
	 Ys[1,i]:=Round(j*Yv)+Y0;
	 Delay(Pause shr 4);
	 DelBlock(i);
       end;
    end;
  DifColorBoom;
  NewVelCoo;
  for i := 1 to Nb div 10 do Play;
  Select := 1;
end;
{-----d--------}
Procedure Run1;
begin
  While NOT KeyPressed do Play;
  Select:=2
end;
{---------}
Procedure Run2;
var
  i:Integer;
begin
 for i := 1 to Nb do Play;
 Select := 3;
end;
{!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
begin {Основная программа}
  Init;
  While not KeyPressed do
    case Select of
    1:Run1;
    2:Run2;
    3:Boom;
   end;
  Done;
end.

Назад