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.

[mnrvovrfc]

LOL this is beautifully done! You could open your own arcade shop for it. Somebody else is going to want to put that into their own three-dimensional faking first-person shooter...

[bplus]

Thankyou mnrvovrfc

I have renamed named things; mainly Bloom is now Bolt because I don't want to create impression this is anything like a 3D Bloom that would take 1000's of LOC, just a simple 2D job that tries to simulate laser beams in pulses (sections of Bolt Line displayed in frames). I set 2 constants NBolts and PulseLength and lots more comments for easier mods and portability.

Yikes! They are shooting back at my ship... watch out for lower left corner specially ;-))

Code: (Select All)

Option _Explicit
_Title "Bolt: click mouse around screen" ' b+ 2023-07-15  started as Bloom.bas
' 2023-07-16 rename to Bolt from Bloom and comment better and make more generic

' BoltLine: Imagine a line with a thickness at one end and a different thickness at then other.
' Colored like I imagine a Laser beam yellowish white core with bluish tinge around the edges.
' Now draw sections of that BoltLine according to the frames of display in main loop.
' This is a demo of that!

Const NBolts = 20 ' max number of Bolt slots available, just like bullet science
Const PulseLength = 100 ' length of light pulses as they travel down BoltLine

Type BoltType 'see NewBolt for description of these variables
    As Single x1, y1, dx, dy, dr, d, r1, x2, y2, r2, frames, frame, active
End Type

Dim Shared Bolts(1 To NBolts) As BoltType
Dim mx, my, i, lpc

Randomize Timer
Screen _NewImage(1200, 700, 32)
_ScreenMove 50, 20

Do
    Cls
    DrawShip 600, 350, &HFF00CC66 ' bplus signature space ship, for rent :)

    ' fire off some more bolts at the ship from the screen corners!
    If lpc = 0 Then
        If Rnd < .2 Then NewBolt 0, 0, 1, 600, 350, 10
    ElseIf lpc = 30 Then
        If Rnd < .2 Then NewBolt _Width - 1, 0, 1, 600, 350, 20
    ElseIf lpc = 60 Then
        If Rnd < .2 Then NewBolt _Width - 1, _Height - 1, 1, 600, 350, 30
    ElseIf lpc = 90 Then
        If Rnd < .2 Then NewBolt 0, _Height - 1, 1, 600, 350, 50
    End If
    lpc = (lpc + 1) Mod 120 ' loopscounter every 30 shoot from a corner

    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY
    If _MouseButton(1) Then
        NewBolt 600, 340, 1, mx, my, 15
        _Delay .1 ' wait a little for mouse release so 2 bolts aren't draw from 1 click
    End If
    For i = 1 To NBolts
        If Bolts(i).active Then DrawBolt (i) ' draws the bolts still active
    Next '                                     according to what frame they are on
    _Display
    _Limit 60
Loop Until _KeyDown(27)

Sub NewBolt (x1, y1, r1, x2, y2, r2) ' sets up for the DrawBolt Sub
    Dim i
    For i = 1 To NBolts
        If Bolts(i).active = 0 Then
            Bolts(i).x1 = x1 ' start x, y, radius
            Bolts(i).y1 = y1
            Bolts(i).r1 = r1
            Bolts(i).x2 = x2 ' target x, y, radius (not precisely where bolt ends)
            Bolts(i).y2 = y2
            Bolts(i).r2 = r2
            Bolts(i).active = 1 ' bolt is activated
            Bolts(i).dx = x2 - x1 ' drawing the bolt line and thickness
            Bolts(i).dy = y2 - y1 ' as it changes from x1, y1, r1 to x2, y2, r2
            Bolts(i).dr = r2 - r1
            Bolts(i).d = _Hypot(Bolts(i).dx, Bolts(i).dy) ' distance of the bolt line
            Bolts(i).frames = Int(Bolts(i).d / PulseLength) + 1 ' divide that distance by pulse = PulseLength
            Bolts(i).frame = 1 ' set the frame you are on to locate the pulse in drawing
            Exit Sub
        End If
    Next
End Sub

Sub DrawBolt (idx) ' needs FCirc (Fill Circle) routine
    ' This sub draw a pulse of light on the BoltLine from .x1, .y1 on the way to .x2, .y2
    ' The start radius is .r1 and the end radius is .r2 and the pulse is thinned or thickened
    ' as it proceeds down the boltLine.

    'All this is setup in the NewBolt Sub and uses DIM Shared Bolts() as BoltType and Constants
    ' NBolts = max amount of activated Bolt "slots" available and PulseLength the length of
    ' BoltLine sections to draw in each frame.

    Dim i '
    For i = (Bolts(idx).frame - 1) * PulseLength To Bolts(idx).frame * (PulseLength - 1) Step 2
        FCirc Bolts(idx).x1 + i * Bolts(idx).dx / Bolts(idx).d, Bolts(idx).y1 + i * Bolts(idx).dy _
        / Bolts(idx).d, Bolts(idx).r1 + i * Bolts(idx).dr / Bolts(idx).d, &H10DDDDFF
        FCirc Bolts(idx).x1 + i * Bolts(idx).dx / Bolts(idx).d, Bolts(idx).y1 + i * Bolts(idx).dy _
        / Bolts(idx).d, .35 * Bolts(idx).r1 + i * .4 * Bolts(idx).dr / Bolts(idx).d, &HaaFFFFAA
    Next
    _Display
    _Delay .001
    Bolts(idx).frame = Bolts(idx).frame + 1 ' update frame number
    If Bolts(idx).frame > Bolts(idx).frames Then Bolts(idx).active = 0 ' job done!
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) 'needs FCirc and FEllipse subs
    Static ls ' tracks the last light position in string of lights
    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 - PulseLength, 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

