Summer LASER Challenge

[bplus]

This is what I came up with:

Code: (Select All)

Option _Explicit
_Title "Bloom: click mouse around screen" ' b+ 2023-07-15
Screen _NewImage(1200, 700, 32)
_ScreenMove 50, 50
Type ray
    As Single x1, y1, dx, dy, dr, d, r1, x2, y2, r2, frames, frame, active
End Type
Dim Shared blooms(1 To 20) As ray
Dim mx, my, i
Do
    Cls
    drawShip 600, 350, &HFF00CC66
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY
    If _MouseButt
on(1) Then
        bloom 600, 340, 1, mx, my, 15
        _Delay .1
    End If
    For i = 1 To 20
        If blooms(i).active Then drawBloom (i)
    Next
    _Display
    _Limit 30
Loop Until _KeyDown(27)

Sub bloom (x1, y1, r1, x2, y2, r2)
    Dim i
    For i = 1 To 20
        If blooms(i).active = 0 Then
            blooms(i).x1 = x1
            blooms(i).y1 = y1
            blooms(i).r1 = r1
            blooms(i).x2 = x2
            blooms(i).y2 = y2
            blooms(i).r2 = r2
            blooms(i).active = 1
            blooms(i).dx = x2 - x1
            blooms(i).dy = y2 - y1
            blooms(i).dr = r2 - r1
            blooms(i).d = _Hypot(blooms(i).dx, blooms(i).dy)
            blooms(i).frames = Int(blooms(i).d / 120) + 1
            blooms(i).frame = 1
            Exit Sub
        End If
    Next
End Sub

Sub drawBloom (ind)
    Dim i
    For i = (blooms(ind).frame - 1) * 120 To blooms(ind).frame * 118 Step 2
        fcirc blooms(ind).x1 + i * blooms(ind).dx / blooms(ind).d, blooms(ind).y1 + i * blooms(ind).dy / blooms(ind).d, blooms(ind).r1 + i * blooms(ind).dr / blooms(ind).d, &H10DDDDFF
        fcirc blooms(ind).x1 + i * blooms(ind).dx / blooms(ind).d, blooms(ind).y1 + i * blooms(ind).dy / blooms(ind).d, .35 * blooms(ind).r1 + i * .4 * blooms(ind).dr / blooms(ind).d, &H88FFFFAA
    Next
    _Display
    _Delay .001
    blooms(ind).frame = blooms(ind).frame + 1
    If blooms(ind).frame > blooms(ind).frames Then blooms(ind).active = 0
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

Sub drawShip (x, y, colr As _Unsigned Long) 'shipType     collisions same as circle x, y radius = 30
    Static ls
    Dim light As Long, r As Long, g As Long, b As Long
    r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
    FEllipse x, y, 6, 15, _RGB32(r, g - 120, b - 100)
    FEllipse x, y, 18, 11, _RGB32(r, g - 60, b - 50)
    FEllipse x, y, 30, 7, _RGB32(r, g, b)
    For light = 0 To 5
        fcirc x - 30 + 11 * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
    Next
    ls = ls + 1
    If ls > 5 Then ls = 0
End Sub

Sub FEllipse (CX As Long, CY As Long, xr As Long, yr As Long, C As _Unsigned Long)
    If xr = 0 Or yr = 0 Then Exit Sub
    Dim h2 As _Integer64, w2 As _Integer64, h2w2 As _Integer64
    Dim x As Long, y As Long
    w2 = xr * xr: h2 = yr * yr: h2w2 = h2 * w2
    Line (CX - xr, CY)-(CX + xr, CY), C, BF
    Do While y < yr
        y = y + 1
        x = Sqr((h2w2 - y * y * w2) \ h2)
        Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
        Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
    Loop
End Sub

Oh hey, I just discovered a cool effect. Drag the mouse close to the source of the shoot above the ship.