Particle Picasso

Share your advanced PureBasic knowledge/code with the community.
User avatar
Hroudtwolf
Addict
Addict
Posts: 803
Joined: Sat Feb 12, 2005 3:35 am
Location: Germany(Hessen)
Contact:

Particle Picasso

Post by Hroudtwolf »

A little particlefun by Hellhound, Hades and myself.

Code: Select all

; Particle Picasso
; 2006 Hroudtwolf
; PureBasic-Lounge.de
; PureBasic Version 4.00
; slightly modified by Hades, Hellhound


#D3DBLEND_ZERO            = 1
#D3DBLEND_ONE             = 2
#D3DBLEND_SRCCOLOR        = 3
#D3DBLEND_INVSRCCOLOR     = 4
#D3DBLEND_SRCALPHA        = 5
#D3DBLEND_INVSRCALPHA     = 6
#D3DBLEND_DESTALPHA       = 7
#D3DBLEND_INVDESTALPHA    = 8
#D3DBLEND_DESTCOLOR       = 9
#D3DBLEND_INVDESTCOLOR    = 10
#D3DBLEND_SRCALPHASAT     = 11
#D3DBLEND_BOTHSRCALPHA    = 12
#D3DBLEND_BOTHINVSRCALPHA = 13



If InitSprite() = 0 Or InitSprite3D() = 0 Or InitKeyboard() = 0 Or InitMouse() = 0
  MessageRequester("Fehler", "Dein System ist doof.", 0)
  End
EndIf


Structure _ParticlesStruct
  x.l
  y.l
  intens.l 
  ruin.l
  size.l
  smoke.l
EndStructure
Global NewList ParticleList._ParticlesStruct()



Declare CreateParticlesOnMouse (x.l,y.l)
Declare DisplayParticles()


#GrundSprite_0=1
#GrundSprite_1=2
#Sprite3D_0=1
#Sprite3D_1=2

