How to push object to stack without loosing reference

General FreeBASIC programming questions.
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

How to push object to stack without loosing reference

Postby UEZ » Dec 30, 2018 21:56

Currently I'm trying to code some fireworks using classes. My idea was to add some particle tails by using a stack. My problem is that the class is not by reference and hence the values will not be updated properly.

When you run the example you will see the dotted lines which are the tails. The object will be added to the stack but not updated (see Sub Fireworks.Draw()).

How can I get this work?

Code: Select all

'Fireworks alpha coded by UEZ

#Include "fbgfx.bi"
#Include "string.bi"

Using FB

Declare Function RandomRange(fStart As Single, fEnd As Single) As Single


Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85

Const iParticles = 500, iParticlesTail = 30, fGravity = 0.3333, fRad = Acos(-1) / 180

Randomize , 2



Type tagParticle
   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
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 tagParticle Particle(iParticles)
      As Ubyte r, g, b, a, rr, gg, bb, aa
      As Ulong Color
      As Ubyte KType
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 = Rnd() * 4 - 2
   This.rocketvy = -4 - Rnd() * 4
   This.heigh = scrh * 0.15 + Rnd() * (scrh * 0.30)
   This.life = 255
   This.power = 0.99 - Rnd() * 0.03
   This.r = &h80 + Rnd() * &h7F
   This.g = &h80 + Rnd() * &h7F
   This.b = &h80 + Rnd() * &h7F
   This.a = &hFF
   This.ktype = Cubyte(RandomRange(1, 2))
   
   Dim As Single h, g = 360 / (iParticles - 1), r
   For i As Ulong = 0 To iParticles - 1
      Select Case This.ktype
         Case 1
            This.Particle(i).power = 0.5 + Rnd() * 8
            This.Particle(i).vx = Cos(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).r = This.r
            This.Particle(i).g = This.g
            This.Particle(i).b = This.b
            This.Particle(i).a = This.a
         Case 2
            This.Particle(i).power = 0.5 + Rnd() * 8
            This.Particle(i).vx = Cos(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).r = Rnd() * &hFF
            This.Particle(i).g = Rnd() * &hFF
            This.Particle(i).b = Rnd() * &hFF
            This.Particle(i).a = Rnd() * &hFF
      End Select
      h += g
   Next
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 iParticles - 1            
            This.Particle(i).x = This.rocketx
            This.Particle(i).y = This.rockety
            This.set = TRUE
         Next
         This.detonate = TRUE
      End If
      For i As Ulong = 0 To iParticles - 1
         This.Particle(i).x += This.Particle(i).vx
         This.Particle(i).y += This.Particle(i).vy + fGravity
         This.Particle(i).vx *= This.power
         This.Particle(i).vy *= This.power
         This.Particle(i).a = This.life
         If This.Particle(i).a < &h80 Then
            This.Particle(i).r = &hFF * Rnd()
            This.Particle(i).g = &hFF * Rnd()
            This.Particle(i).b = &hFF * Rnd()
         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)
   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)
   For i As Ubyte = 0 To iParticlesTail - 1   
      ParticleTail(i).x = x
      ParticleTail(i).y = y
      ParticleTail(i).vx = RandomRange(-4, 4)
      ParticleTail(i).vy = Rnd() * 5
      ParticleTail(i).r = &h80
      ParticleTail(i).g = &h80
      ParticleTail(i).b = &h80
      ParticleTail(i).a = &hFF
   Next
   This.life = 50
   This.count += 1
End Sub

'--------------------------------------------------------------------------------------------------
Type _Stack
   Private:
      As ParticleTail aStack(Any)
      As Uinteger iPos = 0
   Public:
      Declare Sub Init()
      Declare Sub Push(oPT As ParticleTail)
      Declare Function Pop() As ParticleTail
      Declare Function Count() As Uinteger
      Declare Function Get(iPos As Uinteger) As ParticleTail
End Type

Sub _Stack.Init()
   Redim This.aStack(0 To 10000) As ParticleTail
End Sub

Sub _Stack.Push(Byref oPT As ParticleTail)
   If This.iPos >= Ubound(This.aStack) Then
      Redim Preserve This.aStack(0 To This.iPos + 1000)
   End If
   This.aStack(iPos) = oPT
   This.iPos += 1
End Sub

Function _Stack.Pop() As ParticleTail
   If This.iPos > 0 Then This.iPos -= 1
   Return This.aStack(This.iPos)
End Function

Function _Stack.Get(iPos As Uinteger) As ParticleTail
   If iPos >= 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function

Function _Stack.Count() As Uinteger
   Return This.iPos
End Function

'--------------------------------------------------------------------------------------------------
Type Fireworks
   Declare Constructor(iAmount As Ubyte = 1)
   Declare Destructor()
   Declare Sub Update()
   Declare Sub Draw()
   Private: 
      As Ushort amount
      As Kaboom Ptr pBuffer
      As ParticleTail Ptr pBuffer2
      As Image Ptr Img_Empty, Img_Fireworks, Img_Blur
      As _Stack Stack
End Type

Constructor Fireworks(iAmount As Ubyte)
   Img_Empty = Imagecreate(scrw, scrh, &hFF000000, 32)
   Img_Fireworks = Imagecreate(scrw, scrh, , 32)
   This.amount = iAmount
   pBuffer = New Kaboom[This.amount]
   pBuffer2 = New ParticleTail[1]
   Stack.Init()
End Constructor

Destructor Fireworks()
   Delete[] pBuffer
   Delete[] pBuffer2
   pBuffer = 0
   pBuffer2 = 0
   Imagedestroy This.Img_Empty
   Imagedestroy This.Img_Fireworks
End Destructor


