Fireworks.bas
Code: Select all
'Fireworks v0.50 build 2020-07-13 beta coded by UEZ
'Credits To:
' D.J.Peters aka Joshy For the SimplexNoise2D() Function
' dodicat For the Regulate() Function
#Include "fbgfx.bi"
#Include "String.bi"
Using FB
Dim As String sTitle = "Simple Fireworks v0.50 build 2020-07-13 beta coded by UEZ"
Declare Function RandomRange(fStart As Single, fEnd As Single) As Single
Declare Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85
Const iParticlesTail = 6, fGravity = 0.75, fRad = Acos(-1) / 180
Randomize Timer, 2
'--------------------------------------------------------------------------------------------------
Type float As Single 'Double
Dim Shared As Integer perm(512) = { _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180, _
151,160,137, 91, 90, 15,131, 13,201, 95, 96, 53,194,233, 7,225,_
140, 36,103, 30, 69,142, 8, 99, 37,240, 21, 10, 23,190, 6,148, _
247,120,234, 75, 0, 26,197, 62, 94,252,219,203,117, 35, 11, 32, _
57,177, 33, 88,237,149, 56, 87,174, 20,125,136,171,168, 68,175, _
74,165, 71,134,139, 48, 27,166, 77,146,158,231, 83,111,229,122, _
60,211,133,230,220,105, 92, 41, 55, 46,245, 40,244,102,143, 54, _
65, 25, 63,161, 1,216, 80, 73,209, 76,132,187,208, 89, 18,169, _
200,196,135,130,116,188,159, 86,164,100,109,198,173,186, 3, 64, _
52,217,226,250,124,123, 5,202, 38,147,118,126,255, 82, 85,212, _
207,206, 59,227, 47, 16, 58, 17,182,189, 28, 42,223,183,170,213, _
119,248,152, 2, 44,154,163, 70,221,153,101,155,167, 43,172, 9, _
129, 22, 39,253, 19, 98,108,110, 79,113,224,232,178,185,112,104, _
218,246, 97,228,251, 34,242,193,238,210,144, 12,191,179,162,241, _
81, 51,145,235,249, 14,239,107, 49,192,214, 31,181,199,106,157, _
184, 84,204,176,115,121, 50, 45,127, 4,150,254,138,236,205, 93, _
222,114, 67, 29, 24, 72,243,141,128,195, 78, 66,215, 61,156,180}
Function SimplexNoise2D(xin As float, yin As float, scale As float = 20.0) As float 'by D.J.Peters aka Joshy
Const As float F2 = 0.5*(Sqr(3.0)-1.0)
Const As float G2 = (3.0-Sqr(3.0))/6.0
Const As float G22 = G2 + G2
Static As Integer grad2(11,1) = {{ 1, 1},{-1, 1},{1,-1},{-1,-1}, _
{ 1, 0},{-1, 0},{1, 0},{-1, 0}, _
{ 0, 1},{ 0,-1},{0, 1},{ 0,-1}}
Dim As float s = (xin+yin)*F2
Dim As Integer i = Int(xin+s)
Dim As Integer j = Int(yin+s)
Dim As float t = (i+j)*G2
Dim As float x = i-t , y = j-t
Dim As float x0 = xin-x, y0 = yin-y
Dim As Integer i1=Any, j1=Any
i And=255
j And=255
If (x0>y0) Then
i1=1: j1=0
Else
i1=0: j1=1
End If
Dim As float x1 = x0 - i1 + G2
Dim As float y1 = y0 - j1 + G2
Dim As float x2 = x0 - 1.0 + G22
Dim As float y2 = y0 - 1.0 + G22
Dim As Integer ii = i 'And 255
Dim As Integer jj = j 'And 255
Dim As Integer ind = Any
Dim As float n=Any
t = 0.5 - x0*x0-y0*y0
If (t<0) Then
n=0
Else
ind = perm(i+perm(j)) Mod 12
n = t*t*t*t * (grad2(ind,0)*x0 + grad2(ind,1)*y0)
End If
t = 0.5 - x1*x1-y1*y1
If (t<0) Then
Else
ind = perm(i+i1+perm(j+j1)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x1 + grad2(ind,1)*y1)
End If
t = 0.5 - x2*x2-y2*y2
If(t<0) Then
Else
i+=1:j+=1
ind= perm(i+perm(j)) Mod 12
n+= t*t*t*t * (grad2(ind,0)*x2 + grad2(ind,1)*y2)
End If
' scaled in the interval [-1,1].
Return scale * n
End Function
'--------------------------------------------------------------------------------------------------
Type tagBoom
As Single power
As Single x
As Single y
As Single vx
As Single vy
As Ubyte r
As Ubyte g
As Ubyte b
As Ubyte a
As Single size
As Ubyte flag1
End Type
Type Kaboom
Public:
Declare Constructor()
Declare Destructor()
Declare Sub init()
Declare Sub update()
As Boolean detonate, set
As Single rocketx, rockety, rocketvx, rocketvy, radius, life, heigh, power
As tagBoom Boom(5000)
As Ubyte r, g, b, a, rr, gg, bb, aa, c1, c2
As Ulong particles
As Ubyte KType, flimmer
End Type
Constructor Kaboom()
This.Init()
End Constructor
Destructor Kaboom()
End Destructor
Sub Kaboom.init()
This.detonate = False
This.set = False
This.rocketx = scrw / 2 + RandomRange(-scrw / 10, scrw / 10)
This.rockety = scrh
This.rocketvx = RandomRange(-5, 5)
This.rocketvy = -(5 + Rnd() * 5)
This.heigh = scrh * 0.15 + Rnd() * (scrh * 0.30)
This.life = 255
This.power = 0.99 - Rnd() * 0.03
This.r = &hA0
This.g = &hA0
This.b = &hA0
This.a = &hFF
This.rr = &h40 + Rnd() * &h6F
This.gg = &h40 + Rnd() * &h6F
This.bb = &h40 + Rnd() * &h6F
This.c1 = 0
This.flimmer = 0
If Rnd() > 0.75 Then This.flimmer = 1
This.particles = 100 + Rnd() * 600
Dim As Single RndRGBColor = Rnd()
This.ktype = Cubyte(RandomRange(1, 3))
Select Case This.ktype
Case 3
Dim As Single h, g = 360 / (This.particles - 1), r
For i As Ulong = 0 To This.particles - 1
This.Boom(i).power = 0.5 + Rnd() * 7
This.Boom(i).vx = Sin(h * fRad) * This.Boom(i).power
This.Boom(i).vy = Cos(h * fRad) * This.Boom(i).power
If This.Boom(i).power > 6 - Rnd() * 2 Then
This.Boom(i).size = 2
Select Case RndRGBColor
Case 0 To 0.33
This.Boom(i).r = 250
This.Boom(i).g = Rnd() * &h7F
This.Boom(i).b = Rnd() * &h7F
Case 0.34 To 0.66
This.Boom(i).r = Rnd() * &h7F
This.Boom(i).g = 250
This.Boom(i).b = Rnd() * &h7F
Case Else
This.Boom(i).r = Rnd() * &h7F
This.Boom(i).g = Rnd() * &h7F
This.Boom(i).b = 250
End Select
This.Boom(i).a = This.a
Else
This.Boom(i).size = 1.333
This.Boom(i).r = This.rr
This.Boom(i).g = This.gg
This.Boom(i).b = This.bb
This.Boom(i).a = This.aa
End If
h += g
Next
Case 2
For i As Ulong = 0 To This.particles - 1
This.Boom(i).size = 1.333
This.Boom(i).vx = RandomRange(-1.0, 1.0) * (0.5 + Rnd() * 5)
This.Boom(i).vy = RandomRange(-1.0, 1.0) * (0.5 + Rnd() * 5)
This.Boom(i).r = This.r + Rnd() * &h5F
This.Boom(i).g = This.g + Rnd() * &h4F
This.Boom(i).b = This.b + Rnd() * &h4F
This.Boom(i).a = This.a
Next
Case 1
Dim As Single h, g = 360 / (This.particles - 1), r
For i As Ulong = 0 To This.particles - 1
This.Boom(i).power = 0.5 + Rnd() * 7
This.Boom(i).vx = Sin(h * fRad) * This.Boom(i).power
This.Boom(i).vy = Cos(h * fRad) * This.Boom(i).power
If This.Boom(i).power > 6 - Rnd() * 2 Then
This.Boom(i).size = 2
This.Boom(i).r = This.r + Rnd() * &h5F
This.Boom(i).g = This.g + Rnd() * &h5F
This.Boom(i).b = This.b + Rnd() * &h5F
This.Boom(i).a = This.a
Else
This.Boom(i).size = 1.333
This.Boom(i).r = This.rr
This.Boom(i).g = This.gg
This.Boom(i).b = This.bb
This.Boom(i).a = This.aa
End If
h += g
Next
End Select
End Sub
Sub Kaboom.Update()
If This.rockety > This.heigh Then
This.rocketx += This.rocketvx
This.rockety += This.rocketvy
Else
If This.set = False Then
For i As Ulong = 0 To This.particles - 1
This.Boom(i).x = This.rocketx
This.Boom(i).y = This.rockety
This.set = TRUE
Next
This.detonate = TRUE
End If
Dim As Ubyte aGlimmer(0 To 127) '= {255}
aGlimmer(Int(Rnd * Ubound(aGlimmer))) = 255
For i As Ulong = 0 To This.particles - 1
This.Boom(i).x += This.Boom(i).vx
This.Boom(i).y += This.Boom(i).vy + fGravity
This.Boom(i).vx *= This.power
This.Boom(i).vy *= This.power
This.Boom(i).a = This.life
If This.Boom(i).a < &h7F And This.flimmer = 1 Then
This.Boom(i).r = aGlimmer(This.c1)
This.Boom(i).g = aGlimmer(This.c1)
This.Boom(i).b = aGlimmer(This.c1)
This.Boom(i).a = &hFF - This.life
This.c1 += 1
If This.c1 = Ubound(aGlimmer) Then This.c1 = 0
Endif
Next
This.life -= 1
'This.a = This.life * This.power
If This.life = 0 Then This.init()
EndIf
End Sub
'--------------------------------------------------------------------------------------------------
Type tagParticleTail
As Single x
As Single y
As Single vx
As Single vy
As Ubyte r
As Ubyte g
As Ubyte b
As Ubyte a
End Type
Type ParticleTail
Declare Constructor()
Declare Destructor()
Declare Sub Add(x As Single, y As Single, iLife As Ushort = 35, vx As Single = 0, vy As Single = 0)
As tagParticleTail ParticleTail(iParticlesTail - 1)
As Ushort count
As UShort life
End Type
Constructor ParticleTail()
This.count = 0
End Constructor
Destructor ParticleTail()
End Destructor
Sub ParticleTail.Add(x As Single, y As Single, iLife As Ushort = 35, vx As Single = 0, vy As Single = 0)
For i As Ubyte = 0 To iParticlesTail - 1
ParticleTail(i).x = x
ParticleTail(i).y = y
ParticleTail(i).vx = Iif(vx = 0, RandomRange(-0.25, 0.25), vx)
ParticleTail(i).vy = Iif(vy = 0, Rnd() * 1, vy)
ParticleTail(i).r = &hFF
ParticleTail(i).g = &hB0
ParticleTail(i).b = &h60
ParticleTail(i).a = &hB0
Next
This.life = iLife
This.count += 1
End Sub
'--------------------------------------------------------------------------------------------------
Type _Stack
Public:
As ParticleTail aStack(Any)
As UInteger iPos = 1
Declare Constructor()
Declare Destructor()
Declare Sub Push(Byref oPT As ParticleTail)
Declare Function Get(iPos As UInteger) As ParticleTail
End Type
Constructor _Stack()
Redim This.aStack(0 To 10000) As ParticleTail
End Constructor
Destructor _Stack()
Redim This.aStack(0)
End Destructor
Sub _Stack.Push(Byref oPT As ParticleTail)
If This.iPos > Ubound(This.aStack) Then
Redim Preserve This.aStack(0 To This.iPos Shl 1)
End If
This.aStack(iPos) = oPT
This.iPos += 1
End Sub
Function _Stack.Get(iPos As UInteger) As ParticleTail
If iPos > 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function
'--------------------------------------------------------------------------------------------------
Dim Shared As _Stack Stack1, Stack2
Type Fireworks
Declare Constructor(iAmountRockets As Ubyte = 1)
Declare Destructor()
Declare Sub Update()
Declare Sub Plot()
Private:
As Ushort AmountRockets
As Kaboom Ptr pBuffer
As ParticleTail Ptr pBuffer2
As Image Ptr Img_Empty, Img_Fireworks, Img_Blur
End Type
Constructor Fireworks(iAmountRockets As Ubyte)
Img_Empty = Imagecreate(scrw, scrh, &h28000000, 32)
Img_Fireworks = Imagecreate(scrw, scrh, , 32)
This.AmountRockets = iAmountRockets
pBuffer = New Kaboom[This.AmountRockets]
pBuffer2 = New ParticleTail[1]
End Constructor
Destructor Fireworks()
Delete[] pBuffer
Delete[] pBuffer2
pBuffer = 0
pBuffer2 = 0
Imagedestroy This.Img_Empty
Imagedestroy This.Img_Fireworks
End Destructor
Sub Fireworks.Plot()
Dim As Uinteger iParticleSum = 0
Put This.Img_Fireworks, (0, 0), This.Img_Empty, Pset
For y As Ushort = 0 To This.AmountRockets - 1
Select Case pBuffer[y].detonate
Case False
If Rnd() > 0.666667 Then
pBuffer[y].rocketx += SimplexNoise2D(pBuffer[y].rocketx, pBuffer[y].rockety, 10) + Sin((pBuffer[y].rocketx - pBuffer[y].rockety) / 10) * 1.25
'pBuffer[y].rockety += SimplexNoise2D(pBuffer[y].rockety, pBuffer[y].rocketx, 15) + Cos(pBuffer[y].rocketx / 17) * 5.5
End If
Circle This.Img_Fireworks, (pBuffer[y].rocketx, pBuffer[y].rockety), 1.5 + SimplexNoise2D(pBuffer[y].rocketx, pBuffer[y].rockety, 150), Rgba(&hFF, &hFF, &hF0, &hE0),,, 1.5,F
pBuffer2[0].Add(pBuffer[y].rocketx, pBuffer[y].rockety, 7.5 + Rnd() * (20 * pBuffer[y].power))
Stack1.Push(pBuffer2[0])
iParticleSum += 1
Case Else
Dim as Single r, r2, cy, cyy, cx
For i As Ulong = 0 To pBuffer[y].particles - 1
r = pBuffer[y].Boom(i).size - 1
r2 = r * r
For cy = -r to r
cx = Sqr(r2 - cy * cy)
cyy = cy + pBuffer[y].Boom(i).y
Line This.Img_Fireworks, (pBuffer[y].Boom(i).x - cx, cyy)-(pBuffer[y].Boom(i).x + cx, cyy), _
Rgba(pBuffer[y].Boom(i).r, pBuffer[y].Boom(i).g, pBuffer[y].Boom(i).b, pBuffer[y].Boom(i).a)
Next
'Circle This.Img_Fireworks, (pBuffer[y].Boom(i).x, pBuffer[y].Boom(i).y), pBuffer[y].Boom(i).size, _
' Rgba(pBuffer[y].Boom(i).r, pBuffer[y].Boom(i).g, pBuffer[y].Boom(i).b, pBuffer[y].Boom(i).a),,,,F
iParticleSum += 1
Next
End Select
pBuffer[y].update
Next
Stack2.iPos = 1
For y As Ulong = 1 To Stack1.iPos - 1
Dim As ParticleTail oPT = Stack1.Get(y)
If oPT.life > 0 Then
For i As Ubyte = 0 To iParticlesTail - 1
Circle This.Img_Fireworks, (oPT.ParticleTail(i).x, oPT.ParticleTail(i).y), 0.1, Rgba(oPT.ParticleTail(i).r, oPT.ParticleTail(i).g, oPT.ParticleTail(i).b, oPT.ParticleTail(i).a),,,,F
oPT.ParticleTail(i).x += oPT.ParticleTail(i).vx
oPT.ParticleTail(i).y += oPT.ParticleTail(i).vy
If oPT.ParticleTail(i).a - 5 > 0 Then oPT.ParticleTail(i).a -= 5
iParticleSum += 1
Next
End If
oPT.life -= 1
If oPt.life > 0 Then Stack2.Push(oPT)
Next
'clean-up stack
For y As ULong = 1 To Stack2.iPos - 1
Stack1.aStack(y) = Stack2.aStack(y)
Next
Stack1.iPos = Stack2.iPos
Draw String (1, scrh - 10), "Particles:" & iParticleSum, Rgb(&hFF, &h00, &h00)
Put (0, 0), This.Img_Fireworks, Alpha
End Sub
'--------------------------------------------------------------------------------------------------
#Ifdef __Fb_win32__
#Include "windows.bi"
Enum PROCESS_DPI_AWARENESS
DPI_AWARENESS_INVALID = -1, PROCESS_DPI_UNAWARE = 0, PROCESS_SYSTEM_DPI_AWARE = 1, PROCESS_PER_MONITOR_DPI_AWARE = 2
End Enum
Function _WinAPI_GetDpiForWindow(hWnd As HWND) As Ubyte 'requires Win10 v1607+ / no server support
Dim As Any Ptr pLib = Dylibload("User32.dll")
If pLib = NULL Then Exit Function
Dim pGetDpiForWindow As Function (Byval hWND As HWND) As UINT
pGetDpiForWindow = Dylibsymbol(pLib, "GetDpiForWindow")
If pGetDpiForWindow Then Function = pGetDpiForWindow(hWnd)
Dylibfree(pLib)
End Function
Function _WinAPI_SetProcessDpiAwareness(DPIAware As Integer) As Ubyte 'requires Windows 8.1+ / no server support
Dim As Any Ptr pLib = Dylibload("Shcore.dll")
If pLib = NULL Then Exit Function
Dim pSetProcessDpiAwareness As Function (Byval DPIAware As Integer) As HRESULT
pSetProcessDpiAwareness = Dylibsymbol(pLib, "SetProcessDpiAwareness")
If pSetProcessDpiAwareness Then Function = pSetProcessDpiAwareness(DPIAware)
Dylibfree(pLib)
End Function
_WinAPI_SetProcessDpiAwareness(PROCESS_PER_MONITOR_DPI_AWARE)
Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)
Dim tWorkingArea As RECT
SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Else
Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)
#Endif
Windowtitle(sTitle)
Dim As Fireworks Firework = Fireworks(20)
Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer
Do
Screenlock
Firework.Plot()
Draw String(1, 1), iFPS_current & " fps", Rgba(&hFF, &h00, &h00, &hE0)
Screenunlock
If Timer - fTimer > 0.99 Then
iFPS_current = iFPS
iFPS = 0
fTimer = Timer
Else
iFPS += 1
Endif
Sleep(Regulate(60), 1)
Loop Until Inkey = Chr(27)
'--------------------------------------------------------------------------------------------------
Function RandomRange(fStart As Single, fEnd As Single) As Single
Return Rnd() * (fEnd - fStart) + fStart
End Function
'--------------------------------------------------------------------------------------------------
Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
This is my 2nd attempt using classes to get a better understanding... ^^