[DBP] 5 Line Fireworks - GameCreators Forum

Author

Message

Rapidrory

14

Years of Service

User Offline

Joined: 21st Aug 2009

Location:

Posted: 24th Oct 2010 17:32 Edited at: 24th Oct 2010 17:34

Link

Ok, i was bored, so i thought i would give fireworks a quick go, seeing as it's almost November 5th. came out alright. probably could be written better, but it works fine.

sync on:sync rate 100:hide mouse:dim starx#(100,5):dim stary#(100,5):dim x#(5):dim xmov#(50):dim height#(50):dim x#(50):dim y#(50):dim startime(50):dim fwcol(50,2):sw=screen width():sh=screen height():for x=0 to 50:x#(x)=sw/2:y#(x)=sh-20:next x
do:cls 0:if rnd(1)=1:num=rnd(50):if y#(num)=sh-20:dec y#(num):z#=rnd(100):xmov#(num)=(z#/50)-1:height#(num)=rnd(100):fwcol(num,0)=rnd(150)+100:fwcol(num,1)=rnd(150)+100:fwcol(num,2)=rnd(150)+100:endif:endif:lock pixels:for fw=0 to 50:if y#(fw)<sh-20
if y#(fw)<sh/2-height#(fw):gosub stars:else:dec y#(fw),2:inc x#(fw),xmov#(fw):dot x#(fw),y#(fw):for trail=1 to 5:dot x#(fw)-(xmov#(fw)*trail),y#(fw)+trail,rgb(255-trail*40,255-trail*40,0):next trail:endif:endif:next fw:unlock pixels:sync:loop
stars:inc startime(fw):for st=1 to 360 step 15:dot (sin(st)*startime(fw))+x#(fw),(cos(st)*startime(fw))+y#(fw),rgb(fwcol(fw,0),fwcol(fw,1),fwcol(fw,2)):next st:for st=0 to 2:dec fwcol(fw,st):next st:if startime(fw)>100:startime(fw)=0:y#(fw)=sh-20
x#(fw)=sw/2:endif:return

+ Code Snippet

sync on:sync rate 100:hide mouse:dim starx#(100,5):dim stary#(100,5):dim x#(5):dim xmov#(50):dim height#(50):dim x#(50):dim y#(50):dim startime(50):dim fwcol(50,2):sw=screen width():sh=screen height():for x=0 to 50:x#(x)=sw/2:y#(x)=sh-20:next x
do:cls 0:if rnd(1)=1:num=rnd(50):if y#(num)=sh-20:dec y#(num):z#=rnd(100):xmov#(num)=(z#/50)-1:height#(num)=rnd(100):fwcol(num,0)=rnd(150)+100:fwcol(num,1)=rnd(150)+100:fwcol(num,2)=rnd(150)+100:endif:endif:lock pixels:for fw=0 to 50:if y#(fw)<sh-20
if y#(fw)<sh/2-height#(fw):gosub stars:else:dec y#(fw),2:inc x#(fw),xmov#(fw):dot x#(fw),y#(fw):for trail=1 to 5:dot x#(fw)-(xmov#(fw)*trail),y#(fw)+trail,rgb(255-trail*40,255-trail*40,0):next trail:endif:endif:next fw:unlock pixels:sync:loop
stars:inc startime(fw):for st=1 to 360 step 15:dot (sin(st)*startime(fw))+x#(fw),(cos(st)*startime(fw))+y#(fw),rgb(fwcol(fw,0),fwcol(fw,1),fwcol(fw,2)):next st:for st=0 to 2:dec fwcol(fw,st):next st:if startime(fw)>100:startime(fw)=0:y#(fw)=sh-20
x#(fw)=sw/2:endif:return

There is no such thing as "Too Fast!"

Back to top

Profile PM

bergice

16

Years of Service

User Offline

Joined: 5th Jun 2007

Location: Oslo,Norway

Posted: 25th Oct 2010 15:33

Link

Nice program.

Uncompressed here:

Rem Project: Dark Basic Pro Project
Rem Created: Monday, October 25, 2010

Rem ***** Main Source File *****
sync on
sync rate 100
hide mouse

dim starx#(100,5)
dim stary#(100,5)
dim x#(5)
dim xmov#(50)
dim height#(50)
dim x#(50)
dim y#(50)
dim startime(50)
dim fwcol(50,2)

sw=screen width()
sh=screen height()

for x=0 to 50
	x#(x)=sw/2
	y#(x)=sh-20
next x

do
cls 0
	if rnd(1)=1
		num=rnd(50)
		if y#(num)=sh-20
			dec y#(num)
			z#=rnd(100)
			xmov#(num)=(z#/50)-1
			height#(num)=rnd(100)
			fwcol(num,0)=rnd(150)+100
			fwcol(num,1)=rnd(150)+100
			fwcol(num,2)=rnd(150)+100
		endif
	endif
	
	lock pixels
	
	for fw=0 to 50
		if y#(fw)<sh-20
			if y#(fw)<sh/2-height#(fw)
				gosub stars
			else
				dec y#(fw),2
				inc x#(fw),xmov#(fw)
				dot x#(fw),y#(fw)
				
				for trail=1 to 5
					dot x#(fw)-(xmov#(fw)*trail),y#(fw)+trail,rgb(255-trail*40,255-trail*40,0)
				next trail
			endif
		endif
	next fw
	
	unlock pixels
	
sync
loop

stars:
	inc startime(fw)
	
	for st=1 to 360 step 15
		dot (sin(st)*startime(fw))+x#(fw),(cos(st)*startime(fw))+y#(fw),rgb(fwcol(fw,0),fwcol(fw,1),fwcol(fw,2))
	next st
	
	for st=0 to 2
		dec fwcol(fw,st)
	next st
	
	if startime(fw)>100
		startime(fw)=0:y#(fw)=sh-20
		x#(fw)=sw/2
	endif
