Screen Savers

[bplus]

Ken's Spashes reminded of this:

Splats

Code: (Select All)

_Title "Splats" 'b+ 2020-01-12
' from eRATication/cheese wedge tests/ multiple explosions.bas 2018-07-28 translated from
'bomb.bas for SmallBASIC 0.12.2 [B+=MGA] 2016-05-09 from explosion study

Const xmax = 1300, ymax = 760, pi2 = 6.283185
Type particle
    x As Single
    y As Single
    dx As Single
    dy As Single
    size As Single
    spread As Single
    'tf AS INTEGER
End Type
ReDim Shared dots(1) As particle
Screen _NewImage(xmax, ymax, 32)
_FullScreen
Randomize Timer
Dim kolor As _Unsigned Long

While Not _KeyDown(27)
    Color , _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
    Cls
    stopit = (Rnd * 100) \ 1 + 15
    For i = 1 To stopit
        dx = Rnd * 60 - 30: dy = Rnd * 60 - 30: a = 7 * (Rnd * 10 - 5): b = 7 * (Rnd * 10 - 5)
        x = xmax * Rnd: y = ymax * Rnd
        r = Rnd * 255
        If InKey$ = " " Then toggle = 1 - toggle
        If toggle Then
            kolor = _RGB32(r, r, r)
        Else
            kolor = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
        End If
        While x > -100 And x < xmax + 100 And y > -100 And y < ymax + 100
            splat x, y, kolor
            x = x + dx: y = y + dy
            dx = dx + a: dy = dy + b
            _Display
        Wend
    Next
    _Delay 5
Wend
System

Sub splat (x, y, kolor As _Unsigned Long)
    round = 5
    nRounds = (Rnd * 10) \ 1 + 1
    nDots = nRounds * round

    ReDim dots(1 To nDots) As particle
    For i = 1 To round
        NewDot i, x, y
    Next
    rounds = round
    For loopCount = 0 To 20
        If _KeyDown(27) Then End
        For i = 1 To rounds
            dots(i).x = dots(i).x + dots(i).dx
            dots(i).y = dots(i).y + dots(i).dy
            dots(i).dx = dots(i).dx * dots(i).spread
            dots(i).dy = dots(i).dy * dots(i).spread
            fcirc dots(i).x, dots(i).y, dots(i).size / 2, kolor
            dots(i).size = dots(i).size * dots(i).spread
        Next
        If rounds < nDots Then
            For i = 1 To round
                NewDot i, x, y
            Next
            rounds = rounds + round
        End If
        _Display
    Next
End Sub

Sub NewDot (i, x, y)
    angle = Rnd * pi2
    r = Rnd * 5
    dots(i).x = x + r * Cos(angle)
    dots(i).y = y + r * Sin(angle)
    dots(i).size = Rnd * 15 + 5
    r = Rnd * 3
    dots(i).dx = r * (15 - dots(i).size) * Cos(angle)
    dots(i).dy = r * (15 - dots(i).size) * Sin(angle)
    dots(i).spread = Rnd * .3 + .2
End Sub

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