05-14-2024, 03:00 PM
Boid Watching
Code: (Select All)
Option _Explicit
_Title "Boids Remake 2022-03" ' b+ 2022-03-19
' from JB Boids Restart #6 Wings b+ 2022-03-19
Randomize Timer
Const xmax = 1200, ymax = 700, pi = _Pi, nb = 100, no = 7, np = 3
Const green = _RGB32(0, 160, 0), blue = _RGB32(0, 0, 160), black = _RGB32(0, 0, 0), brown = _RGB32(100, 80, 40)
Dim As Long done, headmode, centermode, i, j, testx, testy, iter
Dim As Single hf, cf, t1, s, ao, dist
Dim As Single px(np), py(np), pa(np) ' Predator radius is const 10 or so, twice a bird at least
Dim As Single ox(no), oy(no), ord(no) ' obstacle x, y, radius
Dim As Single bx(nb), by(nb), ba(nb), da(nb, nb) ' new da = distance array
Dim As Long pw(np), bw(nb)
headmode = 1 ' on / off
hf = .3 ' % of 100 pixels distance .1 = 10
centermode = 0 ' on / off
cf = .2 'centering factor how strong a pull from 0 to 1 .01 is week .1 pretty strong!
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20
For i = 1 To no ' in array for redraw
ox(i) = rand(90, xmax - 90): oy(i) = rand(90, ymax - 90): ord(i) = rand(25, 90)
Next
For i = 1 To nb
testAgain: ' don't start a bird inside an obstacle
testx = rand(20, xmax - 20) ' start random screen x, y away from borders
testy = rand(20, ymax - 20)
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain
Wend
j = 0
While j < i - 1 'no bird crowds please note get strange results with For loop
j = j + 1
If distance(testx, testy, bx(j), by(j)) < 15 Then GoTo testAgain
Wend
bx(i) = testx: by(i) = testy: ba(i) = 2 * pi * Rnd: bw(i) = Int(3 * Rnd) ' random headings
Next
For i = 1 To np ' might be smarter to pack the smaller after the larger, ie do predators before birds
testAgain2: ' don't start a predator inside an obstacle
testx = rand(40, xmax - 40) ' start random screen x, y away from borders
testy = rand(40, ymax - 40)
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain2
Wend
j = 0
While j < nb ' give birds some space from predators too
j = j + 1
If distance(testx, testy, bx(j), by(j)) < 30 Then GoTo testAgain2
Wend
px(i) = testx: py(i) = testy: pa(i) = 2 * pi * Rnd: pw(i) = Int(5 * Rnd)
Next
t1 = Timer(.001)
While _KeyDown(27) = 0
Color , green
Cls
For i = 1 To no
fcirc ox(i), oy(i), ord(i), brown
Next
For i = 1 To nb - 1 ' find all the distances between birds
For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
da(i, j) = distance(bx(i), by(i), bx(j), by(j))
da(j, i) = da(i, j) ' symetric relationship
Next
Next
For i = 1 To np ' Predators are just like a birds
pw(i) = (1 + pw(i)) Mod 5 ' flapper wings or not
DrawBird px(i), py(i), 15, pa(i), pw(i), blue
s = Rnd * 4 + 3 ' get some bird separation here?
px(i) = px(i) + s * Cos(pa(i)): py(i) = py(i) + s * Sin(pa(i))
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(px(i), py(i), ox(j), oy(j)) < ord(j) + 23 Then
ao = _Atan2(oy(j) - py(i), ox(j) - px(i))
pa(i) = AngleAve(pa(i), ao - pi)
End If
Wend
' JB&LB have better Mod function! tsh73 pointed it to me
px(i) = Mod2(px(i) + xmax, xmax)
py(i) = Mod2(py(i) + ymax, ymax)
' except predators don't flock
Next
For i = 1 To nb 'draw then update positions of birds
' draw current
bw(i) = (bw(i) + 1) Mod 4 ' flapper wings or not
DrawBird bx(i), by(i), 8, ba(i), bw(i), black
s = rand(3, 7) ' get some bird separation here?
bx(i) = bx(i) + s * Cos(ba(i)): by(i) = by(i) + s * Sin(ba(i))
j = 0
While j < no ' note get strange results with For loop
j = j + 1
If distance(bx(i), by(i), ox(j), oy(j)) < ord(j) + 13 Then
ao = _Atan2(oy(j) - by(i), ox(j) - bx(i))
ba(i) = AngleAve(ba(i), ao - pi)
End If
Wend
j = 0
While j < np
j = j + 1
If distance(bx(i), by(i), px(j), py(j)) < 65 Then
ao = _Atan2(py(j) - by(i), px(j) - bx(i))
ba(i) = AngleAve(ba(i), ao - pi)
End If
Wend
' JB&LB have better Mod function! tsh73 pointed it to me
bx(i) = Mod2(bx(i) + xmax, xmax)
by(i) = Mod2(by(i) + ymax, ymax)
For j = i + 1 To nb
dist = da(i, j)
If dist < 50 Then ' birds are close enough to influence each other by visual
'sway the neighbors headings towards each other
If headmode And Rnd < hf Then
ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
End If
End If
If dist > 30 And dist < 100 Then
'stickiness stay close to neighbors, close distance between
If centermode And Rnd < cf Then
bx(i) = bx(i) - cf / 10 * (bx(i) - bx(j))
bx(j) = bx(j) + cf / 10 * (bx(i) - bx(j))
by(i) = by(i) - cf / 10 * (by(i) - by(j))
by(j) = by(j) + cf / 10 * (by(i) - by(j))
End If
End If
If dist < 20 Then ' too close!!!
bx(i) = bx(i) + .1 * (bx(i) - bx(j))
bx(j) = bx(j) - .1 * (bx(i) - bx(j))
by(i) = by(i) + .1 * (by(i) - by(j))
by(j) = by(j) - .1 * (by(i) - by(j))
End If
Next 'j
Next ' i
_Display
_Limit 10
Wend
Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
rand& = Int((hi - lo + 1) * Rnd + lo)
End Function
Function distance (x1, y1, x2, y2) ' default single OK
distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
End Function
Function AngleAve (ra1, ra2) ' default single OK
Dim twoPi, ray1, ray2, rtn
twoPi = pi * 2
ray1 = Mod2(ra1 + twoPi, twoPi)
ray2 = Mod2(ra2 + twoPi, twoPi)
rtn = (ray1 + ray2) / 2
If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
AngleAve = rtn
End Function
Sub DrawBird (xc, yc, rr, ra, wings As Integer, c As _Unsigned Long)
Dim x1, y1, x2, y2, x3, y3
x1 = xc + rr * Cos(ra)
y1 = yc + rr * Sin(ra)
x2 = xc + rr * Cos(ra - .83 * pi)
y2 = yc + rr * Sin(ra - .83 * pi)
x3 = xc + rr * Cos(ra + .83 * pi)
y3 = yc + rr * Sin(ra + .83 * pi)
ftri x1, y1, xc, yc, x2, y2, c
ftri x1, y1, xc, yc, x3, y3, c
If wings Then
x2 = xc + 2 * rr * Cos(ra - 1.57 * pi)
y2 = yc + 2 * rr * Sin(ra - 1.57 * pi)
x3 = xc + 2 * rr * Cos(ra + 1.57 * pi)
y3 = yc + 2 * rr * Sin(ra + 1.57 * pi)
ftri xc, yc, x2, y2, x3, y3, c
End If
End Sub
' this allows us to do floats including negative floats
Function Mod2# (n As Double, modulus As Double)
Dim rtn As Double
rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
If n < 0 Then rtn = -rtn
Mod2# = rtn
End Function
Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
b = b + ...