If OpenScreen(1024, 768, 32, "Smooth particles")


  If CreateSprite (#GrundSprite_0,16,16,#PB_Sprite_Texture)
    If StartDrawing(SpriteOutput(#GrundSprite_0))
      For Y.l = -7 To 7
        For X.l = -7 To 7
          d.f = Sqr(X*X + Y*Y)
          If d<7.0
            d = 7.0 - d
            Plot(7+X,7+Y,RGB(32*d,4*d,d))
          EndIf
        Next
      Next
      StopDrawing()
    EndIf
    CreateSprite3D(#Sprite3D_0,#GrundSprite_0)
    
  EndIf   
 
 
  If CreateSprite (#GrundSprite_1,16,16,#PB_Sprite_Texture)
    If StartDrawing(SpriteOutput(#GrundSprite_1))
           For x=1 To 15
             gray.l=Random (40)
             Circle(5+Random(6),5+Random(6),Random (6),RGB(gray.l+5,gray.l,gray.l+10))
           Next x
      StopDrawing()
    EndIf
    CreateSprite3D(#Sprite3D_1,#GrundSprite_1)
  EndIf   


Sprite3DQuality(1)

  Repeat   
    FlipBuffers()   
    ClearScreen($000000)
   
    ExamineMouse ()
    MsX.l=MouseX()
    MsY.l=MouseY()
   
    CreateParticlesOnMouse (MsX.l,MsY.l)
    DisplayParticles()

   
   
    ExamineKeyboard()
    Delay (1)
  Until KeyboardPushed(#PB_Key_Escape)
 

EndIf

End   



Procedure CreateParticlesOnMouse (x.l,y.l)
    If CountList (ParticleList())<1000
      For z=1 To 10+Random(50)
        AddElement (ParticleList())
        ParticleList()\x=x.l+(-6+Random(12))
        ParticleList()\y=y.l+(-6+Random(12))
        ParticleList()\intens=255-Random(100)
        ParticleList()\ruin=1+Random(15)
        ParticleList()\size=Random(16)
        ParticleList()\smoke=Random(1)
      Next z
    EndIf
EndProcedure


Procedure DisplayParticles()
   Start3D()
   Sprite3DBlendingMode(#D3DBLEND_SRCALPHA, #D3DBLEND_ONE)
     ForEach ParticleList()
           
        If ParticleList()\smoke=1
          ZoomSprite3D (#Sprite3D_1,4+ParticleList()\size,4+ParticleList()\size+Random(3))  
          DisplaySprite3D (#Sprite3D_1,ParticleList()\x,ParticleList()\y,Int(ParticleList()\intens/4)) 
          fleet.l=Int(ParticleList()\ruin/2)
          If fleet.l<1:fleet.l=1:EndIf 
          ParticleList()\y-fleet.l
          ParticleList()\x+(-2+(Random(4)))
        Else
         ZoomSprite3D (#Sprite3D_1,4+ParticleList()\size,4+ParticleList()\size+Random(3))  
         DisplaySprite3D (#Sprite3D_0,ParticleList()\x,ParticleList()\y,ParticleList()\intens)
         ParticleList()\y+ParticleList()\ruin
        EndIf     
        
        If ParticleList()\y>1024:DeleteElement (ParticleList()):EndIf     
        ParticleList()\intens-ParticleList()\ruin
        If ParticleList()\intens<0:DeleteElement (ParticleList()):EndIf       
     Next
   Stop3D()
EndProcedure
va!n
Addict
Addict
Posts: 1104
Joined: Wed Apr 20, 2005 12:48 pm

Post by va!n »

very nice work! esp the smoke looks very realistic ;)
va!n aka Thorsten

Intel i7-980X Extreme Edition, 12 GB DDR3, Radeon 5870 2GB, Windows7 x64,
Intrigued
Enthusiast
Enthusiast
Posts: 501
Joined: Thu Jun 02, 2005 3:55 am
Location: U.S.A.

Post by Intrigued »

Right on cool!
Intrigued - Registered PureBasic, lifetime updates user
User avatar
NoahPhense
Addict
Addict
Posts: 1999
Joined: Thu Oct 16, 2003 8:30 pm
Location: North Florida

Re: Particle Picasso

Post by NoahPhense »

That's freakin great..

Nice work.. wanna see more! ;)

- np
rsts
Addict
Addict
Posts: 2736
Joined: Wed Aug 24, 2005 8:39 am
Location: Southwest OH - USA

Post by rsts »

Nice indeed.

Thanks for sharing with us.

cheers
User avatar
Hroudtwolf
Addict
Addict
Posts: 803
Joined: Sat Feb 12, 2005 3:35 am
Location: Germany(Hessen)
Contact:

Post by Hroudtwolf »

Thanks.

Now you can burn holes in your screen :D

Code: Select all


; Partikel Picasso
; 2006 Hroudtwolf
; PureBasic-Lounge.de
; PureBasic Version 4.00
; slightly modified by Hades, Hellhound & Hroudtwolf


#D3DBLEND_ZERO            = 1
#D3DBLEND_ONE             = 2
#D3DBLEND_SRCCOLOR        = 3
#D3DBLEND_INVSRCCOLOR     = 4
#D3DBLEND_SRCALPHA        = 5
#D3DBLEND_INVSRCALPHA     = 6
#D3DBLEND_DESTALPHA       = 7
#D3DBLEND_INVDESTALPHA    = 8
#D3DBLEND_DESTCOLOR       = 9
#D3DBLEND_INVDESTCOLOR    = 10
#D3DBLEND_SRCALPHASAT     = 11
#D3DBLEND_BOTHSRCALPHA    = 12
#D3DBLEND_BOTHINVSRCALPHA = 13



If InitSprite() = 0 Or InitSprite3D() = 0 Or InitKeyboard() = 0 Or InitMouse() = 0
  MessageRequester("Fehler", "Dein System ist doof.", 0)
  End
EndIf



 
Structure _ParticlesStruct
  x.l
  y.l
  intens.l 
  ruin.l
  size.l
  smoke.l
EndStructure
Global NewList ParticleList._ParticlesStruct()



Declare CreateParticlesOnMouse (x.l,y.l)
Declare DisplayParticles()
Declare Movement ()

#Hintergrund=0
#GrundSprite_0=1
#GrundSprite_1=2
#Sprite3D_0=1
#Sprite3D_1=2

If OpenScreen(1024, 768, 32, "Smooth particles")
   
   
  If CreateSprite (#Hintergrund,1024,768)
     If StartDrawing (SpriteOutput (#Hintergrund))
        Box(0,0,1024,768,$165AAC)
        For x=1 To 1024 Step 2
           Line (x,0,0,768,$124268)
        Next x
     StopDrawing ()
     EndIf 
     Else
     End
  EndIf  
   

  If CreateSprite (#GrundSprite_0,16,16,#PB_Sprite_Texture)
    If StartDrawing(SpriteOutput(#GrundSprite_0))
      For Y.l = -7 To 7
        For X.l = -7 To 7
          d.f = Sqr(X*X + Y*Y)
          If d<7.0
            d = 7.0 - d
            Plot(7+X,7+Y,RGB(32*d,4*d,d))
          EndIf
        Next
      Next
      StopDrawing()
    EndIf
    CreateSprite3D(#Sprite3D_0,#GrundSprite_0)
    Else
     End
  EndIf   
 
 
  If CreateSprite (#GrundSprite_1,16,16,#PB_Sprite_Texture)
    If StartDrawing(SpriteOutput(#GrundSprite_1))
           For x=1 To 15
             gray.l=Random (40)
             Circle(5+Random(6),5+Random(6),Random (6),RGB(gray.l+5,gray.l,gray.l+10))
           Next x
      StopDrawing()
    EndIf
    CreateSprite3D(#Sprite3D_1,#GrundSprite_1)
    Else
    End
  EndIf   


Sprite3DQuality(1)

  Repeat   
    FlipBuffers()   
    ClearScreen($000000)
    DisplaySprite (#Hintergrund,0,0)
    
    
    ExamineMouse ()
    MsX.l=MouseX()
    MsY.l=MouseY()

    CreateParticlesOnMouse (MsX.l,MsY.l)
    DisplayParticles()

   
   
    ExamineKeyboard()
    Delay (1)
  Until KeyboardPushed(#PB_Key_Escape)
 

EndIf

End   



Procedure CreateParticlesOnMouse (x.l,y.l)
    If CountList (ParticleList())<1000
      For z=1 To 10+Random(50)
        AddElement (ParticleList())
        ParticleList()\x=x.l+(-6+Random(12))
        ParticleList()\y=y.l+(-6+Random(12))
        ParticleList()\intens=255-Random(100)
        ParticleList()\ruin=1+Random(15)
        ParticleList()\size=Random(16)
        ParticleList()\smoke=Random(1)
        If StartDrawing (SpriteOutput (#Hintergrund))
           If ParticleList()\x>0 And ParticleList()\x<1023 And ParticleList()\y>0 And ParticleList()\y<768              
              heat.l=2+Random(10)
              Offset.l=5+Random(5)
              Color.l=Point(ParticleList()\x+Offset.l,ParticleList()\y+Offset.l)
              NewRed.l=Red(Color.l)-heat.l:NewGreen.l=Green(Color.l)-heat.l:NewBlue.l=Blue(Color.l)-heat.l              
              If NewRed.l<0:NewRed.l=0:EndIf 
              If NewGreen.l<0:NewGreen.l=0:EndIf 
              If NewBlue.l<0:NewBlue.l=0:EndIf 
              Circle (ParticleList()\x+Offset.l,ParticleList()\y+Offset.l,Random(2),RGB(NewRed.l,NewGreen.l,NewBlue.l))
           EndIf 
           StopDrawing ()
        EndIf 
      Next z
    EndIf
EndProcedure


Procedure DisplayParticles()
   Start3D()
   Sprite3DBlendingMode(#D3DBLEND_SRCALPHA, #D3DBLEND_ONE)
     ForEach ParticleList()
           
        If ParticleList()\smoke=1
          ZoomSprite3D (#Sprite3D_1,4+ParticleList()\size,4+ParticleList()\size+Random(3))  
          DisplaySprite3D (#Sprite3D_1,ParticleList()\x,ParticleList()\y,Int(ParticleList()\intens/4)) 
          fleet.l=Int(ParticleList()\ruin/2)
          If fleet.l<1:fleet.l=1:EndIf 
          ParticleList()\y-fleet.l
          ParticleList()\x+(-2+(Random(4)))
        Else
         ZoomSprite3D (#Sprite3D_1,4+ParticleList()\size,4+ParticleList()\size+Random(3))  
         DisplaySprite3D (#Sprite3D_0,ParticleList()\x,ParticleList()\y,ParticleList()\intens)
         ParticleList()\y+ParticleList()\ruin
        EndIf     
        
        If ParticleList()\y>1024:DeleteElement (ParticleList()):EndIf     
        ParticleList()\intens-ParticleList()\ruin
        If ParticleList()\intens<0:DeleteElement (ParticleList()):EndIf       
     Next
   Stop3D()
EndProcedure
SCRJ
User
User
Posts: 93
Joined: Sun Jan 15, 2006 1:36 pm

Post by SCRJ »

Great! :D
rsts
Addict
Addict
Posts: 2736
Joined: Wed Aug 24, 2005 8:39 am
Location: Southwest OH - USA

Post by rsts »

Really cool -

(but) - after my daughter was "testing" it for a few minutes -

(ERROR) Line:181
(ERROR) The linked list doesn't have a current element.


cheers
va!n
Addict
Addict
Posts: 1104
Joined: Wed Apr 20, 2005 12:48 pm

Post by va!n »

again very very cool one!
remembers me on the intro sequence by factor5 (turrican) on amiga ;-)
va!n aka Thorsten

Intel i7-980X Extreme Edition, 12 GB DDR3, Radeon 5870 2GB, Windows7 x64,
Fred
Administrator
Administrator
Posts: 18162
Joined: Fri May 17, 2002 4:39 pm
Location: France
Contact:

Post by Fred »

Nice one !
User avatar
Hroudtwolf
Addict
Addict
Posts: 803
Joined: Sat Feb 12, 2005 3:35 am
Location: Germany(Hessen)
Contact:

Post by Hroudtwolf »

Thank you at all !
Image
Post Reply