Sub Fireworks.Draw()
   Put This.Img_Fireworks, (0, 0), This.Img_Empty, Pset
   For y As Ushort = 0 To This.amount - 1
      Select Case pBuffer[y].detonate
         Case False
            Circle This.Img_Fireworks, (pBuffer[y].rocketx, pBuffer[y].rockety), 2, Rgba(&hA0, &hA0, &hA0, &hF0),,,,F
            pBuffer2[0].Add(pBuffer[y].rocketx, pBuffer[y].rockety)
            Stack.Push(pBuffer2[0])         
         Case Else
            
            For i As Ulong = 0 To iParticles - 1
               Circle This.Img_Fireworks, (pBuffer[y].Particle(i).x, pBuffer[y].Particle(i).y), 1, _
                     Rgba(pBuffer[y].Particle(i).r, pBuffer[y].Particle(i).g, pBuffer[y].Particle(i).b, pBuffer[y].Particle(i).a),,,,F
               'Circle This.Img_Fireworks, (pBuffer[y].aParticle(i, 3), pBuffer[y].aParticle(i, 4)), 1, pBuffer[y].r Shl 16 Or pBuffer[y].g Shl 8 Or pBuffer[y].b Or pBuffer[y].a Shl 24,,,,F
            Next
            
      End Select
      pBuffer[y].update
   Next
   
   Dim As ParticleTail oPT
   For y As Ulong = 0 To Stack.Count() - 1
      oPT = Stack.Get(y)
      If oPT.life = 0 Then Stack.pop()
      For i As Ubyte = 0 To iParticlesTail - 1
         Circle This.Img_Fireworks, (oPT.ParticleTail(i).x, oPT.ParticleTail(i).y), 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 + fGravity
         oPT.ParticleTail(i).a -= 1
      Next
      oPT.life -= 1
   Next
   
   Put (0, 0), This.Img_Fireworks, Trans
End Sub
'--------------------------------------------------------------------------------------------------




Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)

#Ifdef __Fb_win32__
   #Include "windows.bi"
   Dim tWorkingArea As RECT
   SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
   Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Endif
                             
Windowtitle "Simple Fireworks coded by UEZ"

Dim As Fireworks Firework

Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer


Do
   Screenlock
   Firework.Draw
   Draw String(0, 0), iFPS_current & " fps", Rgb(&hFF, &h00, &h00)
   Screenunlock
   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   Sleep 1
Loop Until Inkey = Chr(27)

'--------------------------------------------------------------------------------------------------
Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function
sancho3
Posts: 358
Joined: Sep 30, 2017 3:22

Re: How to push object to stack without loosing reference

Postby sancho3 » Dec 30, 2018 23:54

In the draw function these lines create a copy of the member of the stack. They do not give you access to the member. So when oPT goes out of scope any amount of oPT.Life -= 1 has no affect on the stored member. You can see that the 'if' line never resolves to true. You need to change to a pointer.

Code: Select all

   Dim As ParticleTail oPT
   For y As Ulong = 0 To Stack.Count() - 1
      oPT = Stack.Get(y)
      If oPT.life = 0 Then Stack.pop()
      For i As Ubyte = 0 To iParticlesTail - 1
         Circle This.Img_Fireworks, (oPT.ParticleTail(i).x, oPT.ParticleTail(i).y), 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 + fGravity
         oPT.ParticleTail(i).a -= 1
      Next
      oPT.life -= 1
   Next

In this version I undid the 'private' in the stack so I could get access to aStack. There is better ways of doing this but this was quickest.
I changed oPT to a pointer.

Code: Select all

'Fireworks alpha coded by UEZ

#Include "fbgfx.bi"
#Include "string.bi"

Using FB

Declare Function RandomRange(fStart As Single, fEnd As Single) As Single


Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85

Const iParticles = 500, iParticlesTail = 30, fGravity = 0.3333, fRad = Acos(-1) / 180

Randomize , 2



Type tagParticle
   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
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 tagParticle Particle(iParticles)
      As Ubyte r, g, b, a, rr, gg, bb, aa
      As Ulong Color
      As Ubyte KType
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 = Rnd() * 4 - 2
   This.rocketvy = -4 - Rnd() * 4
   This.heigh = scrh * 0.15 + Rnd() * (scrh * 0.30)
   This.life = 255
   This.power = 0.99 - Rnd() * 0.03
   This.r = &h80 + Rnd() * &h7F
   This.g = &h80 + Rnd() * &h7F
   This.b = &h80 + Rnd() * &h7F
   This.a = &hFF
   This.ktype = Cubyte(RandomRange(1, 2))
   
   Dim As Single h, g = 360 / (iParticles - 1), r
   For i As Ulong = 0 To iParticles - 1
      Select Case This.ktype
         Case 1
            This.Particle(i).power = 0.5 + Rnd() * 8
            This.Particle(i).vx = Cos(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).r = This.r
            This.Particle(i).g = This.g
            This.Particle(i).b = This.b
            This.Particle(i).a = This.a
         Case 2
            This.Particle(i).power = 0.5 + Rnd() * 8
            This.Particle(i).vx = Cos(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).r = Rnd() * &hFF
            This.Particle(i).g = Rnd() * &hFF
            This.Particle(i).b = Rnd() * &hFF
            This.Particle(i).a = Rnd() * &hFF
      End Select
      h += g
   Next
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 iParticles - 1           
            This.Particle(i).x = This.rocketx
            This.Particle(i).y = This.rockety
            This.set = TRUE
         Next
         This.detonate = TRUE
      End If
      For i As Ulong = 0 To iParticles - 1
         This.Particle(i).x += This.Particle(i).vx
         This.Particle(i).y += This.Particle(i).vy + fGravity
         This.Particle(i).vx *= This.power
         This.Particle(i).vy *= This.power
         This.Particle(i).a = This.life
         If This.Particle(i).a < &h80 Then
            This.Particle(i).r = &hFF * Rnd()
            This.Particle(i).g = &hFF * Rnd()
            This.Particle(i).b = &hFF * Rnd()
         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)
   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)
   For i As Ubyte = 0 To iParticlesTail - 1   
      ParticleTail(i).x = x
      ParticleTail(i).y = y
      ParticleTail(i).vx = RandomRange(-4, 4)
      ParticleTail(i).vy = Rnd() * 5
      ParticleTail(i).r = &h80
      ParticleTail(i).g = &h80
      ParticleTail(i).b = &h80
      ParticleTail(i).a = &hFF
   Next
   This.life = 50
   This.count += 1