return

+ Code Snippet

Rem Project: Dark Basic Pro Project
Rem Created: Monday, October 25, 2010

Rem ***** Main Source File *****
sync on
sync rate 100
hide mouse

dim starx#(100,5)
dim stary#(100,5)
dim x#(5)
dim xmov#(50)
dim height#(50)
dim x#(50)
dim y#(50)
dim startime(50)
dim fwcol(50,2)

sw=screen width()
sh=screen height()

for x=0 to 50
	x#(x)=sw/2
	y#(x)=sh-20
next x


do
cls 0
	if rnd(1)=1
		num=rnd(50)
		if y#(num)=sh-20
			dec y#(num)
			z#=rnd(100)
			xmov#(num)=(z#/50)-1
			height#(num)=rnd(100)
			fwcol(num,0)=rnd(150)+100
			fwcol(num,1)=rnd(150)+100
			fwcol(num,2)=rnd(150)+100
		endif
	endif
	
	lock pixels
	
	for fw=0 to 50
		if y#(fw)<sh-20
			if y#(fw)<sh/2-height#(fw)
				gosub stars
			else
				dec y#(fw),2
				inc x#(fw),xmov#(fw)
				dot x#(fw),y#(fw)
				
				for trail=1 to 5
					dot x#(fw)-(xmov#(fw)*trail),y#(fw)+trail,rgb(255-trail*40,255-trail*40,0)
				next trail
			endif
		endif
	next fw
	
	unlock pixels
	
sync
loop

stars:
	inc startime(fw)
	
	for st=1 to 360 step 15
		dot (sin(st)*startime(fw))+x#(fw),(cos(st)*startime(fw))+y#(fw),rgb(fwcol(fw,0),fwcol(fw,1),fwcol(fw,2))
	next st
	
	for st=0 to 2
		dec fwcol(fw,st)
	next st
	
	if startime(fw)>100
		startime(fw)=0:y#(fw)=sh-20
		x#(fw)=sw/2
	endif
return

51fa1db0ec7c4af52d93a6f5d0e86bc5

Back to top

Profile PM Email

29 games

18

Years of Service

User Offline

Joined: 23rd Nov 2005

Location: not entirely sure

Posted: 4th Nov 2010 01:34

Link

nice

Back to top

Profile PM Email

Dr Tank

15

Years of Service

User Offline

Joined: 1st Apr 2009

Location: Southampton, UK

Posted: 8th Nov 2010 05:30

Link

That is nice. Lock pixels makes things way faster than without.

Back to top

Profile PM

Daygamer

14

Years of Service

User Offline

Joined: 16th Mar 2010

Location: United States

Posted: 14th Dec 2010 06:00

Link

Good Job. Really looks clean.

yrotate when you can spin?
God Bless!

Back to top

Profile PM Email

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 31st Dec 2010 19:18

Link

That inspired me to do this (for a hello world contest)

Rem Project: HelloWordContest
Rem Created: Friday, December 10, 2010

Rem ***** Main Source File *****
randomize timer()
Set display mode 800,600,32
set window position 0,0
sync on
sync rate 60

Type Mortar
   Global ID
   Global X
   Global Y
   Global Kind$
Endtype

Type Trail
   Global ID
   Global kind$
   Global State$
   Global TrailColor as Dword
   Global StarColor as Dword
   Global amount
   Global Radius as float
   Global Life
   Global Letter$
   
   Global LDelay
   Global EDelay
   
   Global X
   Global Y
   Global XV
   Global YV
   
   Global VDamping
Endtype

Type Particle
   Global ID
   Global PVDamping
   Global Color as Dword
   Global MaxLife
   Global Life
   Global Set
   
   Global X
   Global Y
   
   Global XV as float
   Global YV as float
   
   Global XDest
   Global YDest
endtype

Global MaxMortars=50
Dim Mrtr(MaxMortars) as Mortar

Global MaxTrails=250
Dim Trl(MaxTrails) as Trail

Global MaxParticles=10000
Dim Frwrk(MaxParticles) as Particle

Set text size 24

MakeMortar(1,150,600,"")
MakeMortar(2,300,600,"")
MakeMortar(3,450,600,"")
MakeMortar(4,600,600,"")
MakeMortar(5,400,600,"")

For x=1 to 100
   Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   AddFireworkToMortar(x,rnd(3)+1,"",Color,Color2,120,rnd(50)+50,rnd(170),100,30,2-rnd(4),rnd(3)+10)
Next X

SpellMessageInFireworks(101,5,"Hello",200,225,100,14)
SpellMessageInFireworks(110,5,"World",210,235,100,12)

do
   cls
   UpdateFireworks()
   text 0,0,str$(Screen FPS())
   sync
LOOP

Function SpellMessageInFireworks(IdStart,MortarID,Msg$,TimeFrmStrt,TimeFrmEnd,life,yvel)
   ID=IdStart
   Time=TimeFrmStrt
   TimeInc=(TimeFrmEnd-TimeFrmStrt)/Len(Msg$)
   For i=1 to Len(Msg$)
      Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      AddFireworkToMortar(ID,MortarID,Mid$(Msg$,i),Color,Color2,120,1,Time,100,life,((0-Len(Msg$)/2)+(i-1)),yvel)
      inc Time,TimeInc
      inc ID
   NEXT i
Endfunction

Function MakeMortar(MortarID,x,y,kind$)
  id=SearchMortar(0) 
  Mrtr(ID).id=MortarID
  Mrtr(ID).x=x
  Mrtr(ID).y=y
  Mrtr(ID).kind$=kind$
Endfunction

