Code: Select all
' fish Aquarium by neil improvements by dodicat
' fish graphics by badidea and dodicat
Screenres 800,600,32,1
Randomize
Setmouse 0,0,0
Const W As Integer = 800
Const H As Integer = 600
Type Fish
X As Single
Y As Single
DX As Single
DY As Single
C As Ulong
r As Long=15
m As Long=15*15
End Type
Dim Shared Fsh(1 To 25) As Fish
Dim Shared NumFish As Integer
Sub InitializeFish()
NumFish = 25 ' Number of fish
For i As Integer = 1 To NumFish
Fsh(i).X = Rnd * W
Fsh(i).Y = Rnd * H
Fsh(i).DX = Rnd * 2 - 1
Fsh(i).DY = Rnd * 2 - 1
Fsh(i).C = Rgb(Rnd * 255, Rnd * 255, Rnd * 255)
Next i
End Sub
Function DetectFishCollisions( B1 As Fish,B2 As Fish) As Single 'save some cpu 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 Check_FishCollisions(b() As Fish)
For n1 As Long=Lbound(b) To Ubound(b)-1
For n2 As Long=n1+1 To Ubound(b)
Dim As Single L= DetectFishCollisions(b(n1),b(n2))
If L Then
Dim As Single impulsex=(b(n1).x-b(n2).x)
Dim As Single impulsey=(b(n1).y-b(n2).y)
Dim As Single ln=Sqr(impulsex*impulsex+impulsey*impulsey)
impulsex/=ln'normalize the impulse
impulsey/=ln
'set one Fish 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
'handle mass
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
'======= collisionds done =====
End If
Next n2
Next n1
End Sub
Sub MoveFish()
For i As Integer = 1 To NumFish
Fsh(i).X = Fsh(i).X + Fsh(i).DX
Fsh(i).Y = Fsh(i).Y + Fsh(i).DY
If Fsh(i).x<20 Then fsh(i).x=20: Fsh(i).DX = -Fsh(i).DX
If Fsh(i).x>w-20 Then Fsh(i).x=w-20:Fsh(i).DX = -Fsh(i).DX
If Fsh(i).Y < 20 Then Fsh(i).Y=20: Fsh(i).DY = -Fsh(i).DY
If Fsh(i).Y > H -20 Then Fsh(i).Y=H-20:Fsh(i).DY = -Fsh(i).DY
Next i
End Sub
Sub DrawOneFish(i As Integer) ' i = fish index
With Fsh(i)
Circle(.X, .Y + 5), 12, .C, 3.1416 * 0.15, 3.1416 * 0.85
Circle(.X, .Y - 5), 12, .C, 3.1416 * 1.15, 3.1416 * 1.85
If int(.DX) > 0 Then
Line(.X - 10, .Y)- Step(-10,+5), .C
Line(.X - 10, .Y)- Step(-10,-5), .C
Line(.X - 20, .Y - 5)- Step(0,+10), .C
Elseif int(.DX) < 0 Then
Line(.X + 10, .Y)- Step(+10,+5), .C
Line(.X + 10, .Y)- Step(+10,-5), .C
Line(.X + 20, .Y - 5)- Step(0,+10), .C
Else
'weird fish
Circle(.X - 3, .Y - 1), 2, .C
Circle(.X + 3, .Y - 1), 2, .C
End If
End With
End Sub
Function DrawAllFish() As Single
Dim As Single e
Screenlock
Cls
For i As Integer = 1 To NumFish
e+=(Fsh(i).dx*Fsh(i).dx + Fsh(i).dy*Fsh(i).dy)
DrawOneFish(i)
Next i
Screenunlock
Return e
End Function
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,lastsleeptime,t3,frames
Var t=Timer
frames+=1
If (t-t3)>=1 Then t3=t:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
Sub Start()
Dim As Long fps
InitializeFish()
Do
MoveFish()
Check_FishCollisions(fsh())
Var ke= DrawAllFish()
Windowtitle "Runaway check " & ke & ","& " fps= " & fps
Sleep regulate (60,fps)
Loop Until Inkey() <> ""
End Sub
Start