End Sub

'--------------------------------------------------------------------------------------------------
Type _Stack
   'Private:
      As ParticleTail aStack(Any)
      As Uinteger iPos = 0
   Public:
      Declare Sub Init()
      Declare Sub Push(oPT As ParticleTail)
      Declare Function Pop() As ParticleTail
      Declare Function Count() As Uinteger
      Declare Function Get(iPos As Uinteger) As ParticleTail
End Type

Sub _Stack.Init()
   Redim This.aStack(0 To 10000) As ParticleTail
End Sub

Sub _Stack.Push(Byref oPT As ParticleTail)
   If This.iPos >= Ubound(This.aStack) Then
      Redim Preserve This.aStack(0 To This.iPos + 1000)
   End If
   This.aStack(iPos) = oPT
   This.iPos += 1
End Sub

Function _Stack.Pop() As ParticleTail
   If This.iPos > 0 Then This.iPos -= 1
   Return This.aStack(This.iPos)
End Function

Function _Stack.Get(iPos As Uinteger) As ParticleTail
   If iPos >= 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function

Function _Stack.Count() As Uinteger
   Return This.iPos
End Function

'--------------------------------------------------------------------------------------------------
Type Fireworks
   Declare Constructor(iAmount As Ubyte = 1)
   Declare Destructor()
   Declare Sub Update()
   Declare Sub Draw()
   Private:
      As Ushort amount
      As Kaboom Ptr pBuffer
      As ParticleTail Ptr pBuffer2
      As Image Ptr Img_Empty, Img_Fireworks, Img_Blur
      As _Stack Stack
End Type

Constructor Fireworks(iAmount As Ubyte)
   Img_Empty = Imagecreate(scrw, scrh, &hFF000000, 32)
   Img_Fireworks = Imagecreate(scrw, scrh, , 32)
   This.amount = iAmount
   pBuffer = New Kaboom[This.amount]
   pBuffer2 = New ParticleTail[1]
   Stack.Init()
End Constructor

Destructor Fireworks()
   Delete[] pBuffer
   Delete[] pBuffer2
   pBuffer = 0
   pBuffer2 = 0
   Imagedestroy This.Img_Empty
   Imagedestroy This.Img_Fireworks
End Destructor


Sub Fireworks.Draw()
   Put This.Img_Fireworks, (0, 0), This.Img_Empty, Pset
   For y As Ushort = 0 To This.amount - 1
      Select Case pBuffer[y].detonate
         Case False
            Circle This.Img_Fireworks, (pBuffer[y].rocketx, pBuffer[y].rockety), 2, Rgba(&hA0, &hA0, &hA0, &hF0),,,,F
            pBuffer2[0].Add(pBuffer[y].rocketx, pBuffer[y].rockety)
            Stack.Push(pBuffer2[0])         
         Case Else
           
            For i As Ulong = 0 To iParticles - 1
               Circle This.Img_Fireworks, (pBuffer[y].Particle(i).x, pBuffer[y].Particle(i).y), 1, _
                     Rgba(pBuffer[y].Particle(i).r, pBuffer[y].Particle(i).g, pBuffer[y].Particle(i).b, pBuffer[y].Particle(i).a),,,,F
               'Circle This.Img_Fireworks, (pBuffer[y].aParticle(i, 3), pBuffer[y].aParticle(i, 4)), 1, pBuffer[y].r Shl 16 Or pBuffer[y].g Shl 8 Or pBuffer[y].b Or pBuffer[y].a Shl 24,,,,F
            Next
           
      End Select
      pBuffer[y].update
   Next
   
   Dim As ParticleTail Ptr oPT
   For y As Ulong = 0 To Stack.Count() - 1
      oPT =  @Stack.aStack(y)         ''Stack.Get(y)
      If oPT->life = 0 Then Stack.pop()
      For i As Ubyte = 0 To iParticlesTail - 1
         Circle This.Img_Fireworks, (oPT->ParticleTail(i).x, oPT->ParticleTail(i).y), 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 + fGravity
         oPT->ParticleTail(i).a -= 1
      Next
      oPT->life -= 1
   Next
   
   Put (0, 0), This.Img_Fireworks, Trans
End Sub
'--------------------------------------------------------------------------------------------------




Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)

#Ifdef __Fb_win32__
   #Include "windows.bi"
   Dim tWorkingArea As RECT
   SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
   Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Endif
                             
Windowtitle "Simple Fireworks coded by UEZ"

Dim As Fireworks Firework

Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer


Do
   Screenlock
   Firework.Draw
   Draw String(0, 0), iFPS_current & " fps", Rgb(&hFF, &h00, &h00)
   Screenunlock
   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   Sleep 1
Loop Until Inkey = Chr(27)

'--------------------------------------------------------------------------------------------------
Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function


Your fireworks are beautiful. Nice.

Edit:
I am uncomfortable with ByRef returns so I opted for the previous method.
But I got it to work.
Replace the Private back in the stack
and change the 'get' function to:

Code: Select all

Declare Function Get(iPos As Uinteger) Byref As ParticleTail

Then the pointer oPT can just use the address of the return variable from get:

Code: Select all

oPT =  @Stack.Get(y)
badidea
Posts: 1545
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: How to push object to stack without loosing reference

Postby badidea » Dec 31, 2018 0:12

A bit early for fireworks, but looks cool.
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

Re: How to push object to stack without loosing reference

Postby UEZ » Dec 31, 2018 0:51

@sancho3: thx for your help. It works and I saw now the very first time the tails but it doesn't work properly. I assume the Stack.pop() doesn't work because this will remove only the last added from the stack not the current one. I have to add another function called Stack.Delete() to remove current element from stack.

Here the current version:

Code: Select all

'Fireworks alpha coded by UEZ

#Include "fbgfx.bi"
#Include "string.bi"

