program balls;
{$mode delphi}
uses windows,sysutils;
const
DC_BRUSH=18;
DC_PEN=19;
xres=1024;
yres=768;
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..9] 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:longword=1):MMRESULT;stdcall external 'winmm.dll' name 'timeBeginPeriod';
Function freetimer(n:longword=1):MMRESULT;stdcall external 'winmm.dll' name 'timeEndPeriod';
procedure ClearScreen(h:hdc);
var
colour:longword;
begin
colour:=rgb(55,255,255);
SetDCBrushColor(h,colour);
SetDCPenColor(h,colour);
rectangle(h,0,0,xres,yres);
end;
procedure MoveAndDraw(Memory:hdc;GDIScreen:hdc;var b:aov;var energy:single);
var i,r:integer;
begin
energy:=0;
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(Memory,b[i].c);
SetDCPenColor(Memory,b[i].c);
ellipse(Memory,trunc(b[i].x-r),trunc(b[i].y-r),trunc(b[i].x+r),trunc(b[i].y+r));
energy:=energy+ 0.5*(b[i].radius*b[i].radius)*(b[i].dx*b[i].dx + b[i].dy*b[i].dy);
end;
BitBlt(GDIScreen, 0, 0, xres, yres,Memory, 0, 0,SRCCOPY);
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>(xres-r)) then begin b[i].x:=xres-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>(yres-r-25)) then begin b[i].y:=yres-r-25;b[i].dy:=-b[i].dy; end
end;
end;
function DetectBallCollisions(b1:V2;b2:V2):single;
var
xdiff,ydiff,L:single;
begin
xdiff:=b2.x-b1.x;
ydiff:=b2.y-b1.y;
If Abs(xdiff) > (b2.radius+b1.radius) Then exit(0);
If Abs(ydiff) > (b2.radius+b1.radius) Then exit(0);
L:=Sqrt(xdiff*xdiff+ydiff*ydiff);
If (L<=(b2.radius+b1.radius)) Then exit(L) else exit(0);
End;
function HandleBallCollisions(Var b:aov):boolean ;
Var
L,impulsex,impulsey,dot,impactx,impacty: single;
ma,mb,f1,f2,ln: 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:=DetectBallCollisions(b[n1],b[n2]);
if (L<>0) then
Begin
flag:=true;
impulsex := (b[n1].x-b[n2].x) ;
impulsey := (b[n1].y-b[n2].y) ;
ln:=Sqrt(impulsex*impulsex+impulsey*impulsey);
impulsex:=impulsex/ln; // normalize impulse
impulsey:=impulsey/ln;
// 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;
Function Regulate(const MyFps:int32;var fps:int32):int32;
const
timervalue:double =0;_lastsleeptime:double=0;t3:double=0;frames:double=0;
Var t,sleeptime:double;
begin
t:=gettickcount64/1000;
frames:=frames+1;
If (t-t3)>=1.0 Then begin t3:=t;fps:=trunc(frames);frames:=0; end;
sleeptime:=(_lastsleeptime+((1/myfps)-(t)+timervalue)*1000);
If (sleeptime<1) Then sleeptime:=1;
_lastsleeptime:=sleeptime;
timervalue:=t;
exit( trunc(sleeptime));
End;
procedure setfontsize(h:hdc;size:int32;style:ansistring);
begin
SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,pchar(style)));
end;
procedure setfontcolours(h:hdc;text:longword;background:longword);
begin
SetTextColor(h,text);
SetBkColor(h,background);
end;
procedure text(h:hdc;x:int32;y:int32;s:ansistring);
var
L:int32;
begin
l:=length(s);
textouta(h,x,y,pchar(s),L);
end;
Var
p:hwnd;
b:aov;
emsg:msg;
fps:int32=0;
Memhdc,Membitmap,wh:hdc;
myfps:integer=60;
energy:single=0;
j:integer;
begin
b[1].setf(100,100,2.75,2.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));
b[6].setf(200,300,0,0,35,rgb(255,255,255));
b[7].setf(600,300,0,0,27,rgb(255,100,0));
b[8].setf(600,600,0,0,25,rgb(255,255,0));
b[9].setf(650,650,0,0,23,rgb(255,55,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,xres,yres,0,0,0,nil);
wh:=GetDC(p);
Memhdc := CreateCompatibleDC(wh);
Membitmap := CreateCompatibleBitmap(wh, xres, yres);// 810, 630
SelectObject(Memhdc,GetStockObject(DC_BRUSH));
SelectObject(Memhdc,GetStockObject(DC_PEN));
SelectObject(Memhdc, Membitmap);
setfontsize(Memhdc,20,'courier new');
setfontcolours(Memhdc,rgb(0,0,200),rgb(55,255,255));
freeconsole();
while true do
begin
while(int64(PeekMessage(@eMsg,0, 0, 0, PM_REMOVE)) > 0) do
begin
TranslateMessage (@eMsg);
DispatchMessage (@eMsg);
if boolean(GetAsyncKeyState(VK_DOWN)) then myfps:=myfps-1;
if boolean(GetAsyncKeyState(VK_UP)) then myfps:=myfps+1;
if boolean(GetAsyncKeyState(VK_LEFT)) then
begin
for j:=low(b) to high(b) do
if b[j].dx>=0 then b[j].dx:=b[j].dx-0.01 else b[j].dx:=b[j].dx+0.01
end;
if boolean(GetAsyncKeyState(VK_RIGHT)) then
begin
for j:=low(b) to high(b) do
if b[j].dx>=0 then b[j].dx:=b[j].dx+0.01 else b[j].dx:=b[j].dx-0.01
end;
if boolean(GetAsyncKeyState($1B)) then
begin
DeleteObject(Membitmap);
DeleteDC (Memhdc);
exit;
end;
if myfps<5 then myfps:=5;
end;
HandleEdges(b);
HandleBallCollisions(b);
ClearScreen(Memhdc);
text(Memhdc,10,10,'Use up/down arrowkeys to adjust framerate');
text(Memhdc,10,30,'Use left/right arrowkeys to adjust energy per frame');
text(Memhdc,10,50,'fps required = '+(IntToStr(myfps)));
text(Memhdc,10,70,' fps = '+(IntToStr(fps)));
text(Memhdc,10,90,'energy per frame = '+(FloatToStr((energy))));
MoveAndDraw(Memhdc,wh,b,energy);
settimer();
sleep(regulate(myfps,fps));
freetimer();
end;
end.
Recent
