Graphics 640,480,16,2
SetBuffer BackBuffer()

Type explo
 field x,y,speedx#,speedy#
end type

for i=1 to 20
 explo.explo=new explo
 explo\x=100
 explo\y=100
 explo\speedx=rnd(-2.5,2.5)
 explo\speedy=rnd(-3.0,-0.8)
next

while not keyhit(1)
Cls
for explo.explo=each explo
 plot explo\x,explo\y
 explo\x=explo\x+explo\speedx
 explo\y=explo\y+explo\speedy
 explo\speedy=explo\speedy+0.2
Next
Flip
Wend

;-------------------------------- Explode -------------------------------------
Const  NumOfPixel = 2000        ; Anzahl maximal gleichzeitiger Pixel
Global AktPix     = 0           ; Aktueller Pixel
Dim    ExColor# (256)           ; Farbwerte
Dim    Pixel#   (NumOfPixel,4)  ; 0=x  1=y  2=speed  3=angle  4=color/active
For i=1 To 256                  ; Vorberechnen der Farbwerte für WritePixelFast
   ExColor#(i)=(255*$1000000 + i*$10000 + i*$100 + i)And $FFFFFF
Next
SeedRnd MilliSecs ()
Graphics 1024, 768, 32, 1
SetBuffer BackBuffer ()
;------------------------------------------------------------------------------
While Not KeyDown(1)
Cls
If MouseHit(1) Then NewExplosion MouseX(),MouseY()
Text MouseX(),MouseY(),"Mouse ;-)"
drawexplosion
Text 0,0,"ESC = Beenden      Klicken für Explosion
Flip
Wend
;------------------------------------------------------------------------------
Function NewExplosion(x,y)
   For i=0 To 400
      pixel#(AktPix,0)=x
      pixel#(AktPix,1)=y
      pixel#(AktPix,2)=Rnd#(0.2,3.0)
      pixel#(AktPix,3)=Rnd#(0,360)
      pixel#(AktPix,4)=257
      AktPix=(AktPix+1) Mod NumOfPixel
    Next
End Function
;------------------------------------------------------------------------------
Function DrawExplosion()
   LockBuffer BackBuffer()
   For i=0 To NumOfPixel
        If Pixel#(i,4)>0 Then
         Pixel#(i,0)=pixel#(i,0)+pixel#(i,2)*Cos(pixel#(i,3))
         Pixel#(i,1)=pixel#(i,1)+pixel#(i,2)*Sin(pixel#(i,3))
         Pixel#(i,4)=pixel#(i,4)-1
         If pixel#(i,0)<0 Or pixel#(i,0)>1023 Or pixel#(i,1)<0 Or pixel#(i,1)>767 Or pixel#(i,4)<1 Then
            pixel#(i,4)=0
         Else
            WritePixelFast pixel#(i,0),pixel#(i,1),ExColor#(pixel#(i,4))
         EndIf
        EndIf
    Next        
   UnlockBuffer
End Function
;-------------------------------- Explode -------------------------------------

; PartikelExplosion (Feuerwerk)
; Copyright (C) Mai 2005, Daniel Nobis

; Dies demonstriert ein Feuerwerk aus einzelnen Bildpunkten

Type Partikel
 Field x#, y#, sx#, sy#, speed#, winkel, col, time
End Type

Global FPSSEC = MilliSecs(), FPS, FRAMES
Global n, on

Graphics 1024,768,16,1
SetBuffer BackBuffer()
AppTitle "Firework by Travis"


; ------ Beginn der Hauptschleife ------
Repeat
Cls

 Text 0,0, "FPS: " + FPS()
 
 If MilliSecs() - T2 > 100 Then ; Partikelzahl in Intervallen anzeigen
  Text 0,15, "Partikel: " + n
  T2 = MilliSecs() :  on = n
 Else
  Text 0,15, "Partikel: " + on
 EndIf

 If MilliSecs()-Timer1 > Rnd(150) Then ; Neue Explosion erzeugen
  Timer1 = MilliSecs()
  Explosion(Rnd(1024), Rnd(768))
 EndIf

 UpdatePartikel()

 If KeyHit(59) Then VSync = Vsync Xor 1

 Flip
Until KeyHit(1)
End
; ------ Ende der Hauptschleife ------


; --- Explosion erzeugen ---
Function Explosion(x,y)
 For i = 1 To 1500
  p.partikel = New partikel
  p\x = x
  p\y = y
  p\speed# = Rnd(3)
  p\winkel = Rnd(359)
  p\sx# = Cos(p\winkel) * p\speed#
  p\sy# = Sin(p\winkel) * p\speed#
  r = 255
  g = Rnd(255)
  b = 0
  p\col = r*$10000 + g*$100 + b
  p\time = MilliSecs()
  n = n + 1
 Next
End Function
; --- Explosion erzeugen ---


; --- Partikel aktualisieren ---
Function UpdatePartikel()
 LockBuffer BackBuffer()
  For p.partikel = Each partikel
 
   WritePixelFast p\x, p\y, p\col

   p\x# = p\x# + p\sx#
   p\y# = p\y# + p\sy#
 
   If p\x < 0 Or p\y < 0 Or p\x > 1023 Or p\y > 767 Or MilliSecs()-p\time > Rnd(2200) Then Delete p: n = n - 1
   
  Next
 UnlockBuffer BackBuffer()
End Function
; --- Partikel aktualisieren ---


; --- FPS anzeigen ---
Function FPS()

  FRAMES = FRAMES + 1
  If MilliSecs() - FPSSEC => 1000 Then
   FPS = FRAMES
   FRAMES = 0
   FPSSEC = MilliSecs()
  EndIf
 
 Return FPS
End Function
; --- FPS anzeigen ---