Function AddFireworkToMortar(TrailID,MortarID,Letter$,TrailColor,StarColor,amount,radius,LaunchDelay,ExplodeDelay,Life,xvel,yvel)
   ID=SearchTrail(0)
   Trl(ID).id=TrailID
   MId=SearchMortar(MortarID)
   
   Trl(ID).Letter$=Letter$
   Trl(ID).kind$=kind$
   Trl(ID).LDelay=LaunchDelay
   Trl(ID).EDelay=ExplodeDelay
   Trl(ID).TrailColor=TrailColor
   Trl(ID).StarColor=StarColor
   Trl(ID).amount=amount
   Trl(ID).radius=radius
   Trl(ID).life=life
      
   Trl(ID).x=Mrtr(MId).x
   Trl(ID).y=Mrtr(MId).y
   Trl(ID).xv=XVel
   Trl(ID).yv=YVel
ENDFUNCTION

Function UpdateFireworks()
   UpdateTrails()
   UpdateParticles()   
ENDFUNCTION

Function UpdateTrails()
   For ID=1 to MaxTrails
      If Trl(Id).id<>0
         if Trl(ID).LDelay>0
            Dec Trl(ID).LDelay
         else
            ink Trl(ID).TrailColor,0
            
            if Timer()>Trl(ID).VDamping then dec Trl(ID).yv,1; Trl(ID).VDamping=Timer()+100
            
            if Trl(ID).EDelay>0 then Dec Trl(ID).EDelay else BlowupFirework(ID)
                 
            
            inc Trl(ID).x,Trl(ID).xv
            dec Trl(ID).y,Trl(ID).yv
            box Trl(ID).x,Trl(ID).y,Trl(ID).x+2,Trl(ID).y+5
            
            ink rgb(255,255,255),0
         endif
      endif
   NEXT ID   
ENDFUNCTION

