Good Luck followers, may the best team win.
Code: Select all
Type d2
As Single x,y,z
Dim As Single mw,ang
End Type
Type line3d
As d2 v1,v2
End Type
'globals
Dim shared As Integer xres,yres
Screenres 1000,700,32
Screeninfo xres,yres
Dim Shared As Any Pointer im
im=imagecreate(xres,yres)
Dim Shared As Uinteger array(xres+1,yres+1)
'_________________________
Operator + (v1 As d2,v2 As d2) As d2
Return Type<d2>(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z,v1.mw+v2.mw,v1.ang+v2.ang)
End Operator
Operator -(v1 As d2,v2 As d2) As d2
Return Type<d2>(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z,v1.mw-v2.mw)
End Operator
Operator *(f As Single,v1 As d2) As d2 'scalar*d2
Return Type<d2>(f*v1.x,f*v1.y,f*v1.z,f*v1.mw)
End Operator
Operator * (v1 As d2,v2 As d2) As Single 'dot product
Return v1.x*v2.x+v1.y*v2.y+v1.z+v2.z',v1.mw*v2.mw
End Operator
Operator ^ (v1 As d2,v2 As d2) As d2 'cross product
Return type<d2>(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Operator
#define dot *
#define cross ^
#define length(v) sqr(v.x*v.x+v.y*v.y+v.z*v.z)
#define normalize(v) Type<d2>(v.x/length(v),v.y/length(v),v.z/length(v))
#define rr(f,l) (Rnd*(l-f)+f)
'locals
Dim As Integer n=5
Dim balls(1 To n) As d2
Dim direction(1 To n) As d2
Dim collision(n) As Integer
Dim dt As Single
dim as d2 SA(1 to 54)
dim as d2 B(1 to 41)
dim as line3d linesegments(53)
dim as single cxSA,cySA,cxB,cyB
for n as integer=1 to 54
read SA(n).x
cxSA+=SA(n).x
next n
for n as integer=1 to 54
read SA(n).y
cySA+=SA(n).y
next n
for n as integer=1 to 41
read B(n).x
cxB+=B(n).x
next n
for n as integer=1 to 41
read B(n).y
cyB+=B(n).x
next n
cxSA=cxSA/54:cySA=cySA/54:
cxB=cxB/41:cyB=cyB/41:
for n as integer=1 to 53
linesegments(n).v1=type<d2>(SA(n).x,SA(n).y)
linesegments(n).v2=type<d2>(SA(n+1).x,SA(n+1).y)
next n
'================================================
Sub drawpolygon(p() As d2, col As Uinteger,im as any ptr=0)
Dim k As Integer=Ubound(p)+1
Dim As Integer index,nextindex
For n As Integer=1 To Ubound(p)
index=n Mod k:nextindex=(n+1) Mod k
If nextindex=0 Then nextindex=1
Line im,(p(index).x,p(index).y)-(p(nextindex).x,p(nextindex).y),col
Next
End Sub
Sub thickline(x1 As Double,_
y1 As Double,_
x2 As Double,_
y2 As Double,_
thickness As Double,_
colour As Uinteger,_
im As Any Pointer=0)
Dim p As Uinteger=Rgb(255, 255, 254)
If thickness<2 Then
Line im,(x1,y1)-(x2,y2),colour
Else
Dim As Double h=Sqr((x2-x1)^2+(y2-y1)^2):If h=0 Then h=1e-6
Dim As Double s= (y1-y2)/h ,c=(x2-x1)/h
For x As Integer=1 To 2
Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),p
Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),p
Line im,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
Paint im,((x1+x2)/2, (y1+y2)/2), p, p
p=colour
Next x
End If
End Sub
Sub make_background
Dim As Integer xres,yres
Screeninfo xres,yres
For y As Integer=0 To yres
Line im,(0,y)-(xres,y),rgb(0,0,50+y/8)
Next y
End Sub
Function segmentdistance(l As Line3d,p As d2,Byref ip As d2=type<d2>(0,0,0)) As Single
Dim As Single linelength=length((l.v1-l.v2))
Dim As Single dist= length((1/linelength)*((l.v1-l.v2) cross (p-l.v1)))
Dim As Single lpf=length((p-l.v2)),lps=length((p-l.v1))
If lps >= lpf Then
Var temp=Sqr(lps*lps-dist*dist)/linelength
If temp>=1 Then temp=1:dist=lpf
ip=l.v1+temp*(l.v2-l.v1)
Return dist
Else
Var temp=Sqr(lpf*lpf-dist*dist)/linelength
If temp>=1 Then temp=1:dist=lps
ip=l.v2+temp*(l.v1-l.v2)
return dist
End If
Return dist
End Function
Sub draw_balls(b As d2)
#macro rotate(pivotx,pivoty,px,py,a,scale)
var Newx=scale*(Cos(a*.0174533)*(px-pivotx)-Sin(a*.0174533)*(py-pivoty))+pivotx
var Newy=scale*(Sin(a*.0174533)*(px-pivotx)+Cos(a*.0174533)*(py-pivoty))+pivoty
#endmacro
#macro incircle(cx,cy,radius,x,y)
(cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#endmacro
If b.mw=0 Then b.mw=1
b.mw=Abs(b.mw)
Dim As Single dil
For x As Integer=b.x-40 To b.x+40
For y As Integer=b.y-40 To b.y+40
If incircle(b.x,b.y,40,x,y) Then
rotate(b.x,b.y,x,y,b.ang,dil)
var dist=Sqr((b.x-newx)*(b.x-newx)+(b.y-newy)*(b.y-newy))
dil=(b.mw+(.5-b.mw)*dist/(40*b.mw))
If incircle(b.x,b.y,(20*b.mw),newx,newy) Then
if x<=xres+1 andalso y<=yres+1 then
Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),array(Abs(x),Abs(y)),BF
end if
End If
End If
Next y
Next x
End Sub
Function framecounter() As Integer
Var t1=Timer,t2=t1
Static As Double t3,frames,answer
frames+=1
If (t2-t3)>=1 Then t3=t2:answer=frames:frames=0
Function= answer
End Function
Function Regulate(byval MyFps As Integer,Byref fps As Integer) As Integer
fps=framecounter()
Static As Double timervalue,lastsleeptime
Dim As Double delta
Var k=fps-myfps,i=1/myfps
If Abs(k)>1 Then delta+=i*Sgn(k)
Var sleeptime=lastsleeptime+(i-Timer+timervalue)*2000+delta
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
sub FullTime
type pt
as integer x,y
as uinteger col
end type
#macro rot(pivot,p,scale)
type<pt>(scale*(p.x-pivot.x)+pivot.x,_
scale*((p.y-pivot.y))+pivot.y)
#endmacro
dim as integer _x,_y,cnt
screeninfo _x,_y
dim as pt a((_x+1)*(_y+1))
for x as integer=0 to _x
for y as integer=0 to _y
a(cnt)=type<pt>(x,y,point(x,y))
cnt+=1
next y
next x
dim as pt piv=type<pt>(_x/2,_y/2)
for dil as single=1 to .05 step -.05
screenlock
cls
for n as integer = 0 to ubound(a)
var temp=rot(piv,a(n),dil)
pset(temp.x,temp.y),a(n).col
next n
screenunlock
next dil
sleep 1000
end
end sub
Sub tessilate(r As Single)
Dim As Integer xres,yres
Screeninfo xres,yres
For y As Integer=0 To yres
Line im,(0,y)-(xres,y),Rgb(200,y/3,0)
Next y
#macro _hex(p,r)
Scope
Dim flag As Byte
Dim As Single lastx,lasty
For z As Single=0 To 360 Step 360/6
var x=p.x+r*Cos(z*.0174533)
var y=p.y+r*Sin(z*.0174533)
If flag =1 Then thickline(lastx,lasty,x,y,2,Rgb(y/4,0,255-y/4),im)
lastx=x
lasty=y
flag=1
Next z
End Scope
#endmacro
Dim As d2 pt
Dim As Single x,y,z
Dim As Integer k=1
For x =0 To xres Step r+r/2
z=3*k*r-yres/2
For y =z To yres Step Sqr(3)*r
pt=Type<d2>(x,y)
_hex(pt,r)
Next y
k=-k
Next x
End Sub
'_________draw background to image then scan sub ________
Sub scan
Dim As Integer xres,yres
Screeninfo xres,yres
tessilate 12
Put(0,0),im,Pset
For x As Integer=0 To xres-1
For y As Integer=0 To yres-1
array(x,y)=Point(x,y)
Next y
Next x
End Sub
Dim As Single seperation,temp
For z As Integer=1 To n 'set positions
balls(z).x=rr(120,120)+seperation+300
balls(z).y=rr(150,150)+seperation
seperation=seperation+100
balls(z).mw=Sqr(z)
balls(z).ang=180
Next z
balls(n).mw=1.5
For z As Integer=1 To n 'set speeds
temp=rr(.5,1.5)
direction(z).x=temp
direction(z).y=temp
direction(z)=1.5*normalize(direction(z))
Next z
' _________Collision macros_____________________
Dim As d2 impulse,impact
#macro check_side_collisions()
For z2 As Integer=1 To n
#macro redirect()
If collision(z2)=0 Then
impact=-1*direction(z2)
dt=impact dot impulse
direction(z2)=direction(z2)+2*dt*impulse
collision(z2)=1
End If
#endmacro
If balls(z2).x<20*balls(z2).mw Then
impulse=Type<d2>(1,0)
redirect()
End If
If balls(z2).x>xres-20*balls(z2).mw Then
impulse=Type<d2>(-1,0)
redirect()
End If
If balls(z2).y>yres-20*balls(z2).mw Then
impulse=Type<d2>(0,-1)
redirect()
End If
If balls(z2).y<20*balls(z2).mw Then
impulse=Type<d2>(0,1)
redirect()
End If
Next z2
#endmacro
#macro check_ball_to_ball_collisions()
For xx As Integer=1 To n
For yy As Integer=1 To n
If xx<>yy Then
If collision(xx)=0 Orelse collision(yy)=0 Then
If length((balls(xx)-balls(yy)))<=20*balls(xx).mw+20*balls(yy).mw Then
impulse=normalize((balls(xx)-balls(yy)))
impact=direction(xx)-direction(yy)
dt=(impact dot impulse)
var mxx=balls(xx).mw*balls(xx).mw*balls(xx).mw 'the ball (weights)
var myy=balls(yy).mw*balls(yy).mw*balls(yy).mw
direction(xx)=direction(xx)-dt*(2*myy/(mxx+myy))*impulse
direction(yy)=direction(yy)+dt*(2*mxx/(myy+mxx))*impulse
collision(xx)=1
collision(yy)=1
balls(xx).ang=balls(xx).ang+length(impact)'dt'5
balls(yy).ang=balls(yy).ang-length(impact)'dt'5
End If
End If
End If
Next yy
Next xx
#endmacro
Dim As d2 impact2
#macro check_line_segment_collisions()
For z3 As Integer=1 To ubound(linesegments)
For z2 As Integer=1 To n
If collision(z2)=0 Then
If segmentdistance(linesegments(z3),balls(z2),impact2)<20*balls(z2).mw Then
impulse=normalize((balls(z2)-impact2))
impact=-1*direction(z2)
dt=impact dot impulse
direction(z2)=direction(z2)+2*dt*impulse
collision(z2)=1
End If
End If
Next z2
Next z3
#endmacro
#macro reset_stuff()
If callcount Mod 2*n=0 Then collision(z)=0
If balls(z).ang>180 Then balls(z).ang=balls(z).ang-.05
If balls(z).ang<180 Then balls(z).ang=balls(z).ang+.05
#endmacro
Dim callcount As Integer
scan
make_background
drawpolygon(SA(),rgb(200,0,0),im)
paint im,(cxSA,cySA),rgb(0,100,100),rgb(200,0,0)
drawpolygon(B(),rgb(200,200,0),im)
paint im,(cxB,cyB),rgb(0,100,0),rgb(200,200,0)
dim as integer fps
Do
callcount+=1
If callcount>1e6 Then callcount=0
check_line_segment_collisions()
check_side_collisions()
check_ball_to_ball_collisions()
Screenlock
Cls
Put(0,0),im
For z As Integer=1 To n
balls(z)=balls(z)+direction(z)
draw_balls(balls(z))
reset_stuff()
Next z
Screenunlock
sleep regulate(50,fps)
Loop Until Inkey=Chr(27)
FullTime
imagedestroy im
Sleep
DATA _
407, 419, 443, 467, 482, 486, 471, 462, 460, 450, 436, 422, 410, 404, 392, 378, 363, 370, 351, 341, 336, 334, 333, 328, 323, 338, 331, 310, 302, 301, 300, 303, 305, 304, 297, 280, 267, 258, 250, 245, 245, 255, 258, 268, 279, 294, 300, 312, 325, 338, 352, 363, 378, 394
DATA _
224, 237, 247, 256, 267, 284, 303, 314, 334, 354, 359, 365, 372, 388, 402, 420, 415, 430, 440, 450, 461, 472, 484, 497, 508, 520, 525, 515, 491, 465, 430, 406, 373, 343, 326, 316, 302, 286, 275, 268, 243, 218, 205, 183, 176, 168, 174, 179, 179, 179, 188, 195, 200, 205
DATA _
376, 392, 400, 409, 433, 450, 463, 476, 487, 485, 474, 466, 462, 454, 444, 431, 410, 407, 389, 370, 385, 380, 368, 371, 357, 351, 332, 328, 306, 294, 284, 299, 307, 301, 309, 326, 333, 342, 352, 353, 359
DATA _
224, 220, 213, 229, 244, 248, 254, 263, 275, 290, 300, 310, 326, 344, 356, 359, 369, 385, 403, 392, 372, 359, 349, 327, 319, 306, 295, 283, 289, 286, 273, 257, 241, 232, 227, 228, 218, 212, 207, 215, 224