Using FB

Declare Function RandomRange(fStart As Single, fEnd As Single) As Single

Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85

Const iParticles = 500, iParticlesTail = 30, fGravity = 0.3333, fRad = Acos(-1) / 180

Randomize , 2



Type tagParticle
   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
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 tagParticle Particle(iParticles)
      As Ubyte r, g, b, a, rr, gg, bb, aa
      As Ulong Color
      As Ubyte KType
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 = Rnd() * 4 - 2
   This.rocketvy = -4 - Rnd() * 4
   This.heigh = scrh * 0.15 + Rnd() * (scrh * 0.30)
   This.life = 255
   This.power = 0.99 - Rnd() * 0.03
   This.r = &h80 + Rnd() * &h7F
   This.g = &h80 + Rnd() * &h7F
   This.b = &h80 + Rnd() * &h7F
   This.a = &hFF
   This.rr = &h80 + Rnd() * &h7F
   This.gg = &h80 + Rnd() * &h7F
   This.bb = &h80 + Rnd() * &h7F
   
   This.ktype = 1 'Cubyte(RandomRange(1, 2))
   
   Dim As Single h, g = 360 / (iParticles - 1), r
   For i As Ulong = 0 To iParticles - 1
      Select Case This.ktype
         Case 1
            This.Particle(i).power = 0.5 + Rnd() * 7
            This.Particle(i).vx = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Cos(h * fRad) * This.Particle(i).power
            If This.Particle(i).power > 6 - Rnd() * 2 Then
               This.Particle(i).r = This.r
               This.Particle(i).g = This.g
               This.Particle(i).b = This.b
               This.Particle(i).a = This.a
            Else
               This.Particle(i).r = This.rr
               This.Particle(i).g = This.gg
               This.Particle(i).b = This.bb
               This.Particle(i).a = This.aa
            End If
         Case 2
            This.Particle(i).power = 0.5 + Rnd() * 8
            This.Particle(i).vx = Cos(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).r = Rnd() * &hFF
            This.Particle(i).g = Rnd() * &hFF
            This.Particle(i).b = Rnd() * &hFF
            This.Particle(i).a = Rnd() * &hFF
      End Select
      h += g
   Next
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 iParticles - 1            
            This.Particle(i).x = This.rocketx
            This.Particle(i).y = This.rockety
            This.set = TRUE
         Next
         This.detonate = TRUE
      End If
      For i As Ulong = 0 To iParticles - 1
         This.Particle(i).x += This.Particle(i).vx
         This.Particle(i).y += This.Particle(i).vy + fGravity
         This.Particle(i).vx *= This.power
         This.Particle(i).vy *= This.power
         This.Particle(i).a = This.life
         If This.Particle(i).a < &h80 Then
            This.Particle(i).r = &hFF * Rnd()
            This.Particle(i).g = &hFF * Rnd()
            This.Particle(i).b = &hFF * Rnd()
         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)
   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)
   For i As Ubyte = 0 To iParticlesTail - 1   
      ParticleTail(i).x = x
      ParticleTail(i).y = y
      ParticleTail(i).vx = RandomRange(-1, 1)
      ParticleTail(i).vy = Rnd()
      ParticleTail(i).r = &h80
      ParticleTail(i).g = &h80
      ParticleTail(i).b = &h80
      ParticleTail(i).a = &hFF
   Next
   This.life = 5
   This.count += 1
End Sub

'--------------------------------------------------------------------------------------------------
Type _Stack
   Private:
      As ParticleTail aStack(Any)
      As Uinteger iPos = 0
   Public:
      Declare Constructor()
      Declare Destructor()
      Declare Sub Push(oPT As ParticleTail)
      Declare Function Pop() Byref As ParticleTail
      Declare Function Count() As Uinteger
      Declare Function Get(iPos As Uinteger) Byref As ParticleTail
End Type

Constructor _Stack()
   Redim This.aStack(0 To 1000) 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 + 1000)
   End If
   This.aStack(iPos) = oPT
   This.iPos += 1
End Sub

Function _Stack.Pop() Byref As ParticleTail
   If This.iPos > 0 Then This.iPos -= 1
   Return This.aStack(This.iPos)
End Function

Function _Stack.Get(iPos As Uinteger) Byref As ParticleTail
   If iPos >= 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function

Function _Stack.Count() As Uinteger
   Return This.iPos
End Function

'--------------------------------------------------------------------------------------------------
Type Fireworks
   Declare Constructor(iAmount As Ubyte = 1)
   Declare Destructor()
   Declare Sub Update()
   Declare Sub Draw()
   Private: 
      As Ushort amount
      As Kaboom Ptr pBuffer
      As ParticleTail Ptr pBuffer2
      As Image Ptr Img_Empty, Img_Fireworks, Img_Blur
      As _Stack Stack
End Type

Constructor Fireworks(iAmount As Ubyte)
   Img_Empty = Imagecreate(scrw, scrh, &hFF000000, 32)
   Img_Fireworks = Imagecreate(scrw, scrh, , 32)
   This.amount = iAmount
   pBuffer = New Kaboom[This.amount]
   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.Draw()
   Put This.Img_Fireworks, (0, 0), This.Img_Empty, Pset
   For y As Ushort = 0 To This.amount - 1
      Select Case pBuffer[y].detonate
         Case False
            Circle This.Img_Fireworks, (pBuffer[y].rocketx, pBuffer[y].rockety), 1, Rgba(&hA0, &hA0, &hA0, &hE0),,,,F
            If (y Mod 10) = 0 Then
               pBuffer2[0].Add(pBuffer[y].rocketx, pBuffer[y].rockety)
               Stack.Push(pBuffer2[0])      
            End If
         Case Else
            
            For i As Ulong = 0 To iParticles - 1
               Circle This.Img_Fireworks, (pBuffer[y].Particle(i).x, pBuffer[y].Particle(i).y), 1, _
                     Rgba(pBuffer[y].Particle(i).r, pBuffer[y].Particle(i).g, pBuffer[y].Particle(i).b, pBuffer[y].Particle(i).a),,,,F
               'Circle This.Img_Fireworks, (pBuffer[y].aParticle(i, 3), pBuffer[y].aParticle(i, 4)), 1, pBuffer[y].r Shl 16 Or pBuffer[y].g Shl 8 Or pBuffer[y].b Or pBuffer[y].a Shl 24,,,,F
            Next
            
      End Select
      pBuffer[y].update
   Next

   Dim As ParticleTail Ptr oPT
   For y As Ulong = 0 To Stack.Count() - 1
      oPT = @Stack.Get(y)         ''Stack.Get(y)
      If oPT->life = 0 Then
         Stack.pop()
      Else
         For i As Ubyte = 0 To iParticlesTail - 1
            Circle This.Img_Fireworks, (oPT->ParticleTail(i).x, oPT->ParticleTail(i).y), 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 + fGravity
            oPT->ParticleTail(i).a -= 1
         Next
      End If
      oPT->life -= 1
   Next

   
   Put (0, 0), This.Img_Fireworks, Trans
