Summer LASER Challenge

[James D Jarvis]

I didn't look at any of the other programs so far and this is what I whipped up for a laser zap demo.  From what i just scrolled past some above look similar and more sophisticated. But what the heck... here's another shot at the task.

Code: (Select All)

'laser zap demo
Screen _NewImage(800, 500, 32)
Dim zapa(30), zapx(30), zapy(30), zapds(30), zapde(30), zapl(30)
Dim zapk(30) As _Unsigned Long
Dim starx(100), stary(100)
Cls
_Blend
Do
    rays = 5 + Int(1 + Rnd * 25)
    xx = 400 - Int(Rnd * 200) + Int(Rnd * 200)
    yy = 250 - Int(Rnd * 100) + Int(Rnd * 100)
    For a = 1 To rays
        zapa(a) = Int(Rnd * 360)
        zapx(a) = xx
        zapy(a) = yy
        zapds(a) = Int(1 + Rnd * 6)
        zapde(a) = Int(zapds(a) + Rnd * (2 * (zapds(a))))
        zapl(a) = Int(3 + Rnd * 6) * 50
        zapk(a) = _RGBA32(220 + Int(Rnd * 30) - Rnd * (30), 230 - Int(Rnd * 12) + Int(Rnd * 12), 0, 22)
    Next a
    For c = 1 To 100
        starx(c) = Int(Rnd * _Width)
        stary(c) = Int(Rnd * _Height)
    Next c
    lr = Int(2 + Rnd * 10) * 15
    For z = 1 To 30
        _Limit lr
        Cls
        For c = 1 To 100
            PSet (starx(c), stary(c)), _RGBA32(252 + Int(Rnd * 3), 252 + Int(Rnd * 3), 252 + Int(Rnd * 3), 200 + Int(Rnd * 50))
        Next c

        For n = 1 To rays
            zz = Int(z + Rnd(31 - z))
            zzz = 30 - Int(Rnd * 3)
            zap_line zapx(n), zapy(n), zapl(n), zapa(n), zapds(n), zapde(n), zz, zzz, zapk(n)
        Next n
        _Display
    Next z
    Cls
    For c = 1 To 100
        PSet (starx(c), stary(c)), _RGBA32(252 + Int(Rnd * 3), 252 + Int(Rnd * 3), 252 + Int(Rnd * 3), 200 + Int(Rnd * 50))
    Next c

    Print "Press any key for more zaps, <esc> to quit"

    _Display
    Do
        _Limit 60
        kk$ = InKey$
    Loop Until kk$ <> ""
    Cls
    _Display
Loop Until kk$ = Chr$(27)
Sub zap_line (x, y, Lnth, ang, thks, thke, ss, es, klr As _Unsigned Long)
    Dim zseg(30, 2)
    Dim thk(30)
    thk(1) = thks
    tc = (thke - thks) / 30

    zseg(1, 1) = x: zseg(1, 2) = y
    st = ss: If st = 1 Then st = 2
    For s = 2 To 30
        zseg(s, 1) = zseg(s - 1, 1) + (Lnth / 30) * Cos(0.01745329 * ang)
        zseg(s, 2) = zseg(s - 1, 2) + (Lnth / 30) * Sin(0.01745329 * ang)
        thk(s) = thk(s - 1) + tc
    Next s
    For s = st To es
        If Int(Rnd * 10) < 7 Then fatline zseg(s - 1, 1), zseg(s - 1, 2), zseg(s, 1), zseg(s, 2), thk(s) + thk(2) / 5, klr
        If Int(Rnd * 10) < 8 Then fatline zseg(s - 1, 1), zseg(s - 1, 2), zseg(s, 1), zseg(s, 2), thk(s), klr

    Next s
End Sub


Sub angle_line (x, y, Lnth, ang, thk, klr As _Unsigned Long)
    'draw a line from x,y lnth units long (from center of line) at angle ang of radial thickness thk in color klr
    ox = x: oy = y
    nx = ox + Lnth * Cos(0.01745329 * ang)
    ny = oy + Lnth * Sin(0.01745329 * ang)
    fatline ox, oy, nx, ny, thk, klr
End Sub

Sub fcirc (CX As Long, CY As Long, R, klr As _Unsigned Long)
    'draw a filled circle with the quickest filled circle routine in qb64, not my development
    Dim subRadius As Long, RadiusError As Long
    Dim X As Long, Y As Long
    subRadius = Abs(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0
    If subRadius = 0 Then PSet (CX, CY): Exit Sub
    Line (CX - X, CY)-(CX + X, CY), klr, 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), klr, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), klr, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), klr, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), klr, BF
    Wend
End Sub

Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
    'draw a line with dots with a radial thickness of r    from x0,y0 to x1,y1 in color klr
    If r > 0.5 Then
        If Abs(y1 - y0) < Abs(x1 - x0) Then
            If x0 > x1 Then

                lineLow x1, y1, x0, y0, r, klr
            Else

                lineLow x0, y0, x1, y1, r, klr
            End If
        Else
            If y0 > y1 Then
                lineHigh x1, y1, x0, y0, r, klr
            Else
                lineHigh x0, y0, x1, y1, r, klr
            End If
        End If
    Else
        Line (x0, y0)-(x1, y1), klr 'line with r of <= 0.5 don't render properly so we force them to be 1 pixel wide on screen
    End If
End Sub
Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
    dx = x1 - x0
    dy = y1 - y0
    yi = 1
    If dy < 0 Then
        yi = -1
        dy = -dy
    End If
    d = (dy + dy) - dx
    y = y0
    For x = x0 To x1
        fcirc x, y, r, klr
        If d > 0 Then
            y = y + yi
            d = d + ((dy - dx) + (dy - dx))
        Else
            d = d + dy + dy
        End If
    Next x
End Sub
Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
    dx = x1 - x0
    dy = y1 - y0
    xi = 1
    If dx < 0 Then
        xi = -1
        dx = -dx
    End If
    D = (dx + dx) - dy
    x = x0
    For y = y0 To y1
        fcirc x, y, r, klr
        If D > 0 Then
            x = x + xi
            D = D + ((dx - dy) + (dx - dy))
        Else
            D = D + dx + dx
        End If
    Next y
End Sub
Sub Replace (text$, old$, new$)
    'modiifed routine from WIKI shown in  LEFT$  entry
    Do
        find = InStr(start + 1, text$, old$)
        If find Then
            count = count + 1
            first$ = Left$(text$, find - 1)
            last$ = Right$(text$, Len(text$) - (find + Len(old$) - 1))
            text$ = first$ + new$ + last$
        End If
        start = find
    Loop While find
End Sub