Screen Savers

[PhilOfPerth]

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

Love the way those little swallows (?) avoid the blue hawk (?)