End Sub
'--------------------------------------------------------------------------------------------------




Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)

#Ifdef __Fb_win32__
   #Include "windows.bi"
   Dim tWorkingArea As RECT
   SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
   Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Endif
                             
Windowtitle "Simple Fireworks coded by UEZ"

Dim As Fireworks Firework = Fireworks()

Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer


Do
   Screenlock
   Firework.Draw
   Draw String(0, 0), iFPS_current & " fps", Rgb(&hFF, &h00, &h00)
   Screenunlock
   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   Sleep 1
Loop Until Inkey = Chr(27)

'--------------------------------------------------------------------------------------------------
Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function


badidea wrote:A bit early for fireworks, but looks cool.

Well, it is not finished yet and probably will not finish until new year which is in approx. 22 hours...
fxm
Posts: 9178
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: How to push object to stack without loosing reference

Postby fxm » Dec 31, 2018 6:24

A variant by declaring the local variable 'oPT' as a reference (instead of a pointer) in the member procedure 'Fireworks.Draw()':

Code: Select all

.....
   'Dim As ParticleTail Ptr oPT
   For y As Ulong = 0 To Stack.Count() - 1
      Dim Byref As ParticleTail oPT = Stack.Get(y)
      If oPT.life = 0 Then
         Stack.pop()
      Else
         For i As Ubyte = 0 To iParticlesTail - 1
            Circle This.Img_Fireworks, (oPT.ParticleTail(i).x, oPT.ParticleTail(i).y), 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 + fGravity
            oPT.ParticleTail(i).a -= 1
         Next
      End If
      oPT.life -= 1
   Next
.....
UEZ
Posts: 336
Joined: May 05, 2017 19:59
Location: Germany

Re: How to push object to stack without loosing reference

Postby UEZ » Dec 31, 2018 14:02

@fxm: thanks. This alternative looks more comfortable for my eyes. ^^

I didn't add the delete item function to the stack yet, thus the stack will grow each cycle.

Sneak preview for today midnight. ;-)

Code: Select all

'Fireworks alpha coded by UEZ

#Include "fbgfx.bi"
#Include "string.bi"

Using FB

Declare Function RandomRange(fStart As Single, fEnd As Single) As Single

Dim Shared As Integer iDW, iDH, scrw, scrh
Screencontrol GET_DESKTOP_SIZE, iDW, iDH
scrw = iDW * 0.95
scrh = iDH * 0.85

Const iParticles = 1000, iParticlesTail = 8, fGravity = 0.3333, fRad = Acos(-1) / 180

Randomize , 2



Type tagParticle
   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
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 tagParticle Particle(iParticles)
      As Ubyte r, g, b, a, rr, gg, bb, aa
      As Ulong Color
      As Ubyte KType
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 = Rnd() * 4 - 2
   This.rocketvy = -4 - Rnd() * 8
   This.heigh = scrh * 0.15 + Rnd() * (scrh * 0.30)
   This.life = 255
   This.power = 0.99 - Rnd() * 0.03
   This.r = &h80 + Rnd() * &h7F
   This.g = &h80 + Rnd() * &h7F
   This.b = &h80 + Rnd() * &h7F
   This.a = &hFF
   This.rr = &h80 + Rnd() * &h7F
   This.gg = &h80 + Rnd() * &h7F
   This.bb = &h80 + Rnd() * &h7F
   
   This.ktype = 1 'Cubyte(RandomRange(1, 2))
   
   Dim As Single h, g = 360 / (iParticles - 1), r
   For i As Ulong = 0 To iParticles - 1
      Select Case This.ktype
         Case 1
            This.Particle(i).power = 0.5 + Rnd() * 7
            This.Particle(i).vx = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Cos(h * fRad) * This.Particle(i).power
            If This.Particle(i).power > 6 - Rnd() * 2 Then
               This.Particle(i).r = This.r
               This.Particle(i).g = This.g
               This.Particle(i).b = This.b
               This.Particle(i).a = This.a
            Else
               This.Particle(i).r = This.rr
               This.Particle(i).g = This.gg
               This.Particle(i).b = This.bb
               This.Particle(i).a = This.aa
            End If
         Case 2
            This.Particle(i).power = 0.5 + Rnd() * 8
            This.Particle(i).vx = Cos(h * fRad) * This.Particle(i).power
            This.Particle(i).vy = Sin(h * fRad) * This.Particle(i).power
            This.Particle(i).r = Rnd() * &hFF
            This.Particle(i).g = Rnd() * &hFF
            This.Particle(i).b = Rnd() * &hFF
            This.Particle(i).a = Rnd() * &hFF
      End Select
      h += g
   Next
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 iParticles - 1            
            This.Particle(i).x = This.rocketx
            This.Particle(i).y = This.rockety
            This.set = TRUE
         Next
         This.detonate = TRUE
      End If
      For i As Ulong = 0 To iParticles - 1
         This.Particle(i).x += This.Particle(i).vx
         This.Particle(i).y += This.Particle(i).vy + fGravity
         This.Particle(i).vx *= This.power
         This.Particle(i).vy *= This.power
         This.Particle(i).a = This.life
         If This.Particle(i).a < &h80 Then
            This.Particle(i).r = &hFF * Rnd()
            This.Particle(i).g = &hFF * Rnd()
            This.Particle(i).b = &hFF * Rnd()
         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)
   As tagParticleTail ParticleTail(iParticlesTail - 1)
   As Ushort count
   As short life
