Code: Select all
type ball
x as single 'position x component
y as single 'position y component
dx as single 'velocity x component
dy as single 'velocity y component
col as uLong 'colour
as Long r,m 'radius, mass
end type
dim shared as any ptr row
dim shared as integer pitch
dim shared as integer xres,yres
#define incircle(cx,cy,r,mx,my,a) _
iif(a<=1,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a,a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r))
#define shade(c,n) rgb(Cptr(Ubyte Ptr,@c)[2]*n,Cptr(Ubyte Ptr,@c)[1]*n,Cptr(Ubyte Ptr,@c)[0]*n)
Function o(c As Ulong) As Ulong 'mono maker
Var v=.299*((c Shr 16)And 255)+.587*((c Shr 8)And 255)+.114*(c And 255)
Return Rgb(v,v,v)
End Function
function dist(b1 as ball,b2 as ball) as single
return sqr((b1.x-b2.x)^2 + (b1.y-b2.y)^2)
end function
function rainbow( x as single ) as ulong 'idea from bluatigro
static as double pi=4*atn(1)
#define rad(n) (pi/180)*(n)
dim as ulong r , g , b
r = sin( rad( x ) ) * 127 + 128
g = sin( rad( x - 120 ) ) * 127 + 128
b = sin( rad( x + 120 ) ) * 127 + 128
return rgb( r and 255 , g and 255 , b and 255 )
end function
sub _circle(b as ball) 'custom
#define onscreen x>=0 and x<xres and y>.0 and y<yres
#define putpixel(_x,_y,colour) *cptr(ulong ptr,row+ (_y)*pitch+ (_x) shl 2) =(colour)
dim as ulong tc
for x as long=b.x-b.r to b.x+b.r
for y as long=b.y-b.r to b.y+b.r
if incircle(b.x,b.y,b.r,x,y,1) andalso onscreen then
if incircle(512,768\2,400,x,y,.75) then tc=b.col else tc=o(b.col)
putpixel(x,y,tc)
end if
next
next
end sub
sub MoveAndDraw( b() as ball,byref e as Long)'get energy also
for n as Long=lbound(b) to ubound(b)
b(n).x+=b(n).dx:b(n).y+=b(n).dy
_circle(b(n))
e+=.5*b(n).m*(b(n).dx*b(n).dx + b(n).dy*b(n).dy)
next n
end sub
sub edges(b() as ball,xres as Long,yres as Long,byref status as Long ) 'get status also
for n as Long=lbound(b) to ubound(b)
if(b(n).x<b(n).r) then b(n).x=b(n).r: b(n).dx=-b(n).dx
if(b(n).x>xres-b(n).r )then b(n).x=xres-b(n).r: b(n).dx=-b(n).dx
if(b(n).y<b(n).r)then b(n).y=b(n).r:b(n).dy=-b(n).dy
if(b(n).y>yres-b(n).r)then b(n).y=yres-b(n).r:b(n).dy=-b(n).dy
if b(n).x<0 or b(n).x>xres then status=0
if b(n).y<0 or b(n).y>yres then status=0
next n
end sub
Function DetectBallCollisions( B1 As ball,B2 As ball) As single 'avoid using sqr if they are well seperated
Dim As Long xdiff = B2.x-B1.x
Dim As Long ydiff = B2.y-B1.y
If Abs(xdiff) > (B2.r+B1.r) Then Return 0
If Abs(ydiff) > (B2.r+B1.r) Then Return 0
var L=Sqr(xdiff*xdiff+ydiff*ydiff)
If L<=(B2.r+B1.r) Then Function=L else Function=0
End Function
sub BallCollisions(b() as ball)
for n1 as Long=lbound(b) to ubound(b)-1
for n2 as Long=n1+1 to ubound(b)
dim as single L= DetectBallCollisions(b(n1),b(n2))
if L then
dim as single impulsex=(b(n1).x-b(n2).x)/L
dim as single impulsey=(b(n1).y-b(n2).y)/L
'set one ball to nearest non overlap position
b(n1).x=b(n2).x+(b(n2).r+b(n1).r)*impulsex
b(n1).y=b(n2).y+(b(n2).r+b(n1).r)*impulsey
dim as single impactx=b(n1).dx-b(n2).dx
dim as single impacty=b(n1).dy-b(n2).dy
dim as single dot=impactx*impulsex+impacty*impulsey
dim as single mn2=b(n1).m/(b(n1).m+b(n2).m),mn1=b(n2).m/(b(n1).m+b(n2).m)
b(n1).dx-=dot*impulsex*2*mn1
b(n1).dy-=dot*impulsey*2*mn1
b(n2).dx+=dot*impulsex*2*mn2
b(n2).dy+=dot*impulsey*2*mn2
end if
next n2
next n1
end sub
'steady framerate
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As double timervalue,lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
sub Start()
dim as ball b(0 to 10)
dim as Long fps,energy,status=1
screen 20,32
row=screenptr
screeninfo xres,yres,,,pitch
dim as any ptr i=imagecreate(xres,yres)
dim as ball p(15)
for n as long=0 to ubound(p)
p(n)=type(rnd*xres,rnd*yres)
next
for y as long=0 to yres
for x as long=0 to xres
if incircle(512,768\2,400,x,y,.75) then
pset i,(x,y),rainbow(x-y)
else
var clr=o(rainbow(x-y))
pset i,(x,y),shade(clr,.75)
end if
next
next
randomize 3
for n as Long=lbound(b) to ubound(b)
with b(n)
.x=xres/2
.y=yres/2
.dx=rnd*3-rnd*3
.dy=rnd*3-rnd*3
select case n
case 0:.col=rgb(0,55,55)
case 1:.col=rgb(200,0,0)
case 2:.col=rgb(0,200,0)
case 3:.col=rgb(0,0,200)
case 4:.col=rgb(255,215,0)
case 5:.col=rgb(0,200,200)
case 6:.col=rgb(0,50,255)
case 7:.col=rgb(255,100,0)
case 8:.col=rgb(255,0,255)
case else:.col=rgb(rnd*255,rnd*255,rnd*255)
end select
.r=20+rnd*40
.m=.r^2
end with
next
while 1
energy=0
edges(b(),xres,yres,status)
BallCollisions(b())
screenlock
cls
put(0,0),i,pset
MoveAndDraw(b(),energy)
draw string(50, 10), " Press escape key to end",0
draw string(50, 55), "framerate " &fps ,0
draw string (50,100),"System energy " &energy,0
draw string (50,145),"System stauus " & iif(1,"OK","Leaks"),0
screenunlock
sleep regulate(65, fps)
if inkey=chr(27) then exit while
wend
imagedestroy i
end sub
Start
sleep