Screen Savers

[bplus]

Rain Drain

Code: (Select All)

'Rain Drain.bas started 2017-09-13
'translated from
'Rain Drain.bas  SmallBASIC 0.12.9 [B+=MGA] 2017-04-26

' 2020-08-29 Rain Drain 2: What if we move one side of every line up and down?

_Define A-Z As SINGLE
Randomize Timer
Const xmax = 1100
Const ymax = 700

Screen _NewImage(xmax, ymax, 32)
_FullScreen
_Title "Rain Drain 2:   spacebar for new arrangement,    esc to quit"

Type ball
    x As Single
    y As Single
    speed As Single
    r As Single
    c As Long
End Type

Type bLine
    x1 As Single
    y1 As Single
    x2 As Single
    y2 As Single
    a As Double
End Type

While _KeyDown(27) = 0
    balls = 1500
    ReDim b(balls) As ball
    For i = 1 To balls
        b(i).x = Rnd * xmax
        b(i).y = Rnd * ymax
        b(i).speed = 9.85
        b(i).r = 6
        b(i).c = _RGB(0, rand%(200, 255), rand%(200, 255))
    Next

    m = 10
    nbl = 12
    ReDim bl(nbl) As bLine
    For i = 1 To nbl
        d = rand%(50, 200)
        bl(i).x1 = rand%(m, xmax - d - m)
        bl(i).y1 = i * ymax / nbl - 10
        bl(i).a = Rnd * _Pi(1 / 4) - _Pi(1 / 8)
        bl(i).x2 = bl(i).x1 + d * Cos(bl(i).a)
        bl(i).y2 = bl(i).y1 + d * Sin(bl(i).a)
    Next
    dir = .5: lp = 0
    While 1
        Cls
        If 32 = _KeyHit Then
            Exit While
        ElseIf 27 = _KeyHit Then
            End
        End If
        lp = lp + dir
        If lp > 50 Then dir = -dir
        If lp < -50 Then dir = -dir

        For j = 1 To balls
            If b(j).y - b(j).r > ymax Or b(j).x + b(j).r < 0 Or b(j).x - b(j).r > xmax Then
                b(j).x = rand%(0, xmax): b(j).y = 0
            End If
            fcirc b(j).x, b(j).y, b(j).r, b(j).c
            testx = b(j).x + b(j).speed * Cos(_Pi(.5))
            testy = b(j).y + b(j).speed * Sin(_Pi(.5))
            cFlag = 0
            For i = 1 To nbl
                Color _RGB(255, 0, 0)
                If j = 1 Then bl(i).y1 = bl(i).y1 + dir
                Line (bl(i).x1, bl(i).y1)-(bl(i).x2, bl(i).y2)
                If cFlag = 0 Then
                    If hitLine(testx, testy, b(j).r, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) Then
                        bx1 = b(j).x + b(j).speed * Cos(bl(i).a)
                        bx2 = b(j).x + b(j).speed * Cos(_Pi(1) - bl(i).a)
                        by1 = yy(bx1, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
                        by2 = yy(bx2, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
                        If by1 = (-9999 - b(j).r - 1) Or by2 = (-9999 - b(j).r - 1) Then
                            cFlag = 0: Exit For
                        End If
                        If by1 >= by2 Then b(j).y = by1: b(j).x = bx1 Else b(j).y = by2: b(j).x = bx2
                        cFlag = 1
                    End If
                End If
            Next
            If cFlag = 0 Then b(j).x = testx: b(j).y = testy
        Next
        _Limit 20
        _Display
    Wend
Wend

Function hitLine (x, y, r, xx1, yy1, xx2, yy2)
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
    If x1 > x2 Then Swap x1, x2: Swap y1, y2
    If x < x1 Or x > x2 Then hitLine = 0: Exit Function
    If ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 - r < y And y < ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 + r Then
        hitLine = 1
    Else
        hitLine = 0
    End If
End Function

Function yy (x, xx1, yy1, xx2, yy2) 'this puts drop on line
    'copy parameters that are changed
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
    If x1 > x2 Then Swap x1, x2: Swap y1, y2
    If x1 <= x And x <= x2 Then
        yy = ((y2 - y1) / (x2 - x1)) * (x - x1) + y1
    Else
        yy = -9999
    End If
End Function

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

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