End Type

Constructor ParticleTail()
   This.count = 0
End Constructor

Destructor ParticleTail()
End Destructor

Sub ParticleTail.Add(x As Single, y As Single)
   For i As Ubyte = 0 To iParticlesTail - 1   
      ParticleTail(i).x = x
      ParticleTail(i).y = y
      ParticleTail(i).vx = RandomRange(-0.5, 0.5)
      ParticleTail(i).vy = Rnd() * 4
      ParticleTail(i).r = &hFF
      ParticleTail(i).g = &hFF
      ParticleTail(i).b = &h80
      ParticleTail(i).a = &h80
   Next
   This.life = 20
   This.count += 1
End Sub

'--------------------------------------------------------------------------------------------------
Type _Stack
   Private:
      As ParticleTail aStack(Any)
      As Uinteger iPos = 0
   Public:
      Declare Constructor()
      Declare Destructor()
      Declare Sub Push(Byref oPT As ParticleTail)
      Declare Function Pop() Byref As ParticleTail
      Declare Function Count() As Uinteger
      Declare Function Get(iPos As Uinteger) Byref As ParticleTail
End Type

Constructor _Stack()
   Redim This.aStack(0 To 1000) 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 + 1000)
   End If
   This.aStack(iPos) = oPT
   This.iPos += 1
End Sub

Function _Stack.Pop() Byref As ParticleTail
   If This.iPos > 0 Then This.iPos -= 1
   Return This.aStack(This.iPos)
End Function

Function _Stack.Get(iPos As Uinteger) Byref As ParticleTail
   If iPos >= 0 And iPos <= Ubound(This.aStack) Then Return This.aStack(iPos)
End Function

Function _Stack.Count() As Uinteger
   Return This.iPos
End Function

'--------------------------------------------------------------------------------------------------
Type Fireworks
   Declare Constructor(iAmount As Ubyte = 1)
   Declare Destructor()
   Declare Sub Update()
   Declare Sub Draw()
   Private: 
      As Ushort amount
      As Kaboom Ptr pBuffer
      As ParticleTail Ptr pBuffer2
      As Image Ptr Img_Empty, Img_Fireworks, Img_Blur
      As _Stack Stack
End Type

Constructor Fireworks(iAmount As Ubyte)
   Img_Empty = Imagecreate(scrw, scrh, &hFF000000, 32)
   Img_Fireworks = Imagecreate(scrw, scrh, , 32)
   This.amount = iAmount
   pBuffer = New Kaboom[This.amount]
   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.Draw()
   Put This.Img_Fireworks, (0, 0), This.Img_Empty, Pset
   For y As Ushort = 0 To This.amount - 1
      Select Case pBuffer[y].detonate
         Case False
            Circle This.Img_Fireworks, (pBuffer[y].rocketx, pBuffer[y].rockety), 2, Rgba(&hA0, &hA0, &h20, &hE0),,,,F
            pBuffer2[0].Add(pBuffer[y].rocketx, pBuffer[y].rockety)
            Stack.Push(pBuffer2[0])      
         Case Else
            
            For i As Ulong = 0 To iParticles - 1
               Circle This.Img_Fireworks, (pBuffer[y].Particle(i).x, pBuffer[y].Particle(i).y), 1, _
                     Rgba(pBuffer[y].Particle(i).r, pBuffer[y].Particle(i).g, pBuffer[y].Particle(i).b, pBuffer[y].Particle(i).a),,,,F
               'Circle This.Img_Fireworks, (pBuffer[y].aParticle(i, 3), pBuffer[y].aParticle(i, 4)), 1, pBuffer[y].r Shl 16 Or pBuffer[y].g Shl 8 Or pBuffer[y].b Or pBuffer[y].a Shl 24,,,,F
            Next   
      End Select
      pBuffer[y].update
   Next

   For y As Ulong = 0 To Stack.Count() - 1
      Dim Byref As ParticleTail oPT = Stack.Get(y)
      For i As Ubyte = 0 To iParticlesTail - 1
         If oPT.life > 0 Then
            Circle This.Img_Fireworks, (oPT.ParticleTail(i).x, oPT.ParticleTail(i).y), 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 + fGravity
            oPT.ParticleTail(i).a -= 3
         End If
      Next
      oPT.life -= 1
   Next
   
   Put (0, 0), This.Img_Fireworks, Trans
End Sub
'--------------------------------------------------------------------------------------------------




Screenres (scrw, scrh, 32, 1, GFX_ALPHA_PRIMITIVES Or GFX_NO_SWITCH Or GFX_ALWAYS_ON_TOP)

#Ifdef __Fb_win32__
   #Include "windows.bi"
   Dim tWorkingArea As RECT
   SystemParametersInfo(SPI_GETWORKAREA, null, @tWorkingArea, null)
   Screencontrol SET_WINDOW_POS, (iDW - scrw) \ 2, ((tWorkingArea.Bottom - scrh) - (iDH - tWorkingArea.Bottom)) \ 2
#Endif
                             
Windowtitle "Simple Fireworks coded by UEZ"

Dim As Fireworks Firework = Fireworks(3)

Dim As Ulong i, iFPS = 0, iFPS_current = 0
Dim As Double fTimer = Timer


Do
   Screenlock
   Firework.Draw
   Draw String(0, 0), iFPS_current & " fps", Rgb(&hFF, &h00, &h00)
   Screenunlock
   If Timer - fTimer > 0.99 Then
      iFPS_current = iFPS
      iFPS = 0
      fTimer = Timer
   Else
      iFPS += 1
   Endif
   Sleep 1