Sorry for all the edits, trying to make this clear and simple and correct as possible.

[TerryRitchie]

Ok, thanks to the replies I received I realized a bloom is what I need, more specifically Gaussian blurring. Instead of recreating code for Gaussian blurs I've been using @RhoSigma 's excellent Image Processing Library which includes a few methods for Gaussian blurring. His blurring routines also preserve the alpha channel which is a HUGE plus! The code below is a proof of concept I came up with. You'll need the image and library .BM file below to execute the code.

Code: (Select All)

' Bloom test 1

' Uses RhoSigma's Image Processing Library (imageprocess.bm)



DIM TestImage AS LONG

DIM NoAlphaImage AS LONG

DIM AlphaImage AS LONG

DIM FirstPass AS LONG

DIM SecondPass AS LONG

DIM Alpha AS INTEGER

DIM Red AS INTEGER

DIM Green AS INTEGER

DIM Blue AS INTEGER

DIM x AS INTEGER

DIM y AS INTEGER

DIM i AS INTEGER



TestImage = _LOADIMAGE("test.png", 32) '                            27 x 53 original image

AlphaImage = _NEWIMAGE(_WIDTH(TestImage), _HEIGHT(TestImage), 32) ' empty image same size as original



RANDOMIZE TIMER

SCREEN _NEWIMAGE(640, 480, 32)



'+-----------------------------------+

'| Create quick and dirty background |

'+-----------------------------------+



FOR i = 1 TO 200

    LINE (RND * 640, RND * 480)-(RND * 640, RND * 480), _RGB32(RND * 256, RND * 256, RND * 256)

NEXT i



'+-------------------------------------------------------------------------+

'| Copy TestImage to AlphaImage at the same time applying the alpha levels |

'+-------------------------------------------------------------------------+



_DEST AlphaImage

_SOURCE TestImage

FOR y = 0 TO _HEIGHT(TestImage) - 1



    '+------------------------------------------+

    '| Draw center vertical strip with no alpha |

    '+------------------------------------------+



    Alpha = 255

    Red = _RED(POINT(13, y))

    Green = _GREEN(POINT(13, y))

    Blue = _BLUE(POINT(13, y))

    IF Red OR Green OR Blue THEN '                            don't copy pixel if value is (0,0,0)

        PSET (13, y), _RGB32(Red, Green, Blue, Alpha)

    END IF



    FOR x = 12 TO 0 STEP -1



        '+------------------------------------------------------------------------+

        '| Draw vertical strips to right and left of center with decreasing alpha |

        '+------------------------------------------------------------------------+



        Alpha = Alpha - 10

        Red = _RED(POINT(x, y))

        Green = _GREEN(POINT(x, y))

        Blue = _BLUE(POINT(x, y))

        IF Red OR Green OR Blue THEN '                        don't copy pixel if value is (0,0,0)

            PSET (x, y), _RGB32(Red, Green, Blue, Alpha)

            PSET (26 - x, y), _RGB32(Red, Green, Blue, Alpha)

        END IF

    NEXT x

NEXT y

_DEST 0

_SOURCE 0



NoAlphaImage = ApplyFilter&(TestImage, "gauss8", 0, 0, -1, -1, -1, -1, -1)

FirstPass = ApplyFilter&(AlphaImage, "gauss8", 0, 0, -1, -1, -1, -1, -1)

SecondPass = ApplyFilter&(FirstPass, "gauss8", 0, 0, -1, -1, -1, -1, -1)



_PUTIMAGE (100, 100), TestImage '      original untouched image

_PUTIMAGE (125, 100), NoAlphaImage '    TestImage blurred once with no alpha applied

_PUTIMAGE (150, 100), AlphaImage '      TestImage with alpha applied (no blurring)

_PUTIMAGE (175, 100), FirstPass '      AlphaImage blurred once

_PUTIMAGE (200, 100), SecondPass '      AlphaImage blurred a second time



'$INCLUDE:'imageprocess.bm'

[bplus]

@TerryRitchie that demo sucks LOL I look forward to seeing what you do from there. I have every confidence it will get allot better!

And now I am filled with 2 more ideas:
1. use image also, only a drawn one
2. control speed of bolt from start to finish more like a bullet

I've already added a random background so you can see the transparent blue tinge to laser pulse.

[TerryRitchie]

@TerryRitchie that demo sucks LOL I look forward to seeing what you do from there. I have every confidence it will get allot better!

And now I am filled with 2 more ideas:
1. use image also, only a drawn one
2. control speed of bolt from start to finish more like a bullet

I've already added a random background so you can see the transparent blue tinge to laser pulse.

It was just meant to show how well RhoSigma's Gaussian blur routines work. I need to work this into my previous attempts to figure out the best method to implement it.

[SpriggsySpriggs]

Now we can have Stormtroopers shooting in QB64

[bplus]

or play Laser Tag

[TerryRitchie]

or play Laser Tag

With MasterGy's Love and War code that is entirely possible!

[TerryRitchie]

Now we can have Stormtroopers shooting in QB64

You mean like this?