{$E+,N+}
Program ScreenSaverType;
Uses Graph,CRT;
{A-HA "You'll Never Get Over Me"}
const
MaxR = 28;
NB = 15;
MaxVx = 30;
MaxVy = 21;
Pause = 200;
Nh = 50;
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,p : 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 Abr(a:Integer):Integer;
var
i,k:Integer;
w:Boolean;
begin
W:=true;
for i:= 1 to NB do
for k:=1 to NB do
if unitedBlocks[i,k] then
begin
abr:=NumberBlock[i];
W:= false;
end ;
if w then
begin
NumberBlock[i]:=p;
p:=p+1;
end;
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;
{----------------}
Function BlocksUnited(N1,N2:Integer):Boolean;
begin
BlocksUnited:= UnitedBlocks[N1,N2] or UnitedBlocks[N2,N1];
end;
{-----------------}
Function AllBlocksUnited:Boolean;
begin
if Hmuw[NB] >= (NB -1 ) then {?} {!-!-!-!-!-!}
AllBlocksUnited:=True
else
AllBlocksUnited:=False;
end;
{-----------------}
Procedure NewCoo;
var
Vvec,MaxVvec : Single;
j,i,k,r,z : Integer;
begin
MaxVvec :=len1(MaxVx,MaxVy);
for i:=1 to NB do
begin
Xs[0,i]:=Xs[1,i];
Ys[0,i]:=Ys[1,i];
end;
if Select = 1 then
begin
BlocksFar := True;
z := 1;
for i:=1 to NB do
for k := 1 to NB do
if (len2(Xs[0,i],Ys[0,i],Xs[0,k],Ys[0,k])< MaxR)
and not BlocksUnited(i,k)
{ and not (NumberBlock[k]=NumberBlock[i]) }then
begin
BlocksFar:=False;
NotFarNums[1,z]:=k;
NotFarNums[2,z]:=i;
Hmuw[k]:=Hmuw[k]+1;
Hmuw[i]:=Hmuw[k];
{Hmuw[i]:=Hmuw[i]+1;}
z:=z+1;
p:=1;
end;
if BlocksFar = False then
for i:=1 to z-1 do
{Правильно ниже}
begin
Vx[NotFarNums[1,i]]:=
(Hmuw[NotFarNums[1,i]]*Vx[NotFarNums[1,i]] +
Hmuw[NotFarNums[2,i]]*Vx[NotFarNums[2,i]]) div
(Hmuw[NotFarNums[1,i]]+Hmuw[NotFarNums[2,i]]);
Vx[NotFarNums[2,i]]:=Vx[NotFarNums[1,i]];
Vy[NotFarNums[1,i]]:=
(Hmuw[NotFarNums[1,i]] * Vy[NotFarNums[1,i]] +
Hmuw[NotFarNums[2,i]] * Vy[NotFarNums[2,i]]) div
(Hmuw[NotFarNums[1,i]] + Hmuw[NotFarNums[2,i]]);
Vy[NotFarNums[2,i]] := Vy[NotFarNums[1,i]];
Vvec := len1(Vx[NotFarNums[1,i]], Vy[NotFarNums[1,i]]);
Vvec := len1(Vx[NotFarNums[2,i]], Vy[NotFarNums[2,i]]) + Vvec;
q := Round(Vvec/MaxVvec * NC);
Color[NotFarNums[1,i]] := BlockColors[B(q)];
Color[NotFarNums[2,i]] := Color[NotFarNums[1,i]];
{} NumberBlock[NotFarNums[2,i]] :=NumberBlock[NotFarNums[1,i]];
{+++++++++++++}
UnitedBlocks[NotFarNums[1,i], NotFarNums[2,i]] := true;
UnitedBlocks[NotFarNums[2,i], NotFarNums[1,i]] := true;
for j := 1 to NB do
begin
if BlocksUnited(j,NotFarNums[1,i]) then
{} NumberBlock[j] := NumberBlock[NotFarNums[1,i]];
Unitedblocks[j,NotFarNums[1,i]]:=false;
Unitedblocks[NotFarNums[1,i],j]:=false;
end;
for j := 1 to NB do
begin
if BlocksUnited(NotFarNums[2,i],j) then
NumberBlock[j] := NumberBlock[NotFarNums[1,i]];
Unitedblocks[j,NotFarNums[2,i]]:=false;
Unitedblocks[NotFarNums[2,i],j]:=false;
end;
for r :=1 to NB do
for j:= 1 to NB do
if NumberBlock[r]=NumberBlock[j] then
begin
UnitedBlocks[r,j]:=true;
UnitedBlocks[j,r]:=true;
end;
end;{for i:=1 to z-1...}
for r :=1 to NB do
for j:= 1 to NB do
if BlocksUnited(r, j) then
begin
NumberBlock[r]:= abr(r);
NumberBlock[j]:= NumberBlock[r];
end;
end;{if select = 1 ...}
{======================================================}
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;
if (Select=1) and not BlocksFar then Delay(Pause - 150)
else Delay(Pause - 150);
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:=2*(GMX shr 1 - X0)/len2(X0,Y0,GMX shr 1, GMY shr 1) ;
Yv:=2*(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) shr 2 do
begin
PutBlock(i);
Xs[0,i]:= Xs[1,i];
Ys[0,i]:= Ys[1,i];
Xs[1,i]:=Round(j*Xv) shl 1+X0;
Ys[1,i]:=Round(j*Yv) shl 1+Y0;
Delay(Pause shr 5);
DelBlock(i);
end;
end;
DifColorBoom;
NewVelCoo;
for i := 1 to Nh div 10 do Play;
Select := 1;
end;
{-----d--------}
Procedure Run1;
begin
While not AllBlocksUnited do Play;
Select:=2
end;
{---------}
Procedure Run2;
var
i:Integer;
begin
for i := 1 to Nh do Play;
Select := 3;
end;
{!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
begin {Основная программа}
Init;
While not KeyPressed do
case Select of
1:Run1;
2:Run2;
3:Boom;
end;
Done;
end.
< -->