Loop Until Inkey = Chr(27)

'--------------------------------------------------------------------------------------------------
Function RandomRange(fStart As Single, fEnd As Single) As Single
   Return Rnd() * (fEnd - fStart) + fStart
End Function


Have fun... ;-)
fxm
Posts: 9178
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: How to push object to stack without loosing reference

Postby fxm » Dec 31, 2018 15:25

UEZ wrote:@fxm: thanks. This alternative looks more comfortable for my eyes. ^^

That is why I reiterate my request that the reference declaration be now extended to arrays and non-static member data.
The 'Dim Byref syntax' topic could be used to discuss a possible syntax, with and without initializer (as I wish).
dodicat
Posts: 5938
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: How to push object to stack without loosing reference

Postby dodicat » Dec 31, 2018 20:04

I have no object, stacks or references, sorry, but I have straight and wobbly for the new year.

Code: Select all

Dim As Integer xres,yres
Screen 20,32,,64
Screeninfo xres,yres

Const k=1         'drag coefficient
Const g=9.81      'gravity
Const m=5         'initial mass of thing
Const d =.05      'density coefficient
Const mm=d*6^3    'explosion mass

Dim As Any Pointer im=Imagecreate(xres,yres,0)
Type v3
    As Single x,y,z
    #define cross ^
End Type
Type Line
    As v3 v1,v2
End Type

