Ball Screensaver

[SMcNeill]

The little demo should speak for itself.   It's simple, but I was just having fun playing around with my balls for a bit this morning, since it seems everyone else has been doing the same thing around here lately. 

Code: (Select All)

Screen _NewImage(1024, 720, 32)

Randomize Timer

$Color:32



Type Ball_Type

    x As Integer 'position

    y As Integer

    xchange As Integer 'speed

    ychange As Integer

    size As Integer 'size

    c As _Unsigned Long 'color

End Type



Dim Balls(5000) As Ball_Type

'Init balls

For i = 0 To UBound(Balls)

    Balls(i).size = Int(Rnd * 10) + 1

    Select Case Int(Rnd * 2)

        Case 0: Balls(i).c = Red

        Case Else: Balls(i).c = Blue

    End Select

    Balls(i).x = Int(Rnd * _Width)

    Balls(i).y = Int(Rnd * _Height)

    Balls(i).xchange = Int(Rnd * 20) - 10

    Balls(i).ychange = Int(Rnd * 20) - 10

Next



t# = Timer(.01)

Do

    While _MouseInput: Wend

    Cls

    max = (Timer - t#) * 10

    If max >= 1000 Then max = 1000

    For i = 1 To max

        CircleFill Balls(i).x, Balls(i).y, Balls(i).size, Balls(i).c

        Balls(i).x = Balls(i).x + Balls(i).xchange

        Balls(i).y = Balls(i).y + Balls(i).ychange

        If _Hypot(Balls(i).x - _MouseX, Balls(i).y - _MouseY) < Balls(i).size Then

            Balls(i).xchange = -Balls(i).xchange

            Balls(i).ychange = -Balls(i).ychange

            Balls(i).c = Green

        End If

        If Balls(i).x < 0 Then

            Balls(i).x = 0

            Balls(i).xchange = -Balls(i).xchange

        End If

        If Balls(i).y < 0 Then

            Balls(i).y = 0

            Balls(i).ychange = -Balls(i).ychange

        End If

        If Balls(i).x >= _Width Then

            Balls(i).x = _Width

            Balls(i).xchange = -Balls(i).xchange

        End If

        If Balls(i).y >= _Height Then

            Balls(i).y = _Height

            Balls(i).ychange = -Balls(i).ychange

        End If

    Next

    _Limit 60

    _Display

Loop



Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)

    ' CX = center x coordinate

    ' CY = center y coordinate

    '  R = radius

    '  C = fill color

    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

Have fun and see how long it takes you to turn all the balls green.