М | Тема нарушает Правила Форума (п.4) и правила раздела Задачи (п.1). Просьба исправить - или она будет закрыта. |
program Billiard;
{ Моделируем упругие столкновение шаров }
uses
Graph, Crt;
const
BgiPath = 'd:\pascal\bgi';
Nn = 40; { число шаров }
r = 12; { радиус шара }
d = 2*r; { диаметр шара }
d_2 = d*d; { квадрат диаметра }
doubled_2 = 4*d_2; { квадрат двойного диаметра }
Vmax = 0.2; { амплитуда скорости }
tau = r/3/Vmax; { шаг по времени }
TimeDelay = 0; { задержка по времени }
type
TData = Extended;
TBall = record
X, Y: TData;
Xold, Yold: TData;
Vx, Vy: TData;
dVx, dVy: TData;
Color : Integer;
end;
var
Balls : array [1..Nn] of TBall;
N : Integer; { реальное число шаров }
procedure GraphBegin;
var
Gd, Gm: Integer;
Begin;
Gd:= Detect;
InitGraph (Gd, Gm, BgiPath);
End; { GraphBegin }
procedure DrawBalls;
{ стираем/рисуем шары }
var
i : Integer;
Begin
Rectangle (0,0, GetMaxX, GetMaxY);
for i:= 1 to N do
with Balls[i] do begin
SetColor(Black);
Circle(Round(Xold),Round(Yold),r);
SetColor(Color); Circle(Round(X),Round(Y), r);
end;
End; { DrawBalls }
procedure Swap;
{ ротация координат для обеспечения движения }
var i : Integer;
Begin
for i:= 1 to N do
with Balls[i] do begin
Xold:= X; Yold:= Y;
end;
End; { Swap }
procedure InitBalls;
{ Определяем начальное положения и скорости шаров }
var
Nw, Nh, Num, H, k : Integer;
Begin
Randomize;
{ определяем максимальное количество шаров }
Nw:= GetMaxX div (2*d); { по горизонтали }
Nh:= GetMaxY div (2*d); { по вертикали }
{ корректируем заданное число шаров }
if Nn >= Nw*Nh then N:=Nw*Nh else N:= Nn;
Num:= 1; { количество размещенных шаров }
H:= 2*r; { начальная y-координата }
while Num <= N do begin
with Balls[Num] do begin
k:= Num mod Nw;
if k = 0 then Xold:= 2*r+4*r*(Nw-1)
else Xold:= 2*r+4*r*(k-1);
Yold:= H;
Vx:= -Vmax+Random*2*Vmax;
Vy:= -Vmax+Random*2*Vmax;
dVx:= 0;
dVy:= 0;
Color:= 1+Random (15);
end;
if k = 0 then Inc (H, 4*r);
Inc (Num);
end;
End; { InitBalls }
procedure BlowBetween;
{ отслеживаем удар }
var
i, j: Integer;
X0, Y0, Vx0, Vy0 : TData;
r0_2, V0_2, S, Discr, t : TData;
Begin
{ для каждой пары шаров }
for i:=1 to N do
for j:=i+1 to N do begin
{ Переходим в систему отсчета, связанную с i-ым
шаром }
X0:=Balls[j].X-Balls[i].X;
Y0:=Balls[j].Y-Balls[i].Y;
Vx0:=Balls[j].Vx-Balls[i].Vx;
Vy0:=Balls[j].Vy-Balls[i].Vy;
r0_2:=Sqr(X0)+Sqr(Y0);
if r0_2 <= doubled_2 then begin
{ проверяем направление движения }
S:=X0*Vx0+Y0*Vy0;
if S < 0 then begin
{ столкновение произойдет }
V0_2:=Sqr(Vx0)+Sqr(Vy0);
Discr:=Sqr(S)-(r0_2-d_2)*V0_2;
if Discr >= 0 then begin
{ две частицы находятся
недалеко друг от друга }
t:=(-S-sqrt(Discr))/V0_2;
if t < tau then begin
{ столкновение происходит }
S:=S/r0_2;
with Balls[i] do begin
dVx:=X0*S; dVy:=Y0*S;
end;
with Balls[j] do begin
dVx:=-Balls[i].dVx;
dVy:=-Balls[i].dVy;
end;
end;
end;
end;
end;
end;
End; { BlowBetween }
procedure BlowBounds;
{ соударения со стенками }
var i : Integer;
Begin
for i:= 1 to N do
with Balls [i] do begin
if X < r then begin
X:= r; Vx:=-Vx;
end
else if X > GetMaxX-r then begin
X:= GetMaxX-r; Vx:=-Vx;
end;
if Y < r then begin
Y:= r; Vy:=-Vy;
end
else if Y > GetMaxY-r then begin
Y:=GetMaxY-r; Vy:=-Vy;
end;
end;
End; { BlowBounds }
procedure Move;
{ собственно обсчет движения }
var
i : Integer;
Begin
for i:= 1 to N do
with Balls [i] do begin
Vx:= Vx+dVx; Vy:= Vy+dVy;
X:= Xold+Vx*tau; Y:= Yold+Vy*tau;
dVx:=0; dVy:=0;
end;
End; { Move }
BEGIN
GraphBegin;
InitBalls;
repeat
Move;
BlowBetween;
BlowBounds;
DrawBalls;
Swap;
Delay (TimeDelay);
until KeyPressed;
END.
М | Тэпи!! Правила Форума, п.5, и правила раздела Задачи, п.2 Исправлено. Lapp |
program ball;
uses crt, graph;
const N=9;
r=40;
var
gd,gm,i,d,x1,x2,y1,y2:integer;
begin
gd:=detect;
initgraph(gd,gm,'C:\BP\bgi');
Randomize;
rectangle(0,0,GetMaxX,GetMaxY);
setcolor(white);
Line(320,0,320,480);
for i:=1 to N do
begin
x1:=random(238);
y1:=random(398);
x2:=random(238);
y2:=random(398);
SetColor(red);
circle(41+x1,41+y1,r);
setcolor(cyan);
circle(361+x2,41+y2,r);
end;
end.
procedure InitBalls;
var
i, j: integer;
isIntersect: boolean;
TX, TY: TData;
Begin
Randomize;
n := Nn div 2;
for i := 1 to n do
with Balls[ i ] do
begin
repeat
TX := random((GetMaxX div 2) - D) + r;
TY := random(GetMaxY - D + r);
isIntersect := False;
for j := 1 to i - 1 do
if sqrt(sqr(TX - Balls[j].X) + sqr(TY - Balls[j].Y)) < D then
begin
isIntersect := True; break;
end;
until not isIntersect;
XOld := TX; YOld := TY;
Color := Red;
Vx := 0; { -Vmax+Random*2*Vmax; }
Vy := 0; { -Vmax+Random*2*Vmax; }
dVx := 0;
dVy := 0;
end;
End; { InitBalls }