Function UpdateParticles()
   For ID=1 to MaxParticles
      if Frwrk(ID).id<>0  
         inc Frwrk(ID).x,Frwrk(ID).xv
         inc Frwrk(ID).y,Frwrk(ID).yv
            
          if Timer()>Frwrk(ID).PVDamping 
               Frwrk(ID).xv=Frwrk(ID).xv/1.3
               Frwrk(ID).yv=Frwrk(ID).yv/1.3
               Frwrk(ID).PVDamping=Timer()+80
         endif
         
         ColPerc#=((Frwrk(ID).Life*1.8)/(Frwrk(ID).MaxLife))
         if ColPerc#>1.0 then ColPerc#=1.0
         if Frwrk(ID).life>0
            dec Frwrk(ID).life
            Frwrk(ID).color=rgb((rgbr(Frwrk(ID).color)*ColPerc#),(rgbg(Frwrk(ID).color)*ColPerc#),(rgbb(Frwrk(ID).color)*ColPerc#))
         else
            Frwrk(ID).ID=0
         endif
         
         ink Frwrk(ID).color,0
         dot Frwrk(ID).x,Frwrk(ID).y
         ink rgb(255,255,255),0
      endif
   Next ID
ENDFUNCTION

Function BlowupFirework(TrlID)
   FWID=1
   For ID=1 to Trl(TrlID).amount
      while Frwrk(FWID).Id<>0
         inc FWID
      ENDWHILE
      Frwrk(FWID).ID=SearchFrwrk(0)
      Frwrk(FWID).set=Trl(TrlID).id
      Frwrk(FWID).X=Trl(TrlID).x
      Frwrk(FWID).Y=Trl(TrlID).y
      Frwrk(FWID).MaxLife=TRl(TrlID).life
      Frwrk(FWID).Life=TRl(TrlID).life
      Frwrk(FWID).Color=Trl(TrlID).StarColor
      inc FWID
   NEXT ID
   
   FWID=1
   if Trl(TrlID).Letter$=""
      Ang#=1
      For ID=1 to Trl(TrlID).Amount
         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE
   
         inc Ang#,(360.0/TRl(TrlID).Amount)
         Frwrk(FWID).XDest=((Cos(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).X
         Frwrk(FWID).YDest=((Sin(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).Y
         ink rgb(255,255,255),0
                  
         Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)/10
         Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)/10      
         inc FWID
      NEXT ID  
   else
   
      FWID=1
      cls
      ink rgb(255,255,255),0
      Text 0,0,Trl(TrlID).Letter$
      Get Image 1,0,0,Text width(Trl(TrlID).Letter$),Text height(Trl(TrlID).Letter$)
      cls
      Make Memblock From Image 1,1
      x=0
      y=0
      For Loops=1 to Trl(TrlID).amount
         if x>Text width(Trl(TrlID).Letter$) then x=0;inc y
         pos=(3+x+(y*Text width(Trl(TrlID).Letter$)))*4
         
         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE
         
         if pos>0 and pos<get memblock size(1) and Total<Trl(TrlID).Amount
            If Memblock Byte(1,pos)>100 and Memblock Byte(1,pos+1)>100 and Memblock Byte(1,pos+2)>100
               Frwrk(FWID).XDest=Frwrk(FWID).X-(Text width(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+x*Trl(TrlID).radius
               Frwrk(FWID).YDest=Frwrk(FWID).Y-(Text height(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+y*Trl(TrlID).radius
               
               Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)`/10
               Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)`/10   
               
               inc FWID
               inc total
               
               `dot Frwrk(FWID).XDest,Frwrk(FWID).yDest
               `dot x,y  
               `cls
               `text 0,40,str$(loops)+" / "+str$(Trl(TrlID).amount)
               `sync
               `wait key
            endif
         endif
         inc x
         
         if y>Image Height(1) then Goto ExitBF 
      NEXT loops
      Goto ExitBF:
      ExitBF:
      
      delete image 1
      delete memblock 1
      `text 0,50,str$(x)+", "+str$(y)
      `sync
      `wait key
   endif
   Trl(TrlID).id=0
ENDFUNCTION

Function SearchMortar(MortarID)
   ID=1
   while Mrtr(ID).id<>MortarID
      inc ID
   endwhile   
ENDFUNCTION ID

Function SearchTrail(TrailID)
   ID=1
   while Trl(ID).id<>TrailID
      inc ID
   endwhile 
ENDFUNCTION ID

Function SearchFrWrk(FrWkID)
   ID=1
   while FrWrk(ID).id<>FrWkID
      inc ID
   endwhile 
ENDFUNCTION ID

+ Code Snippet

Rem Project: HelloWordContest
Rem Created: Friday, December 10, 2010

Rem ***** Main Source File *****
randomize timer()
Set display mode 800,600,32
set window position 0,0
sync on
sync rate 60

Type Mortar
   Global ID
   Global X
   Global Y
   Global Kind$
Endtype

Type Trail
   Global ID
   Global kind$
   Global State$
   Global TrailColor as Dword
   Global StarColor as Dword
   Global amount
   Global Radius as float
   Global Life
   Global Letter$
   
   Global LDelay
   Global EDelay
   
   Global X
   Global Y
   Global XV
   Global YV
   
   Global VDamping
Endtype

Type Particle
   Global ID
   Global PVDamping
   Global Color as Dword
   Global MaxLife
   Global Life
   Global Set
   
   Global X
   Global Y
   
   Global XV as float
   Global YV as float
   
   Global XDest
   Global YDest
endtype

Global MaxMortars=50
Dim Mrtr(MaxMortars) as Mortar

Global MaxTrails=250
Dim Trl(MaxTrails) as Trail

Global MaxParticles=10000
Dim Frwrk(MaxParticles) as Particle

Set text size 24

MakeMortar(1,150,600,"")
MakeMortar(2,300,600,"")
MakeMortar(3,450,600,"")
MakeMortar(4,600,600,"")
MakeMortar(5,400,600,"")

For x=1 to 100
   Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   AddFireworkToMortar(x,rnd(3)+1,"",Color,Color2,120,rnd(50)+50,rnd(170),100,30,2-rnd(4),rnd(3)+10)
Next X

SpellMessageInFireworks(101,5,"Hello",200,225,100,14)
SpellMessageInFireworks(110,5,"World",210,235,100,12)

do
   cls
   UpdateFireworks()
   text 0,0,str$(Screen FPS())
   sync
LOOP

Function SpellMessageInFireworks(IdStart,MortarID,Msg$,TimeFrmStrt,TimeFrmEnd,life,yvel)
   ID=IdStart
   Time=TimeFrmStrt
   TimeInc=(TimeFrmEnd-TimeFrmStrt)/Len(Msg$)
   For i=1 to Len(Msg$)
      Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      AddFireworkToMortar(ID,MortarID,Mid$(Msg$,i),Color,Color2,120,1,Time,100,life,((0-Len(Msg$)/2)+(i-1)),yvel)
      inc Time,TimeInc
      inc ID
   NEXT i
Endfunction


Function MakeMortar(MortarID,x,y,kind$)
  id=SearchMortar(0) 
  Mrtr(ID).id=MortarID
  Mrtr(ID).x=x
  Mrtr(ID).y=y
  Mrtr(ID).kind$=kind$
Endfunction

Function AddFireworkToMortar(TrailID,MortarID,Letter$,TrailColor,StarColor,amount,radius,LaunchDelay,ExplodeDelay,Life,xvel,yvel)
   ID=SearchTrail(0)
   Trl(ID).id=TrailID
   MId=SearchMortar(MortarID)
   
   Trl(ID).Letter$=Letter$
   Trl(ID).kind$=kind$
   Trl(ID).LDelay=LaunchDelay
   Trl(ID).EDelay=ExplodeDelay
   Trl(ID).TrailColor=TrailColor
   Trl(ID).StarColor=StarColor
   Trl(ID).amount=amount
   Trl(ID).radius=radius
   Trl(ID).life=life
      
   Trl(ID).x=Mrtr(MId).x
   Trl(ID).y=Mrtr(MId).y
   Trl(ID).xv=XVel
   Trl(ID).yv=YVel
ENDFUNCTION


Function UpdateFireworks()
   UpdateTrails()
   UpdateParticles()   
ENDFUNCTION


Function UpdateTrails()
   For ID=1 to MaxTrails
      If Trl(Id).id<>0
         if Trl(ID).LDelay>0
            Dec Trl(ID).LDelay
         else
            ink Trl(ID).TrailColor,0
            
            if Timer()>Trl(ID).VDamping then dec Trl(ID).yv,1; Trl(ID).VDamping=Timer()+100
            
            if Trl(ID).EDelay>0 then Dec Trl(ID).EDelay else BlowupFirework(ID)
                 
            
            inc Trl(ID).x,Trl(ID).xv
            dec Trl(ID).y,Trl(ID).yv
            box Trl(ID).x,Trl(ID).y,Trl(ID).x+2,Trl(ID).y+5
            
            ink rgb(255,255,255),0
         endif
      endif
   NEXT ID   
ENDFUNCTION

Function UpdateParticles()
   For ID=1 to MaxParticles
      if Frwrk(ID).id<>0  
         inc Frwrk(ID).x,Frwrk(ID).xv
         inc Frwrk(ID).y,Frwrk(ID).yv
            
          if Timer()>Frwrk(ID).PVDamping 
               Frwrk(ID).xv=Frwrk(ID).xv/1.3
               Frwrk(ID).yv=Frwrk(ID).yv/1.3
               Frwrk(ID).PVDamping=Timer()+80
         endif
         
         ColPerc#=((Frwrk(ID).Life*1.8)/(Frwrk(ID).MaxLife))
         if ColPerc#>1.0 then ColPerc#=1.0
         if Frwrk(ID).life>0
            dec Frwrk(ID).life
            Frwrk(ID).color=rgb((rgbr(Frwrk(ID).color)*ColPerc#),(rgbg(Frwrk(ID).color)*ColPerc#),(rgbb(Frwrk(ID).color)*ColPerc#))
         else
            Frwrk(ID).ID=0
         endif
         
         ink Frwrk(ID).color,0
         dot Frwrk(ID).x,Frwrk(ID).y
         ink rgb(255,255,255),0
      endif
   Next ID
ENDFUNCTION


Function BlowupFirework(TrlID)
   FWID=1
   For ID=1 to Trl(TrlID).amount
      while Frwrk(FWID).Id<>0
         inc FWID
      ENDWHILE
      Frwrk(FWID).ID=SearchFrwrk(0)
      Frwrk(FWID).set=Trl(TrlID).id
      Frwrk(FWID).X=Trl(TrlID).x
      Frwrk(FWID).Y=Trl(TrlID).y
      Frwrk(FWID).MaxLife=TRl(TrlID).life
      Frwrk(FWID).Life=TRl(TrlID).life
      Frwrk(FWID).Color=Trl(TrlID).StarColor
      inc FWID
   NEXT ID
   
   FWID=1
   if Trl(TrlID).Letter$=""
      Ang#=1
      For ID=1 to Trl(TrlID).Amount
         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE
   
         inc Ang#,(360.0/TRl(TrlID).Amount)
         Frwrk(FWID).XDest=((Cos(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).X
         Frwrk(FWID).YDest=((Sin(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).Y
         ink rgb(255,255,255),0
                  
         Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)/10
         Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)/10      
         inc FWID
      NEXT ID  
   else
   
      FWID=1
      cls
      ink rgb(255,255,255),0
      Text 0,0,Trl(TrlID).Letter$
      Get Image 1,0,0,Text width(Trl(TrlID).Letter$),Text height(Trl(TrlID).Letter$)
      cls
      Make Memblock From Image 1,1
      x=0
      y=0
      For Loops=1 to Trl(TrlID).amount
         if x>Text width(Trl(TrlID).Letter$) then x=0;inc y
         pos=(3+x+(y*Text width(Trl(TrlID).Letter$)))*4
         
         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE
         
         if pos>0 and pos<get memblock size(1) and Total<Trl(TrlID).Amount
            If Memblock Byte(1,pos)>100 and Memblock Byte(1,pos+1)>100 and Memblock Byte(1,pos+2)>100
               Frwrk(FWID).XDest=Frwrk(FWID).X-(Text width(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+x*Trl(TrlID).radius
               Frwrk(FWID).YDest=Frwrk(FWID).Y-(Text height(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+y*Trl(TrlID).radius
               
               Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)`/10
               Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)`/10   
               
               inc FWID
               inc total
               
               `dot Frwrk(FWID).XDest,Frwrk(FWID).yDest
               `dot x,y  
               `cls
               `text 0,40,str$(loops)+" / "+str$(Trl(TrlID).amount)
               `sync
               `wait key
            endif
         endif
         inc x
         
         if y>Image Height(1) then Goto ExitBF 
      NEXT loops
      Goto ExitBF:
      ExitBF:
      
      delete image 1
      delete memblock 1
      `text 0,50,str$(x)+", "+str$(y)
      `sync
      `wait key
   endif
   Trl(TrlID).id=0
ENDFUNCTION


Function SearchMortar(MortarID)
   ID=1
   while Mrtr(ID).id<>MortarID
      inc ID
   endwhile   
ENDFUNCTION ID

Function SearchTrail(TrailID)
   ID=1
   while Trl(ID).id<>TrailID
      inc ID
   endwhile 
ENDFUNCTION ID

Function SearchFrWrk(FrWkID)
   ID=1
   while FrWrk(ID).id<>FrWkID
      inc ID
   endwhile 
ENDFUNCTION ID

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Rapidrory

14

Years of Service

User Offline

Joined: 21st Aug 2009

Location:

Posted: 2nd Jan 2011 19:13

Link

oh very nice. have to say it was is bit slow, so i've sped it up a bit:

Rem Project: HelloWordContest
Rem Created: Friday, December 10, 2010

Rem ***** Main Source File *****
randomize timer()
Set display mode 800,600,32
set window position 0,0
sync on
sync rate 60

Type Mortar
   Global ID
   Global X
   Global Y
   Global Kind$
Endtype

Type Trail
   Global ID
   Global kind$
   Global State$
   Global TrailColor as Dword
   Global StarColor as Dword
   Global amount
   Global Radius as float
   Global Life
   Global Letter$

Global LDelay
   Global EDelay

Global X
   Global Y
   Global XV
   Global YV

Global VDamping
Endtype

Type Particle
   Global ID
   Global PVDamping
   Global Color as Dword
   Global MaxLife
   Global Life
   Global Set

Global X
   Global Y

Global XV as float
   Global YV as float

Global XDest
   Global YDest
endtype

Global MaxMortars=50
Dim Mrtr(MaxMortars) as Mortar

Global MaxTrails=250
Dim Trl(MaxTrails) as Trail

Global MaxParticles=10000
Dim Frwrk(MaxParticles) as Particle

Set text size 24

MakeMortar(1,150,600,"")
MakeMortar(2,300,600,"")
MakeMortar(3,450,600,"")
MakeMortar(4,600,600,"")
MakeMortar(5,400,600,"")

For x=1 to 100
   Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   AddFireworkToMortar(x,rnd(3)+1,"",Color,Color2,120,rnd(50)+50,rnd(170),100,30,2-rnd(4),rnd(3)+10)
Next X

SpellMessageInFireworks(101,5,"Hello",200,225,100,14)
SpellMessageInFireworks(110,5,"World",210,235,100,12)

do

cls
 lock pixels
   UpdateFireworks()
   text 0,0,str$(Screen FPS())
   unlock pixels
   sync
LOOP

Function SpellMessageInFireworks(IdStart,MortarID,Msg$,TimeFrmStrt,TimeFrmEnd,life,yvel)
   ID=IdStart
   Time=TimeFrmStrt
   TimeInc=(TimeFrmEnd-TimeFrmStrt)/Len(Msg$)
   For i=1 to Len(Msg$)
      Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      AddFireworkToMortar(ID,MortarID,Mid$(Msg$,i),Color,Color2,120,1,Time,100,life,((0-Len(Msg$)/2)+(i-1)),yvel)
      inc Time,TimeInc
      inc ID
   NEXT i
Endfunction

Function MakeMortar(MortarID,x,y,kind$)
  id=SearchMortar(0)
  Mrtr(ID).id=MortarID
  Mrtr(ID).x=x
  Mrtr(ID).y=y
  Mrtr(ID).kind$=kind$
Endfunction

Function AddFireworkToMortar(TrailID,MortarID,Letter$,TrailColor,StarColor,amount,radius,LaunchDelay,ExplodeDelay,Life,xvel,yvel)
   ID=SearchTrail(0)
   Trl(ID).id=TrailID
   MId=SearchMortar(MortarID)

Trl(ID).Letter$=Letter$
   Trl(ID).kind$=kind$
   Trl(ID).LDelay=LaunchDelay
   Trl(ID).EDelay=ExplodeDelay
   Trl(ID).TrailColor=TrailColor
   Trl(ID).StarColor=StarColor
   Trl(ID).amount=amount
   Trl(ID).radius=radius
   Trl(ID).life=life

Trl(ID).x=Mrtr(MId).x
   Trl(ID).y=Mrtr(MId).y
   Trl(ID).xv=XVel
   Trl(ID).yv=YVel
ENDFUNCTION

Function UpdateFireworks()
   UpdateTrails()
   UpdateParticles()
ENDFUNCTION

Function UpdateTrails()
   For ID=1 to MaxTrails
      If Trl(Id).id<>0
         if Trl(ID).LDelay>0
            Dec Trl(ID).LDelay
         else
            ink Trl(ID).TrailColor,0

if Timer()>Trl(ID).VDamping then dec Trl(ID).yv,1; Trl(ID).VDamping=Timer()+100

if Trl(ID).EDelay>0 then Dec Trl(ID).EDelay else BlowupFirework(ID)

inc Trl(ID).x,Trl(ID).xv
            dec Trl(ID).y,Trl(ID).yv
            box Trl(ID).x,Trl(ID).y,Trl(ID).x+2,Trl(ID).y+5

ink rgb(255,255,255),0
         endif
      endif
   NEXT ID
ENDFUNCTION

Function UpdateParticles()
   For ID=1 to MaxParticles
      if Frwrk(ID).id<>0
         inc Frwrk(ID).x,Frwrk(ID).xv
         inc Frwrk(ID).y,Frwrk(ID).yv

if Timer()>Frwrk(ID).PVDamping
               Frwrk(ID).xv=Frwrk(ID).xv/1.3
               Frwrk(ID).yv=Frwrk(ID).yv/1.3
               Frwrk(ID).PVDamping=Timer()+80
         endif

ColPerc#=((Frwrk(ID).Life*1.8)/(Frwrk(ID).MaxLife))
         if ColPerc#>1.0 then ColPerc#=1.0
         if Frwrk(ID).life>0
            dec Frwrk(ID).life
            Frwrk(ID).color=rgb((rgbr(Frwrk(ID).color)*ColPerc#),(rgbg(Frwrk(ID).color)*ColPerc#),(rgbb(Frwrk(ID).color)*ColPerc#))
         else
            Frwrk(ID).ID=0
         endif

ink Frwrk(ID).color,0
         dot Frwrk(ID).x,Frwrk(ID).y
         ink rgb(255,255,255),0
      endif
   Next ID
ENDFUNCTION

Function BlowupFirework(TrlID)
   FWID=1
   For ID=1 to Trl(TrlID).amount
      while Frwrk(FWID).Id<>0
         inc FWID
      ENDWHILE
      Frwrk(FWID).ID=SearchFrwrk(0)
      Frwrk(FWID).set=Trl(TrlID).id
      Frwrk(FWID).X=Trl(TrlID).x
      Frwrk(FWID).Y=Trl(TrlID).y
      Frwrk(FWID).MaxLife=TRl(TrlID).life
      Frwrk(FWID).Life=TRl(TrlID).life
      Frwrk(FWID).Color=Trl(TrlID).StarColor
      inc FWID
   NEXT ID

FWID=1
   if Trl(TrlID).Letter$=""
      Ang#=1
      For ID=1 to Trl(TrlID).Amount
         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE

inc Ang#,(360.0/TRl(TrlID).Amount)
         Frwrk(FWID).XDest=((Cos(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).X
         Frwrk(FWID).YDest=((Sin(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).Y
         ink rgb(255,255,255),0

Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)/10
         Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)/10
         inc FWID
      NEXT ID
   else

FWID=1
      cls
      ink rgb(255,255,255),0
      Text 0,0,Trl(TrlID).Letter$
      unlock pixels
      Get Image 1,0,0,Text width(Trl(TrlID).Letter$),Text height(Trl(TrlID).Letter$)
      lock pixels
      cls
      Make Memblock From Image 1,1
      x=0
      y=0
      For Loops=1 to Trl(TrlID).amount
         if x>Text width(Trl(TrlID).Letter$) then x=0;inc y
         pos=(3+x+(y*Text width(Trl(TrlID).Letter$)))*4

while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE

if pos>0 and pos<get memblock size(1) and Total<Trl(TrlID).Amount
            If Memblock Byte(1,pos)>100 and Memblock Byte(1,pos+1)>100 and Memblock Byte(1,pos+2)>100
               Frwrk(FWID).XDest=Frwrk(FWID).X-(Text width(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+x*Trl(TrlID).radius
               Frwrk(FWID).YDest=Frwrk(FWID).Y-(Text height(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+y*Trl(TrlID).radius

Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)`/10
               Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)`/10

inc FWID
               inc total

`dot Frwrk(FWID).XDest,Frwrk(FWID).yDest
               `dot x,y
               `cls
               `text 0,40,str$(loops)+" / "+str$(Trl(TrlID).amount)
               `sync
               `wait key
            endif
         endif
         inc x

if y>Image Height(1) then Goto ExitBF
      NEXT loops
      Goto ExitBF:
      ExitBF:

delete image 1
      delete memblock 1
      `text 0,50,str$(x)+", "+str$(y)
      `sync
      `wait key
   endif
   Trl(TrlID).id=0
ENDFUNCTION

Function SearchMortar(MortarID)
   ID=1
   while Mrtr(ID).id<>MortarID
      inc ID
   endwhile
ENDFUNCTION ID

Function SearchTrail(TrailID)
   ID=1
   while Trl(ID).id<>TrailID
      inc ID
   endwhile
ENDFUNCTION ID

Function SearchFrWrk(FrWkID)
   ID=1
   while FrWrk(ID).id<>FrWkID
      inc ID
   endwhile
ENDFUNCTION ID

+ Code Snippet

Rem Project: HelloWordContest
Rem Created: Friday, December 10, 2010

Rem ***** Main Source File *****
randomize timer()
Set display mode 800,600,32
set window position 0,0
sync on
sync rate 60

Type Mortar
   Global ID
   Global X
   Global Y
   Global Kind$
Endtype

Type Trail
   Global ID
   Global kind$
   Global State$
   Global TrailColor as Dword
   Global StarColor as Dword
   Global amount
   Global Radius as float
   Global Life
   Global Letter$

   Global LDelay
   Global EDelay

   Global X
   Global Y
   Global XV
   Global YV

   Global VDamping
Endtype

Type Particle
   Global ID
   Global PVDamping
   Global Color as Dword
   Global MaxLife
   Global Life
   Global Set

   Global X
   Global Y

   Global XV as float
   Global YV as float

   Global XDest
   Global YDest
endtype

Global MaxMortars=50
Dim Mrtr(MaxMortars) as Mortar

Global MaxTrails=250
Dim Trl(MaxTrails) as Trail

Global MaxParticles=10000
Dim Frwrk(MaxParticles) as Particle

Set text size 24

MakeMortar(1,150,600,"")
MakeMortar(2,300,600,"")
MakeMortar(3,450,600,"")
MakeMortar(4,600,600,"")
MakeMortar(5,400,600,"")

For x=1 to 100
   Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
   AddFireworkToMortar(x,rnd(3)+1,"",Color,Color2,120,rnd(50)+50,rnd(170),100,30,2-rnd(4),rnd(3)+10)
Next X

SpellMessageInFireworks(101,5,"Hello",200,225,100,14)
SpellMessageInFireworks(110,5,"World",210,235,100,12)

do

   cls
 lock pixels
   UpdateFireworks()
   text 0,0,str$(Screen FPS())
   unlock pixels
   sync
LOOP

Function SpellMessageInFireworks(IdStart,MortarID,Msg$,TimeFrmStrt,TimeFrmEnd,life,yvel)
   ID=IdStart
   Time=TimeFrmStrt
   TimeInc=(TimeFrmEnd-TimeFrmStrt)/Len(Msg$)
   For i=1 to Len(Msg$)
      Color=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      Color2=rgb(rnd(155)+100,rnd(155)+100,rnd(155)+100)
      AddFireworkToMortar(ID,MortarID,Mid$(Msg$,i),Color,Color2,120,1,Time,100,life,((0-Len(Msg$)/2)+(i-1)),yvel)
      inc Time,TimeInc
      inc ID
   NEXT i
Endfunction


Function MakeMortar(MortarID,x,y,kind$)
  id=SearchMortar(0)
  Mrtr(ID).id=MortarID
  Mrtr(ID).x=x
  Mrtr(ID).y=y
  Mrtr(ID).kind$=kind$
Endfunction

Function AddFireworkToMortar(TrailID,MortarID,Letter$,TrailColor,StarColor,amount,radius,LaunchDelay,ExplodeDelay,Life,xvel,yvel)
   ID=SearchTrail(0)
   Trl(ID).id=TrailID
   MId=SearchMortar(MortarID)

   Trl(ID).Letter$=Letter$
   Trl(ID).kind$=kind$
   Trl(ID).LDelay=LaunchDelay
   Trl(ID).EDelay=ExplodeDelay
   Trl(ID).TrailColor=TrailColor
   Trl(ID).StarColor=StarColor
   Trl(ID).amount=amount
   Trl(ID).radius=radius
   Trl(ID).life=life

   Trl(ID).x=Mrtr(MId).x
   Trl(ID).y=Mrtr(MId).y
   Trl(ID).xv=XVel
   Trl(ID).yv=YVel
ENDFUNCTION


Function UpdateFireworks()
   UpdateTrails()
   UpdateParticles()
ENDFUNCTION


Function UpdateTrails()
   For ID=1 to MaxTrails
      If Trl(Id).id<>0
         if Trl(ID).LDelay>0
            Dec Trl(ID).LDelay
         else
            ink Trl(ID).TrailColor,0

            if Timer()>Trl(ID).VDamping then dec Trl(ID).yv,1; Trl(ID).VDamping=Timer()+100

            if Trl(ID).EDelay>0 then Dec Trl(ID).EDelay else BlowupFirework(ID)


            inc Trl(ID).x,Trl(ID).xv
            dec Trl(ID).y,Trl(ID).yv
            box Trl(ID).x,Trl(ID).y,Trl(ID).x+2,Trl(ID).y+5

            ink rgb(255,255,255),0
         endif
      endif
   NEXT ID
ENDFUNCTION

Function UpdateParticles()
   For ID=1 to MaxParticles
      if Frwrk(ID).id<>0
         inc Frwrk(ID).x,Frwrk(ID).xv
         inc Frwrk(ID).y,Frwrk(ID).yv

          if Timer()>Frwrk(ID).PVDamping
               Frwrk(ID).xv=Frwrk(ID).xv/1.3
               Frwrk(ID).yv=Frwrk(ID).yv/1.3
               Frwrk(ID).PVDamping=Timer()+80
         endif

         ColPerc#=((Frwrk(ID).Life*1.8)/(Frwrk(ID).MaxLife))
         if ColPerc#>1.0 then ColPerc#=1.0
         if Frwrk(ID).life>0
            dec Frwrk(ID).life
            Frwrk(ID).color=rgb((rgbr(Frwrk(ID).color)*ColPerc#),(rgbg(Frwrk(ID).color)*ColPerc#),(rgbb(Frwrk(ID).color)*ColPerc#))
         else
            Frwrk(ID).ID=0
         endif

         ink Frwrk(ID).color,0
         dot Frwrk(ID).x,Frwrk(ID).y
         ink rgb(255,255,255),0
      endif
   Next ID
ENDFUNCTION


Function BlowupFirework(TrlID)
   FWID=1
   For ID=1 to Trl(TrlID).amount
      while Frwrk(FWID).Id<>0
         inc FWID
      ENDWHILE
      Frwrk(FWID).ID=SearchFrwrk(0)
      Frwrk(FWID).set=Trl(TrlID).id
      Frwrk(FWID).X=Trl(TrlID).x
      Frwrk(FWID).Y=Trl(TrlID).y
      Frwrk(FWID).MaxLife=TRl(TrlID).life
      Frwrk(FWID).Life=TRl(TrlID).life
      Frwrk(FWID).Color=Trl(TrlID).StarColor
      inc FWID
   NEXT ID

   FWID=1
   if Trl(TrlID).Letter$=""
      Ang#=1
      For ID=1 to Trl(TrlID).Amount
         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE

         inc Ang#,(360.0/TRl(TrlID).Amount)
         Frwrk(FWID).XDest=((Cos(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).X
         Frwrk(FWID).YDest=((Sin(Ang#)) * Trl(TrlID).radius)+Frwrk(FWID).Y
         ink rgb(255,255,255),0

         Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)/10
         Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)/10
         inc FWID
      NEXT ID
   else

      FWID=1
      cls
      ink rgb(255,255,255),0
      Text 0,0,Trl(TrlID).Letter$
      unlock pixels
      Get Image 1,0,0,Text width(Trl(TrlID).Letter$),Text height(Trl(TrlID).Letter$)
      lock pixels
      cls
      Make Memblock From Image 1,1
      x=0
      y=0
      For Loops=1 to Trl(TrlID).amount
         if x>Text width(Trl(TrlID).Letter$) then x=0;inc y
         pos=(3+x+(y*Text width(Trl(TrlID).Letter$)))*4

         while Frwrk(FWID).set<>Trl(TrlID).id
            inc FWID
         ENDWHILE

         if pos>0 and pos<get memblock size(1) and Total<Trl(TrlID).Amount
            If Memblock Byte(1,pos)>100 and Memblock Byte(1,pos+1)>100 and Memblock Byte(1,pos+2)>100
               Frwrk(FWID).XDest=Frwrk(FWID).X-(Text width(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+x*Trl(TrlID).radius
               Frwrk(FWID).YDest=Frwrk(FWID).Y-(Text height(Trl(TrlID).Letter$)/2)*Trl(TrlID).radius+y*Trl(TrlID).radius

               Frwrk(FWID).XV=(Frwrk(FWID).XDest-Frwrk(FWID).X)`/10
               Frwrk(FWID).YV=(Frwrk(FWID).YDest-Frwrk(FWID).Y)`/10

               inc FWID
               inc total

               `dot Frwrk(FWID).XDest,Frwrk(FWID).yDest
               `dot x,y
               `cls
               `text 0,40,str$(loops)+" / "+str$(Trl(TrlID).amount)
               `sync
               `wait key
            endif
         endif
         inc x

         if y>Image Height(1) then Goto ExitBF
      NEXT loops
      Goto ExitBF:
      ExitBF:

      delete image 1
      delete memblock 1
      `text 0,50,str$(x)+", "+str$(y)
      `sync
      `wait key
   endif
   Trl(TrlID).id=0
ENDFUNCTION


Function SearchMortar(MortarID)
   ID=1
   while Mrtr(ID).id<>MortarID
      inc ID
   endwhile
ENDFUNCTION ID

Function SearchTrail(TrailID)
   ID=1
   while Trl(ID).id<>TrailID
      inc ID
   endwhile
ENDFUNCTION ID

Function SearchFrWrk(FrWkID)
   ID=1
   while FrWrk(ID).id<>FrWkID
      inc ID
   endwhile
ENDFUNCTION ID

There is no such thing as "Too Fast!"

Back to top

Profile PM

Madscientist

14

Years of Service

User Offline

Joined: 23rd Aug 2009

Location: Between a rock and a hard place

Posted: 3rd Jan 2011 04:26

Link

Yeah, it was giving my older computer a hard time. The Make firworks functions are quite usefull as you can customize the fireworks.

My computer surpasses all the technologies of the day. What computer do I have?

+ Code Snippet

My Brain

Back to top

Profile PM

Sorry your browser is not supported!

The 20 Line Challenge / [DBP] 5 Line Fireworks