particle system

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
dafhi
Posts: 1258
Joined: Jun 04, 2005 9:51

particle system

Postby dafhi » Sep 22, 2010 14:25

Code: Select all

#include "fbgfx.bi"
'#Include "ArrayedLL_Handler.bi"

'=================-------------------------------------===+
' ArrayedLL_Handler.bi | Author: cRex  Sept 22 - 20100922 '
' Release 0.01 beta                                       '
'========----------------------------------------=+=======+
' Description:  Linked List using plain array     '
' Starting element: 1                             '
'==-------------------------------------==========+

'' -- Typical scenario begin -- '
''
''   - Regular -
''Dim Shared As Particle PartAry()
''Dim Shared As ParticleGroup PartGroup
''   - List -
''Dim Shared As ListArrayInfo ListInfo
''Dim Shared As ListArrayElement ListAry()
''
''   - Initialize -
''Sub DimParticles(ByVal Count As Integer, AvgLifeTime As single = 10, Lifetime_Variance As Single = 2, PartAry() As Particle, ListAry() As ListArrayElement, ListInfo As ListArrayInfo)
''Dim ReturnString As String
''    ReDim PartAry(1 To Count)
''    ReturnString = ArrayedLL_Init (Count, ListAry(), ListInfo)
''End Sub
''
''   - Program Start -
''Dim As UInteger I, SaveUsed_
''    ListInfo.Posi = ListInfo.Head
''    SaveUsed_ = ListInfo.Used
''    For I = 1 To SaveUsed_
''        With PartAry(ListInfo.Posi)
''            .age += time_delta
''            If .age > .lifetime Then
''                ArrayedLL_Remove (ListAry(), ListInfo)
''            Else
''                .px += .dx * time_delta
''                .py += .dy * time_delta
''                ListInfo.Posi = ListAry(ListInfo.Posi).Nxt
''            EndIf
''        End With
''    Next

