How to push object to stack without loosing reference

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

How to push object to stack without loosing reference

Post by UEZ »

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

Post by sancho3 »

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: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: How to push object to stack without loosing reference

Post by badidea »

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

Re: How to push object to stack without loosing reference

Post by UEZ »

@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
Moderator
Posts: 12081
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: How to push object to stack without loosing reference

Post by fxm »

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: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: How to push object to stack without loosing reference

Post by UEZ »

@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
Moderator
Posts: 12081
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: How to push object to stack without loosing reference

Post by fxm »

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: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: How to push object to stack without loosing reference

Post by dodicat »

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: 8586
Joined: May 28, 2005 3:28
Contact:

Re: How to push object to stack without loosing reference

Post by D.J.Peters »

@dodicat damn no sound :-(
Post Reply