[pbcode]
Type tParticle
Shape
X#
Y#
ScaleX#
ScaleY#
Time
MaxTime
Colour
EndType
Dim Parts(1) as tParticle
Do
Cls 0
lockbuffer
For lp=1 to GetArrayelements(Parts(),1)
if Parts(lp)
if Parts(lp).time<Parts(lp).Maxtime
Parts(lp).time=Parts(lp).time+1
C=Parts(lp).Colour
C=rgbfade(c,150-(100.0/Parts(lp).Maxtime)*Parts(lp).time)
ink c
x#=parts(lp).x
y#=parts(lp).y
sx#=parts(lp).Scalex+0.25
sy#=parts(lp).Scaley+0.25
Shape=parts(lp).shape
RotateShapeXY Shape,Angle#,SX#,Sy#
drawshape shape,x#,y#,0
parts(lp).Scalex=sx#
parts(lp).Scaley=sy#
else
DeleteParticles(lp)
endif
endif
next
unlockbuffer
if Spacekey()
x#=rnd(800)
y#=rnd(600)
AddParticles(x#,y#,rndrange(10,36))
; flushkeys
endif
Sync
loop
Function DeleteParticles(index)
DeleteShape Parts(index).shape
Parts(Index)=null
EndFunction
Function AddParticles(x#,y#,POints)
index=GetFreeCell(Parts())
Parts(index).x=x#
Parts(index).y=y#
Parts(index).scalex=1
Parts(index).scaley=1
Parts(index).colour=rndrgb()
Parts(index).Maxtime=150
Parts(index).time=0
Shape=NewShape(Points,POints)
angleStep#=360.0/points
For lp=0 to points-1
angle#=wrapangle(angle#,anglestep#)
radius=rnd(10)
SetShapeVertex Shape,lp,cosRadius(angle#,radius),SinRadius(angle#,radius)
SetShapeEdge Shape,lp,lp,lp
next
Parts(index).Shape=Shape
EndFunction
[/pbcode]
Related Examples: * Shape Star Field (https://www.underwaredesign.com/forums/index.php?topic=3568.0)
* 8Way Layered Star Field / Asteroids Style (https://www.underwaredesign.com/forums/index.php?topic=3837.0)
* Into the Light (Shape Tunnel Variant) (https://www.underwaredesign.com/forums/index.php?topic=3921.0)
This version using alpha addition + alpha sub to create the blur.
[pbcode]
#include "BlitIMage"
OpenScreen 800,600,16,2
MakeBitmapfont 1,$ffffff
Type tParticle
Shape
X#
Y#
ScaleX#
ScaleY#
Time
MaxTime
Colour
EndType
Dim Parts(1) as tParticle
CreateFXimage 1,GetScreenWidth(),GetScreenHeight()
Do
rendertoimage 1
inkmode 1+32
angle#=angle#+2
ActiveShapes=0
VertCount=0
lockbuffer
For lp=1 to GetArrayelements(Parts(),1)
if Parts(lp)
if Parts(lp).time<Parts(lp).Maxtime
Parts(lp).time=Parts(lp).time+1
C=Parts(lp).Colour
ink rgbfade(c,170-(100.0/Parts(lp).Maxtime)*Parts(lp).time)
x#=parts(lp).x
y#=parts(lp).y
sx#=parts(lp).Scalex+0.5
sy#=parts(lp).Scaley+0.5
Shape=parts(lp).shape
RotateShapeXY Shape,Angle#,SX#,Sy#
drawshape shape,x#,y#,0
parts(lp).Scalex=sx#
parts(lp).Scaley=sy#
VertCount=VertCount+GetShapeVerts(Shape,0)
Inc ActiveShapes
else
DeleteParticles(lp)
endif
endif
next
unlockbuffer
For lp=1 to 3
x#=rnd(GetScreenWidth() )
y#=rnd(GetScreenHeight() )
AddParticles(x#,y#,rndrange(20,50))
next
mx=mousex()
my=mousey()
if MouseButton()
AddParticles(mx,my,rndrange(20,75))
endif
rendertoimage 0
BlitImageAlphaSubColour(1,0,0,rgb(11,11,11))
setcursor 0,0
ink $ffffff
inkmode 1
print "Fps:"+str$(fps())
print "Points:"+str$(vertcount)
print "Shapes:"+str$(ActiveShapes)
Circle mx,my,10,false
Sync
loop
Function DeleteParticles(index)
DeleteShape Parts(index).shape
Parts(Index)=null
EndFunction
Function AddParticles(x#,y#,POints)
index=GetFreeCell(Parts())
Parts(index).x=x#
Parts(index).y=y#
Parts(index).scalex=1
Parts(index).scaley=1
Parts(index).colour=rndrgb()
Parts(index).Maxtime=125
Parts(index).time=0
Shape=NewShape(Points,POints)
angleStep#=360.0/points
For lp=0 to points-1
angle#=wrapangle(angle#,anglestep#)
radius=rndrange(1,10)
SetShapeVertex Shape,lp,cosRadius(angle#,radius),SinRadius(angle#,radius)
SetShapeEdge Shape,lp,lp,lp
next
Parts(index).Shape=Shape
EndFunction
[/pbcode]
Impressive - I get 109FPS for the second demo.
Yours demos recently have certainly highlighted my lack of understanding of the PB language and what it is capable of :(
QuoteYours demos recently have certainly highlighted my lack of understanding of the PB language and what it is capable of
Well, it's not like your not the only one :)
This version is a bit like a fireworks display.
[pbcode]
OpenScreen 800,600,16,2
MakeBitmapfont 1,$ffffff
; Setfps 100
#include "BlitIMage"
Type tParticle
Shape
X#
Y#
ScaleX#
ScaleY#
Time
MaxTime
Colour
EndType
Dim Parts(1) as tParticle
CreateFXimage 1,GetScreenWidth(),GetScreenHeight()
Do
rendertoimage 1
inkmode 1+64
lockbuffer
For lp=1 to GetArrayelements(Parts(),1)
if Parts(lp)
if Parts(lp).time<Parts(lp).Maxtime
Parts(lp).time=Parts(lp).time+1
C=Parts(lp).Colour
ink rgbfade(c,125-(100.0/Parts(lp).Maxtime)*Parts(lp).time)
x#=parts(lp).x
y#=parts(lp).y
sx#=parts(lp).Scalex+0.25
sy#=parts(lp).Scaley+0.25
Shape=parts(lp).shape
RotateShapeXY Shape,Angle#,SX#,Sy#
drawshape shape,x#,y#,0
parts(lp).Scalex=sx#
parts(lp).Scaley=sy#
else
DeleteParticles(lp)
endif
endif
next
unlockbuffer
if Nexttime=0
x#=rnd(GetScreenWidth() )
y#=rnd(GetScreenHeight() )
For lp=1 to 5
AddParticles(x#,y#,rndrange(75,500))
next
nexttime=10
endif
dec nexttime
rendertoimage 0
BlitImageAlphaSubColour(1,0,0,rgb($10,$10,$10))
ink $ffffff
inkmode 1
text 10,10,fps()
Sync
loop
Function DeleteParticles(index)
DeleteShape Parts(index).shape
Parts(Index)=null
EndFunction
Function AddParticles(x#,y#,POints)
index=GetFreeCell(Parts())
Parts(index).x=x#
Parts(index).y=y#
Parts(index).scalex=1
Parts(index).scaley=1
Parts(index).colour=rndrgb()
Parts(index).Maxtime=125
Parts(index).time=0
Shape=NewShape(Points,POints)
angleStep#=360.0/points
For lp=0 to points-1
angle#=wrapangle(angle#,anglestep#)
radius#=rndrange#(1,10)
SetShapeVertex Shape,lp,cosRadius(angle#,radius#),SinRadius(angle#,radius#)
SetShapeEdge Shape,lp,lp,lp
next
Parts(index).Shape=Shape
EndFunction
[/pbcode]
Particle Sprinkler This is variation of the particle shape demos above and is rendering around 34,500 alpha addition dot particles.
The example was written in PBFX 1.68 (or so) but will work in old versions also (just slower)
[pbcode]
OpenScreen 800,600,16,2
#include "BlitIMage"
Type tParticle
Shape
X#
Y#
ScaleX#
ScaleY#
Time
MaxTime
Colour
EndType
Dim Parts(1) as tParticle
CreateFXimage 1,GetScreenWidth(),GetScreenHeight()
Do
;cls 0
rendertoimage 1
inkmode 1+64
;inkmode 10
Vertcount=0
lockbuffer
For lp=1 to GetArrayelements(Parts(),1)
if Parts(lp)
if Parts(lp).time<Parts(lp).Maxtime
Parts(lp).time=Parts(lp).time+1
C=Parts(lp).Colour
ink rgbfade(c,125-(100.0/Parts(lp).Maxtime)*Parts(lp).time)
x#=parts(lp).x
y#=parts(lp).y
sx#=parts(lp).Scalex+0.35
sy#=parts(lp).Scaley+0.35
Shape=parts(lp).shape
RotateShapeXY Shape,Angle#,SX#,Sy#
drawshape shape,x#,y#,0
parts(lp).Scalex=sx#
parts(lp).Scaley=sy#
Vertcount=Vertcount+GetShapeVerts(Shape,0)
else
DeleteParticles(lp)
endif
endif
next
unlockbuffer
swayangle#=wrapangle(swayangle#,1.25)
swayangle2#=wrapangle(swayangle2#,0.5)
if Nexttime=0
x#=rnd(GetScreenWidth() )
y#=rnd(GetScreenHeight() )
x#=400+cosradius(swayangle#,200)
; y#=300
y#=300+cosradius(swayangle2#,100)
For lp=1 to 5
AddParticles(x#,y#,rndrange(75,250))
next
nexttime=7
endif
dec nexttime
rendertoimage 0
BlitImageAlphaSubColour(1,0,0,rgb($10,$10,$10))
ink $ffffff
inkmode 1
text 10,10,fps()
; text 10,35,VertCount
Sync
loop
Function DeleteParticles(index)
DeleteShape Parts(index).shape
Parts(Index)=null
EndFunction
Function AddParticles(x#,y#,POints)
index=GetFreeCell(Parts())
Parts(index).x=x#
Parts(index).y=y#
Parts(index).scalex=1
Parts(index).scaley=1
Parts(index).colour=rndrgb()
Parts(index).Maxtime=300
Parts(index).time=0
Shape=NewShape(Points,POints)
angleStep#=360.0/points
For lp=0 to points-1
angle#=wrapangle(angle#,anglestep#)
radius#=rndrange#(1,10)
SetShapeVertex Shape,lp,cosRadius(angle#,radius#),SinRadius(angle#,radius#)
SetShapeEdge Shape,lp,lp,lp
next
Parts(index).Shape=Shape
EndFunction
[/pbcode]
PlayBASIC Source Code: Particle Sparkler ( 2007-10-03 ) This effect is created by using the shape command set to plot batches of dots in rings. The screen is then post processed to give the illusion of the particles are cooling down over time.
[pbcode]
; PROJECT : ShapeParticleSprinkler
; AUTHOR : Kevin Picone
; CREATED : 6/03/2007
; EDITED : 3/10/2007
; ---------------------------------------------------------------------
; OpenScreen 800,600,16,2
; MakeBitmapfont 1,$ffffff
Setfps 200
#include "BlitIMage"
Type tParticle
Shape
X#
Y#
ScaleX#
ScaleY#
Time
MaxTime
Colour
EndType
Dim Parts(1) as tParticle
CreateFXimage 1,GetScreenWidth(),GetScreenHeight()
Do
;cls 0
rendertoimage 1
inkmode 1+64
;inkmode 10
Vertcount=0
lockbuffer
For lp=1 to GetArrayelements(Parts(),1)
if Parts(lp)
if Parts(lp).time<Parts(lp).Maxtime
Parts(lp).time=Parts(lp).time+1
C=Parts(lp).Colour
ink rgbfade(c,125-(100.0/Parts(lp).Maxtime)*Parts(lp).time)
x#=parts(lp).x
y#=parts(lp).y
sx#=parts(lp).Scalex+0.35
sy#=parts(lp).Scaley+0.35
Shape=parts(lp).shape
RotateShapeXY Shape,Angle#,SX#,Sy#
drawshape shape,x#,y#,0
parts(lp).Scalex=sx#
parts(lp).Scaley=sy#
Vertcount=Vertcount+GetShapeVerts(Shape,0)
else
DeleteParticles(lp)
endif
endif
next
unlockbuffer
swayangle#=wrapangle(swayangle#,1.25)
swayangle2#=wrapangle(swayangle2#,0.5)
if Nexttime=0
x#=rnd(GetScreenWidth() )
y#=rnd(GetScreenHeight() )
x#=400+cosradius(swayangle#,200)
; y#=300
y#=300+cosradius(swayangle2#,100)
For lp=1 to 5
AddParticles(x#,y#,rndrange(75,250))
next
nexttime=7
endif
dec nexttime
rendertoimage 0
BlitImageAlphaSubColour(1,0,0,rgb($10,$10,$10))
ink $ffffff
inkmode 1
text 10,10,fps()
; text 10,35,VertCount
Sync
loop
Function DeleteParticles(index)
DeleteShape Parts(index).shape
Parts(Index)=null
EndFunction
Function AddParticles(x#,y#,POints)
index=GetFreeCell(Parts())
Parts(index).x=x#
Parts(index).y=y#
Parts(index).scalex=1
Parts(index).scaley=1
Parts(index).colour=rndrgb()
Parts(index).Maxtime=300
Parts(index).time=0
Shape=NewShape(Points,POints)
angleStep#=360.0/points
For lp=0 to points-1
angle#=wrapangle(angle#,anglestep#)
radius#=rndrange#(1,10)
SetShapeVertex Shape,lp,cosRadius(angle#,radius#),SinRadius(angle#,radius#)
SetShapeEdge Shape,lp,lp,lp
next
Parts(index).Shape=Shape
EndFunction
[/pbcode]