Clouds? for 100 Lines or Less Challenge

[bplus]

And bplus brings it at 98 LOC with no colons!

Code: (Select All)

_Title "2025-10-26 Clouds over Sphere" 'b+ mod with filled circles

Const xmax = 1000, ymax = 700, pi = _Pi, nb = 1500, blue = _RGB32(50, 30, 90)

Dim As Long i, j, clouds

Dim As Single bx(nb), by(nb), br(nb), ba(nb), da(nb, nb) ' new  da = distance array

Dim As _Unsigned Long bc(nb)

Screen _NewImage(xmax, ymax, 32)

For i = 1 To nb

    bx(i) = Rnd * xmax ' start random screen x, y away from borders

    by(i) = Rnd * ymax

    br(i) = rand(1, 4)

    bc(i) = _RGB32(Rnd * 75 + 160)

    ba(i) = -pi * (1 + .75 * Rnd - .75 * Rnd)

Next

clouds = _NewImage(xmax, ymax, 32)

While _KeyDown(27) = 0

    Cls , 0

    _Dest clouds

    Line (0, 0)-(_Width, _Height), blue, BF

    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) = _Hypot(bx(i) - bx(j), by(i) - by(j))

            da(j, i) = da(i, j) ' symetric relationship

        Next

    Next

    For i = 1 To nb 'draw then update positions of birds

        FC3 bx(i), by(i), br(i), bc(i) ' &HFFFFFFFF '

        s = rand(3, 5) ' get some bird separation here?

        bx(i) = bx(i) + s * Cos(ba(i))

        by(i) = by(i) + s * Sin(ba(i))

        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 < 20 Then ' birds are close enough to influence each other by visual

                ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j))) 'sway the neighbors headings towards each other

                ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))

            End If

            If dist < 5 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

    xoff = (xoff + 4) ' Mod (_Width(clouds&) + 1)

    a = a + _Pi(2 / 320)

    projectImagetoSphere clouds, xmax / 2, ymax / 2, ymax / 2 - 20, xoff

    _Display

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 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

Function Mod2# (n As Double, modulus As Double) ' this allows us to do floats including negative floats

    Dim rtn As Double

    rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))

    If n < 0 Then rtn = -rtn

    Mod2# = rtn

End Function

Sub FC3 (cx As Long, cy As Long, r As Long, clr~&)

    Dim As Long r2, x, y ' for Option _Explicit

    If r < 1 Then Exit Sub

    Line (cx - r, cy)-(cx + r, cy), clr~&, BF

    r2 = r * r

    Do

        y = y + 1

        x = Sqr(r2 - y * y)

        Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF

        Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF

    Loop Until y = r

End Sub

Sub projectImagetoSphere (image&, x0, y0, sr, xo)

    Dim r, iW, iH, scale, y, x1, tv, x, tu, pc~&

    r = _Height(image&) / 2

    iW = _Width(image&) - 20

    iH = _Height(image&)

    scale = sr / r

    For y = -r To r

        x1 = Sqr(r * r - y * y)

        tv = (_Asin(y / r) + 1.5) / 3

        For x = -x1 + 1 To x1

            tu = (_Asin(x / x1) + 1.5) / 6

            _Source image&

            pc~& = Point((xo + tu * iW) Mod iW, tv * iH)

            _Dest 0

            PSet (x * scale + x0, y * scale + y0), pc~&

        Next x

    Next y

End Sub

shhhh... unfortunately there is a seam in the sphere 

   

EDIT: cut 2 lines