Operator * (f As Single,v1 As v3) As v3 'scalar*vector
Return Type(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator + (v1 As v3,v3 As v3) As v3
Return Type(v1.x+v3.x,v1.y+v3.y,v1.z+v3.z)
End Operator
Operator -(v1 As v3,v3 As v3) As v3
Return Type(v1.x-v3.x,v1.y-v3.y,v1.z-v3.z)
End Operator
Operator ^ (v1 As v3,v2 As v3) As v3 'cross product
Return Type<v3>(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Operator
Function length(v1 As v3) As Single
    Return Sqr(v1.x*v1.x+v1.y*v1.y+v1.z*v1.z)
End Function

Function normalize(v1 As v3) As v3
    Dim n As Single=length(v1)
    Return Type<v3>(v1.x/n,v1.y/n,v1.z/n)
End Function
'============= variables =====================
Dim As Integer w,n=900 'starting number of particles
Dim As v3 startpos,position,lastposition
Redim Shared As v3 b(),vel()
Redim Shared As Single ang()
Redim Shared As Integer red(),green(),blue()
Dim As Double pi=4*Atn(1)
Dim As Single t,y,zz,radius,theta,dist,v=180,t2
Dim As v3 eye=(1024/3,768/2,1000),temp, np1,np2
Dim As Line ctr=Type<Line>(Type<v3>(xres/2,-10000,0),Type<v3>(xres/2,10000,0))
'================= subs ===============
Function apply_perspective(p As v3,eyepoint As v3) As v3
    Dim As Single   w=1-(p.z/eyepoint.z)
    If w=0 Then w=1e-20
    Return Type<v3>((p.x-eyepoint.x)/w+eyepoint.x,(p.y-eyepoint.y)/w+eyepoint.y,(p.z-eyepoint.z)/w+eyepoint.z)
End Function

Function segdist(l As Line,p As v3,Byref ip As v3=Type(0,0,0)) As Single
    Dim As Single linelength=length(l.v1-l.v2)
    Dim As Single dist= length( (1/linelength)*((l.v1-l.v2) cross (p-l.v1)))
    If length(p-l.v1) >= length(p-l.v2) Then
        Var leg=(p-l.v1)
        Var part=Sqr(length(leg)*length(leg)-dist*dist)
        Var temp=part/linelength
        If temp>=1 Then temp=1:dist=length(p-l.v2)
        ip=l.v1+(temp)*(l.v2-l.v1)
        Return dist
    Else
        Var leg=(p-l.v2)
        Var part=Sqr(length(leg)*length(leg)-dist*dist)
        Var temp=part/linelength
        If temp>=1 Then temp=1:dist=length(p-l.v1)
        ip=l.v2+(temp)*(l.v1-l.v2)
        Return dist
    End If
    Return dist
End Function

Sub lineto(p1 As v3,p2 As v3,l As Single,Byref I As v3=Type<v3>(0,0,0))
    Dim As Single diffx=p2.x-p1.x,diffy=p2.y-p1.y,diffz=p2.z-p1.z
    Dim As Single ln=length(Type<v3>(diffx,diffy,diffz))
    Dim As v3 n=normalize(Type<v3>(diffx,diffy,diffz))
    I.x=p1.x+l*n.x
    I.y=p1.y+l*n.y
    I.z=p1.z+l*n.z
End Sub

Function GetLine(x As Long,y As Long,angle As Single,lngth As Long,col As Ulong) As Line
    Dim As Double x2=x+lngth*Cos(angle)
    Dim As Double y2=y-lngth*Sin(angle)
    Function= Type<Line>(Type<v3>(x,y,0),Type<v3>(x2,y2,0))
End Function

Function fade(fore As Ulong,back As Ulong,lim As Single,ctr As Single) As Ulong
    #define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
    Dim As Ubyte fr=Cast(Ubyte Ptr,@fore)[2],fg=Cast(Ubyte Ptr,@fore)[1],fb=Cast(Ubyte Ptr,@fore)[0]
    Dim As Ubyte br=Cast(Ubyte Ptr,@back)[2],bg=Cast(Ubyte Ptr,@back)[1],bb=Cast(Ubyte Ptr,@back)[0]
    Return Rgb(map(0,lim,ctr,fr,br),map(0,lim,ctr,fg,bg),map(0,lim,ctr,fb,bb))
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
'==================  macros ==========
#define r(f,l) Rnd * ((l) - (f)) + (f)

#macro map(a,b,x,c,d)
((d)-(c))*((x)-(a))/((b)-(a))+(c)
#endmacro

#macro combsort(array,begin,finish,dot)
Scope
    Var size=(finish),switch=0,j=0
    Dim As Single void=size
    Do
        void=void/1.3: If void<1 Then void=1
        switch=0
        For i As Integer =(begin) To size-void
            j=i+void
            If array(i)dot>array(j)dot Then
                Swap array(i),array(j): switch=1
            End If
        Next
    Loop Until  switch =0 And void=1
End Scope
#endmacro

#macro Star(starx,stary,size,col)
Scope
    Var count=0,rad=0.0,_px=0.0,_py=0.0
    For z As Single=0+.28 To 2*pi+.1+.28 Step 2*pi/10
        count=count+1
        If count Mod 2=0 Then rad=size Else rad=.5*size
        _px=starx+rad*Cos(z)
        _py=stary+rad*Sin(z)
        If count=1 Then Pset (_px,_py)Else Line -(_px,_py),col
    Next z
    Paint (starx,stary),col\2,col
End Scope
#endmacro 

#macro setup(n)
Redim b(1 To n)
Redim vel(1 To n)
Redim ang(1 To n)
Redim red(1 To n),green(1 To n),blue(1 To n)
For z As Integer=1 To n
    ang(z)=r(0,360)      'angle of each particle in explosion
    ang(z)=ang(z)*(4*Atn(1))/180'radians
    Var v1=r(10,40)
    vel(z).x=v1*Cos(ang(z))    'velocity of each particle in explosion
    vel(z).y=v1*Sin(ang(z))
    vel(z).z=r(-100,100)
    red(z)=Rnd*255
    green(z)=Rnd*255
    blue(z)=Rnd*255
Next z
#endmacro

setup(n)
'First Run
startpos=Type(300,0,0)
w=-20       'initial wind
theta=90   'initial angle
theta=theta*(4*Atn(1))/180
Dim As Long lim=100
Do
    Do
        t=t+.05 
        position.x=startpos.x+(m/k)*(1-Exp(-(k/m)*t))*(V*Cos(theta)-w)+w*t
        position.y=startpos.y+(m/k)*(1-Exp(-(k/m)*t))*(V*Sin(theta)+g*m/k)-(g*m/k)*t
        position.z=startpos.z+(m/k)*(1-Exp(-(k/m)*t))*(V*Cos(theta)-w)+w*t
        Screenlock
        Put(0,0),im,Alpha,t
        ctr= GetLine(xres/2,-10000,.0002*Sin(t*4)-pi/2,20000,Rgb(0,200,0))
        temp=apply_perspective(position,eye)
        dist=2*segdist(ctr,temp,np1)
        np1=Type<v3>(np1.x,yres-np1.y,np1.z)
        lineto(Type<v3>(temp.x,(yres-temp.y),temp.z),np1,dist,np2)
        Pset im,(np2.x+Rnd*10-Rnd*10,np2.y),Rgba(200,200,200,255)
        Circle(np2.x,np2.y),5,Rgb(255,255,255),,,,f
        Pset im,(temp.x+Rnd*10-Rnd*10,yres-temp.y),Rgba(200,200,200,255)
        Circle (temp.x,yres-temp.y),5,Rgb(255,255,255),,,,f
        Line(0,0)-(xres,yres),Rgba(0,0,0,10),bf
        If position.y<lastposition.y Then
            Screenunlock
            startpos=Type(position.x,position.y,position.z)
            t=0
            Do
                t=t+.05
                Screenlock
                For z As Integer=1 To n
                    With b(z)
                        .x=startpos.x+(mm/k)*(1-Exp(-(k/mm)*t))*(vel(z).x-w)+w*t
                        .y=startpos.y+(mm/k)*(1-Exp(-(k/mm)*t))*(vel(z).y+g*mm/k)-(g*mm/k)*t
                        .z=startpos.z+(mm/k)*(1-Exp(-(k/mm)*t))*(vel(z).z-w)+w*t
                    End With
                    If y<b(z).y Then y=b(z).y:zz=z
                Next z
               
                combsort(b,Lbound(b),Ubound(b),.z)
                t2=t
               
                If t2>12 Then t2=12
               
                ctr= GetLine(xres/2,-10000,.0002*Sin(t*4)-pi/2,20000,Rgb(0,200,0))
               
                For z As Integer=1 To Ubound(b)
                    radius=map(-500,500,b(z).z,2,10)
                    temp=apply_perspective(b(z),eye)
                    dist=2*segdist(ctr,temp,np1)
                    np1=Type<v3>(np1.x,yres-np1.y,np1.z)
                    lineto(Type<v3>(temp.x,(yres-temp.y),temp.z),np1,dist,np2)
                    Var cl=Rgb(red(z),green(z),blue(z))
                    Star(np2.x,(np2.y),(.5*radius),fade(cl,Rgb(0,0,0),13,t2))
                    Star(temp.x,(yres-temp.y),(.5*radius),fade(cl,Rgb(0,0,0),13,t2))
                Next z
                Line(0,0)-(xres,yres),Rgba(0,0,0,10),bf
                Screenunlock
                Sleep 1,1
                If Inkey=Chr(27) Then Exit Do,Do,Do
                If b(zz).y<-200 Then Exit Do,Do
            Loop
        End If
        lastposition=position
        Screenunlock
        Sleep regulate(90),1
    Loop
    Randomize
    startpos=Type(r(.2*xres,.3*xres))
    theta=r(88,92)
    theta=theta*(4*Atn(1))/180 'degrees to radians
    n=r(400,500)*2
    y=0
    w=r(-15,0)
    setup(n)
    lastposition=startpos
    Imagedestroy(im)
    im=Imagecreate(xres,yres,0)
    t=0
Loop Until Inkey=Chr(27)
Imagedestroy(im)


 
D.J.Peters
Posts: 7825
Joined: May 28, 2005 3:28

Re: How to push object to stack without loosing reference

Postby D.J.Peters » Jan 01, 2019 4:14

@dodicat damn no sound :-(

Return to “General”

Who is online

Users browsing this forum: No registered users and 3 guests