QB64 Phoenix Edition
Spiral Colored Balls - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: bplus (https://staging.qb64phoenix.com/forumdisplay.php?fid=36)
+---- Thread: Spiral Colored Balls (/showthread.php?tid=168)

Spiral Colored Balls - bplus - 04-25-2022

Just checked this in Keybone's QB64 - Lite for Linux, it's been awhile since I've seen this.

Code: (Select All)
Option _Explicit
_Title "Spiral Colored Balls" 'B+ 2019-10-29 mod from
' 2019-10-29 mod be able to draw these balls anywhere
' Rotate colors on a sphere.txt for JB v2.0 bplus 2018-04-16
' from (extremely simplified) Double spiral.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-03-28

Const xmax = 1200, ymax = 700, pi = _Pi, nBalls = 10, ww = 3.14159 / 2, gravity = 2
Type ball
    x As Single
    y As Single
    a As Single
    dx As Single
    dy As Single
    sc As Single
    pr As Single
    pg As Single
    pb As Single
    pn As Single
End Type

Dim Shared b(1 To nBalls) As ball

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 100, 20 'this fits my screen yours may be different
Randomize Timer

Dim i As Integer, j As Integer, b As Integer, power, sky As Long

For i = 1 To nBalls
    newBall i
Next
sky = _NewImage(xmax, ymax, 32)
_Dest sky&
For i = 0 To ymax
    Line (0, i)-(xmax, i), _RGB32(100 + i / ymax * 40, 100 + i / ymax * 50, 160 + i / ymax * 95)
Next
_Dest 0
While _KeyDown(27) = 0
    _PutImage , sky&, 0
    For i = 1 To nBalls
        'ready for collision
        b(i).a = _Atan2(b(i).dy, b(i).dx)
        power = (b(i).dx ^ 2 + b(i).dy ^ 2) ^ .5
        For j = i + 1 To nBalls
            If Sqr((b(i).x - b(j).x) ^ 2 + (b(i).y - b(j).y) ^ 2) < 200 * (b(i).sc + b(j).sc) Then
                b(i).a = _Atan2(b(i).y - b(j).y, b(i).x - b(j).x)
                b(j).a = _Atan2(b(j).y - b(i).y, b(j).x - b(i).x)
                Exit For
            End If
        Next
        b(i).dx = power * Cos(b(i).a)
        b(i).dy = power * Sin(b(i).a)
        b(i).dy = b(i).dy + gravity
        b(i).x = b(i).x + b(i).dx
        b(i).y = b(i).y + b(i).dy '+ 2 * gravity
        If b(i).x < -200 * b(i).sc Or b(i).x > xmax + 200 * b(i).sc Then
            newBall i
        End If
        If b(i).y + 220 * b(i).sc > ymax Then
            b(i).y = ymax - 220 * b(i).sc
            b(i).dy = b(i).dy * -.8
            If b(i).dx = 0 Then b(i).dx = rdir Else b(i).dx = b(i).dx * 1.03
        End If
        drawBall i
    Next
    _Display
Wend

Sub drawBall (i)
    Dim w, r, e, tmp, p, x, y, lc As Long
    w = ww 'fix
    For r = 190 To 0 Step -.25
        e = w - pi / 4 / (490 - 300)
        tmp = e: e = w: w = tmp
        For p = 0 To pi Step pi / 144
            e = Int((Cos(w) * 380) / 2)
            x = b(i).x + e * b(i).sc * Cos(p * 2)
            y = b(i).y - 90 * b(i).sc + e * b(i).sc * Sin(p * 2) + r * b(i).sc
            lc = lc + 1
            If lc Mod 25 = 0 Then
                fcirc x, y, 6 * b(i).sc, plasma~&(i)
            End If
        Next
    Next

End Sub

Sub newBall (i)
    b(i).x = Rnd * xmax - 40 + 20
    b(i).y = Rnd * -200
    b(i).dx = rand(1, 3) * rdir
    b(i).dy = rand(-5, 5)
    b(i).sc = rand(2, 5) / 10
    setRGB i
End Sub

Sub setRGB (i)
    b(i).pr = Rnd ^ 3: b(i).pg = Rnd ^ 3: b(i).pb = Rnd ^ 3: b(i).pn = 1
End Sub

Function plasma~& (i)
    b(i).pn = b(i).pn + .05
    plasma~& = _RGBA32(127 + 127 * Sin(b(i).pr * b(i).pn), 127 + 127 * Sin(b(i).pg * b(i).pn), 127 + 127 * Sin(b(i).pb * b(i).pn), 40)
    'plasma~& = _RGBA32(127 + 127 * SIN(b(i).pr * b(i).pn), 127 + 127 * SIN(b(i).pg * b(i).pn), 127 + 127 * SIN(b(i).pb * b(i).pn), 255)
End Function

Function rand (lo, hi)
    rand = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function

Function rdir ()
    If Rnd < .5 Then rdir = -1 Else rdir = 1
End Function

'from Steve Gold standard
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    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

   

RE: Spiral Colored Balls - Dav - 04-25-2022

Nice effect, bplus.  I don't remember seeing this one before.  Glad you posted it.  Fun to tweak!  I was playing around with some of the values and came up with some pretty nice looking bubbles, but I closed QB64 before saving it and *poof* they were gone.

- Dav

RE: Spiral Colored Balls - James D Jarvis - 04-25-2022

Neat.

RE: Spiral Colored Balls - bplus - 04-25-2022

Thanks Dav and James Smile