program balls;
uses windows;
const
DC_BRUSH=18;
DC_PEN=19;
Type V2=object
x,y,dx,dy:single;
radius:integer;
c:longword;
procedure SetF(xx,yy,ddx,ddy:single;rradius:integer;cc:longword);
End;
procedure V2.SetF(xx,yy,ddx,ddy:single;rradius:integer;cc:longword);
begin
x:=xx;y:=yy;dx:=ddx;dy:=ddy;radius:=rradius;c:=cc;
end;
type aov=array[1..5] of v2;
function SetDCBrushColor(p:hdc;colour:COLORREF): COLORREF; stdcall external 'gdi32.dll' name 'SetDCBrushColor';
function SetDCPenColor(p:hdc;colour:COLORREF): COLORREF; stdcall external 'gdi32.dll' name 'SetDCPenColor';
Function settimer(n:integer=1):integer;stdcall external 'winmm.dll' name 'timeBeginPeriod';
Function freetimer(n:integer=1):integer;stdcall external 'winmm.dll' name 'timeEndPeriod';
procedure ClearScreen(h:hdc);
var
colour:longword;
begin
colour:=rgb(100,100,100);
SetDCBrushColor(h,colour);
SetDCPenColor(h,colour);
rectangle(h,0,0,810,630);
end;
procedure MoveAndDraw(wh:hdc;var b:aov);
var i,r:integer;
begin
for i:=low(b) to high(b) do
begin
r:=b[i].radius;
b[i].x:=b[i].x+b[i].dx;
b[i].y:=b[i].y+b[i].dy;
SetDCBrushColor(wh,b[i].c);
SetDCPenColor(wh,b[i].c);
ellipse(wh,trunc(b[i].x-r),trunc(b[i].y-r),trunc(b[i].x+r),trunc(b[i].y+r));
end;
end;
procedure HandleEdges(var b:aov);
var i,r:integer;
begin
for i:=low(b) to high(b) do
begin
r:=b[i].radius;
if (b[i].x<r) then begin b[i].x:=r;b[i].dx:=-b[i].dx; end;
if (b[i].x>(800-r)) then begin b[i].x:=800-r;b[i].dx:=-b[i].dx; end;
if (b[i].y<r) then begin b[i].y:=r;b[i].dy:=-b[i].dy; end;
if (b[i].y>(600-r)) then begin b[i].y:=600-r;b[i].dy:=-b[i].dy; end
end;
end;
function HandleBallCollisions(Var b:aov):boolean ;
Var
L,impulsex,impulsey,dot,impactx,impacty: single;
ma,mb,f1,f2: single;
n1,n2: Integer;
flag:boolean=false;
Begin
For n1 :=low(b) To high(b) -1 Do
Begin
For n2 :=n1+1 To high(b) Do
Begin
L := Sqrt( (b[n1].x-b[n2].x)*(b[n1].x-b[n2].x) + (b[n1].y-b[n2].y)*(b[n1].y-b[n2].y));
If L< (b[n1].radius+b[n2].radius) Then
Begin
flag:=true;
impulsex := (b[n1].x-b[n2].x)/L ;
impulsey := (b[n1].y-b[n2].y)/L ;
// in case of large overlap (non analogue motion)
b[n1].x := b[n2].x+(b[n1].radius+b[n2].radius)*impulsex ;
b[n1].y := b[n2].y+(b[n1].radius+b[n2].radius)*impulsey ;
impactx := b[n1].dx-b[n2].dx ;
impacty := b[n1].dy-b[n2].dy ;
dot := impactx*impulsex+impacty*impulsey ;
ma := b[n1].radius;
mb := b[n2].radius;
ma := ma*ma; // weigh by area (radius squared)
mb := mb*mb;
f1 := 2*mb/(ma+mb); // ball weight factors
f2 := 2*ma/(ma+mb);
b[n1].dx:= b[n1].dx-dot*impulsex *f1;
b[n1].dy:= b[n1].dy-dot*impulsey *f1;
b[n2].dx:=b[n2].dx+ dot*impulsex *f2 ;
b[n2].dy:= b[n2].dy+dot*impulsey *f2 ;
End;
End; // n2
End; // n1
exit(flag);
End;
Var
p:hwnd;
wh:hdc;
b:aov;
emsg:msg;
begin
b[1].setf(100,100,1.75,1.75,35,rgb(255,100,0));
b[2].setf(300,300,0,0,35,rgb(0,255,0));
b[3].setf(400,400,0,0,40,rgb(0,0,255));
b[4].setf(500,500,0,0,30,rgb(0,100,255));
b[5].setf(200,200,0,0,20,rgb(200,100,255));
p:=CreateWindowEx( WS_EX_TOPMOST Or WS_EX_TOOLWINDOW,'#32770','Press ESCAPE key to finish . . .',(WS_OVERLAPPEDWINDOW Or WS_SYSMENU) - (WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME) Or WS_VISIBLE,200,200,810,630,0,0,0,nil);
wh:=GetDC(p);
SelectObject(wh,GetStockObject(DC_BRUSH));
SelectObject(wh,GetStockObject(DC_PEN));
ClearScreen(wh);
freeconsole();
while true do
begin
while(int64(PeekMessage(@eMsg,0, 0, 0, PM_REMOVE)) > 0) do
begin
TranslateMessage (@eMsg);
DispatchMessage (@eMsg);
if boolean(GetAsyncKeyState($1B)) then exit;
end;
ClearScreen(wh);
MoveAndDraw(wh,b);
HandleEdges(b);
HandleBallCollisions(b);
settimer();
sleep(7);
freetimer();
end;
end.
Recent