'''    .. and for Insert, just call, and new .Posi is ready

''        ArrayedLL_Insert ListAry(ListInfo.Posi), ListInfo
''        With PartAry(ListInfo.Posi)

'' -- Typical scenario end -- '

Const As UInteger CONST_LL_MAXSIZE = 999999

Type ListArrayElement
    As UInteger Prv, Nxt
End Type

Type ListArrayInfo
    As UInteger Size, Used, Posi, Head, Tail
End Type

Dim Shared As UInteger mNewGuy_, mElem_
Function ArrayedLL_Init(ByVal pSiz As UInteger, pListAry_() As ListArrayElement, pListInfo_ As ListArrayInfo) As String
Dim PadElements As UInteger
   
    If pSiz < 1 Or pSiz > CONST_LL_MAXSIZE Then
        Return "1 > pSiz <= " & CONST_LL_MAXSIZE
        Exit Function
    EndIf
           
    If pSiz = 2 Then PadElements = 1
    pSiz = pSiz + PadElements
   
    Erase pListAry_
    ReDim pListAry_(1 To pSiz)
   
    For mElem_ = 1 To pSiz
        pListAry_(mElem_).Prv = mElem_ - 1
        pListAry_(mElem_).Nxt = mElem_ + 1
    Next
    pListAry_(1).Prv = pSiz
    pListAry_(pSiz).Nxt = 1

    pListInfo_.Size = pSiz - PadElements

    pListInfo_.Head = 2
    pListInfo_.Tail = 1
   
    pListInfo_.Posi = pListInfo_.Head
    pListInfo_.Used = 0

    Return "Success"

End Function

'=======---------------------------------------------==='
'                                                       '
'   common to ArrayedLL_Remove and ArrayedLL_Insert     '
'                                                       '
'===---------------------------------------------======='
Private Sub zNewNeighborNetwork(pNewGuy_P As UInteger, pNewGuy_N As UInteger, pAry() As ListArrayElement, pCurr As ListArrayElement)
   
    pAry(pNewGuy_P).Nxt = pNewGuy_N    'former neighbors of mNewGuy_ connect with each other
    pAry(pNewGuy_N).Prv = pNewGuy_P
   
    pAry(pCurr.Prv).Nxt = mNewGuy_    'NewGuy_ moving in. "current's first neighbor" ..
    pAry(mNewGuy_).Prv = pCurr.Prv    ' .. becomes "mNewGuy_'s first neighbor
   
    pAry(mNewGuy_).Nxt = mElem_        'mElem_ = "current"
    pCurr.Prv = mNewGuy_

End Sub
Private Sub zNewNeighbors(pAry() As ListArrayElement, pCurr As ListArrayElement)
    zNewNeighborNetwork pAry(mNewGuy_).Prv, pAry(mNewGuy_).Nxt, pAry(), pCurr
End Sub

Sub ArrayedLL_Remove(pListAry_() As ListArrayElement, pList_ As ListArrayInfo)
    If pList_.Used > 0 Then
        If pList_.Posi = pList_.Head Then
            pList_.Head = pListAry_(pList_.Posi).Nxt
            pList_.Posi = pList_.Head
        Else
            If pList_.Posi = pList_.Tail Then
                pList_.Tail = pListAry_(pList_.Tail).Prv
                pList_.Posi = pList_.Tail
            Else
                mElem_ = pListAry_(pList_.Tail).Nxt
                If pList_.Posi = mElem_ Then 'Rare condition.. cursor is at (.Tail).Nxt ..
                    pList_.Posi = pList_.Tail 'So adjust position
                Else
                    mNewGuy_ = pList_.Posi
                    pList_.Posi = pListAry_(pList_.Posi).Nxt
                    zNewNeighbors pListAry_(), pListAry_(mElem_)
                EndIf
            End If
        EndIf
        pList_.Used = pList_.Used - 1
    End If
End Sub
Sub ArrayedLL_Insert(pListAry_() As ListArrayElement, pList_ As ListArrayInfo)
    If pList_.Used < pList_.Size Then
        If pList_.Posi = pList_.Head Then
            pList_.Head = pListAry_(pList_.Posi).Prv
            pList_.Posi = pList_.Head
        Else
            mNewGuy_ = pListAry_(pList_.Tail).Nxt
            If pList_.Posi = mNewGuy_ Then ''Append
                pList_.Tail = mNewGuy_
            Else
              mElem_ = pList_.Posi
              zNewNeighbors pListAry_(), pListAry_(pList_.Posi)
                pList_.Posi = mNewGuy_
            EndIf
        EndIf
        pList_.Used = pList_.Used + 1
    End If
End Sub
' ArrayedLL_Handler.bi end --------- '

    using FB
   
Const As Integer SCR_W = 480
Const As Integer SCR_H = 360
Const As Integer MidX = SCR_W / 2, MidY = SCR_H / 2
Const As Integer WidM = SCR_W - 1, HgtM = SCR_H - 1

Dim Shared e as EVENT

Type Particle
    As Single px,py,dx,dy
    As Integer lifetime, age
    As Uinteger rgbcol
End Type
Type ParticleGroup
    As Integer Count, AvgLifeTime, Lifetime_Variance
    As Single px,py
End Type
Dim Shared As Particle PartAry()            'Particles
Dim Shared As ParticleGroup PartGroup
Dim Shared As ListArrayInfo ListInfo        'List
Dim Shared As ListArrayElement ListAry()

Dim Shared As Integer delta_time, starting_time, primary_time, prev_time

Dim Shared As Single pi = 4 * Atn(1), TwoPi = 8 * Atn(1)
Dim Shared As Integer  I, Nozzle

Sub DimParticles(Byval Count As Integer, AvgLifeTime As Single = 10, Lifetime_Variance As Single = 2, PGroup As ParticleGroup, PartAry() As Particle, ListAry() As ListArrayElement, ListInfo As ListArrayInfo)
Dim StragglersAllocation As Integer = 15, ReturnString As String
    PGroup.AvgLifeTime = AvgLifeTime * 1000
    PGroup.Lifetime_Variance = Lifetime_Variance * 1000
    PGroup.Count = Count 'flow rate based on Count
    PGroup.px = MidX
    PGroup.py = MidY
    Count += StragglersAllocation
    Redim PartAry(1 To Count)
    ReturnString = ArrayedLL_Init (Count, ListAry(), ListInfo)
End Sub
Sub NewParticle(PartAry() As Particle, ListAry() As ListArrayElement, ListInfo As ListArrayInfo, PGroup As ParticleGroup)
Dim As Single velocity, angle, temporal_dither
    If ListInfo.Used < ListInfo.Size Then
        velocity = .05 * (2 + Rnd)
        angle = Rnd * TwoPi       
        temporal_dither = Rnd * delta_time
        ArrayedLL_Insert ListAry(), ListInfo
        With PartAry(ListInfo.Posi)
            .age = temporal_dither
            .LifeTime = PGroup.AvgLifeTime + (Rnd - 0.5) * PGroup.Lifetime_Variance
            .dx = velocity * Cos(angle)
            .dy = velocity * Sin(angle)
            .px = PGroup.px + .dx * temporal_dither
            .py = PGroup.py + .dy * temporal_dither
            .rgbcol = 16777216 * Rnd
        End With
    End If
End Sub

Sub doRender()
Dim buffer As Uinteger Ptr
Dim As Integer x, y, SaveUsed_
Dim As UInteger pitch
    pitch = SCR_W * Len(Integer)
    ListInfo.Posi = ListInfo.Head
    SaveUsed_ = ListInfo.Used
    For I = 1 To SaveUsed_
        With PartAry(ListInfo.Posi)
            x = .px
            y = .py
            If x > -1 And x < SCR_W Then
                If y > -1 And y < SCR_H Then
                    buffer = ScreenPtr + y * pitch + x * Len( Integer )
                    *buffer = .rgbcol
                End If
            End If
            .age += delta_time ''Shared
            If .age > .lifetime Then
                ArrayedLL_Remove (ListAry(), ListInfo)
            Else
                .px += .dx * delta_time
                .py += .dy * delta_time   
                ListInfo.Posi = ListAry(ListInfo.Posi).Nxt
            Endif
        End With
    Next
End Sub

Dim As Integer NumParticles = 25000
Dim As Single LifetimeAverage = .1, LifetimeVariance = 11.0

DimParticles NumParticles, LifetimeAverage, LifetimeVariance, PartGroup,PartAry(),ListAry(), ListInfo

ScreenRes SCR_W, SCR_H,32,,&h20
Do
    prev_time = primary_time
''    primary_time = some_high_resolution_timer
    delta_time = 10 'primary_time - prev_time
    Nozzle = (Rnd - 0.5 + delta_time * PartGroup.Count / PartGroup.AvgLifeTime)
    For I = 1 To Nozzle ''(Rnd - 0.5) ensures dithered time distribution
        NewParticle PartAry(), ListAry(), ListInfo, PartGroup
    Next
    ScreenLock
    Cls
    doRender
    screenUnlock
    if (screenevent(@e)) then
        select case e.type
        case EVENT_KEY_PRESS
            if (e.scancode = SC_ESCAPE) then
                end
            end If
        End Select
    End if
    Sleep 6 ''let os breathe
Loop
Last edited by dafhi on Aug 05, 2016 23:09, edited 21 times in total.
rolliebollocks
Posts: 2655
Joined: Aug 28, 2008 10:54
Location: new york

Postby rolliebollocks » Sep 22, 2010 15:37

Nice!
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Postby kiyotewolf » Sep 23, 2010 9:20

SDL.DLL not found.

[EDIT]

Google is your friend. Nvm.

[EDIT 2MORE]

http://www.emulator-zone.com/doc.php/psp/pspe.html
dafhi
Posts: 1258
Joined: Jun 04, 2005 9:51

Postby dafhi » Sep 23, 2010 13:42

in-code comment added. thanks

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests