Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Feuerwerk 2008
| Uploader: |  Volta |
| Datum/Zeit: | 01.01.2008 14:58:00 |
'Feuerwerk.bas(8) - by Volta - 29.12.2007
'Partikelsystem aus alten RapidQ-Zeiten, in FB erstaunlich schneller.
Declare Function calc (Byval t As Single) As Integer
Declare Sub render
Declare Sub rocket
Declare Sub rocket3 (Byval a As Single, Byval e As Single)
Declare Sub rocket2
Declare Function stern2 (Byval m As Integer) As Integer
Const PI = 3.1415926
Const max = 240 'max. particel
Const lifetime = 2500 'max. time of live
Const ppblast = 100 'number of points in one blast
Type blast 'type point
x As Single 'x position
y As Single 'y position
vx As Single 'horizontal speed
vy As Single 'vertical speed
live As Integer 'is this point alive?
farbe As Integer 'color
top As Integer 'type of point 1-3
End Type
Dim Shared rakete(0 To max) As blast 'array
Dim Shared As Integer breite, hoehe, bpp, pitch
Dim As Single t, r
Dim As String Ik
Randomize Timer
Screen 19,32,,1
Screeninfo breite, hoehe, bpp,,pitch
Draw String (1, hoehe-15),"Wish you a very happy new year 2008 http://Volta.de.tt",&Hffff00
If ((fb_CpuDetect And &h800000) = 0) Or (bpp < 32) Then
Print "Error: only MMX-CPU and true Color!"
Sleep
End
End If
Do
t = Timer
render
Sleep 1,1
If calc(Timer - t) > ppblast Then
r= Rnd *3
If r < 1.9 Then rocket
If (r > 1.9) And (r<2.2) Then rocket2
If (r > 2.2) Then rocket3 (1.2,2)
End If
Ik = Inkey 'Tastaturabfrage
If Ik = Chr(3) Then Exit Do 'wurde Ctrl+C gedrückt oder
If Ik = Chr(255,107) Then Exit Do 'wurde X (Alt+F4) gedrückt
Loop Until Ik = Chr(27) 'oder ESC dann raus hier
End
Sub rocket ()
Dim As Single v, richtung
Dim As Integer n, poc, farbe, ax, ay
poc = Int(Rnd * (ppblast \2))
ax = 50 + Int(Rnd * (breite -100))
ay = 50 + Int(Rnd * (hoehe \2))
farbe = Rgb(120 +Int(Rnd *135),Int(Rnd *256),Int(Rnd *135))
n = 0
Do
If rakete(n).live = 0 Then
richtung = Rnd *2 *PI
v = Rnd * 80
With rakete(n)
.x = ax
.y = ay
.vx = Cos(richtung) * v
.vy = Sin(richtung) * v
.top = Int(1 + 2 * Rnd)
.live = 100 + Int(Rnd * lifetime)
.farbe = farbe
End With
poc += 1
End If
n += 1
Loop Until (poc = ppblast) Or (n = max)
End Sub
Sub render ()
Dim As Integer i, x, y, farbe
Dim As Byte Ptr ScrPtr = Screenptr
Screenlock
ScrPtr += pitch
For i = 1 To hoehe-16
ScrPtr += pitch
For y = 8 To pitch-8 Step 4
Asm
mov eax, [ScrPtr]
add eax, [y]
mov ebx, [pitch]
pxor mm2, mm2 'mm2 [00000000]
movd mm0, [eax +ebx]'mm0 [ rgba]<-pixel unten
punpcklbw mm0, mm2 'mm0 [0r0g0b0a]
movd mm1, [eax] 'mm1 [ rgba]<-pixel
punpcklbw mm1, mm2 'mm1 [0r0g0b0a]
paddw mm0, mm1 'mm0 [ r g b a] =(mm0 + mm1)
movd mm1, [eax -4] 'mm1 [ rgba]<-pixel-1
punpcklbw mm1, mm2 'mm1 [0r0g0b0a]
paddw mm0, mm1 'mm0 [ r g b a] =(mm0 + mm1)
movd mm1, [eax +4] 'mm1 [ rgba]<-pixel+1
punpcklbw mm1, mm2 'mm1 [0r0g0b0a]
paddw mm0, mm1 'mm0 [ r g b a] =(mm0 + mm1)
psrlw mm0, 2 'mm0 [0r0g0b0a] =(mm0 \ 4)
packuswb mm0, mm0 'mm0 [rgbargba]
movd [eax], mm0 'mm0 [ rgba]->pixel
End Asm
Next y
Next i
Asm emms 'Register für FPU freigeben
For i = 0 To max
If rakete(i).live > 0 Then
x = Int(rakete(i).x)
y = Int(rakete(i).y)
farbe = rakete(i).farbe
Pset (x, y), farbe
If rakete(i).top =2 Then
Pset (x + 1, y), farbe
Pset (x, y + 1), farbe
Pset (x - 1, y), farbe
Pset (x, y - 1), farbe
End If
End If
Next
Screenunlock
End Sub
Function calc (Byval t As Single) As Integer
Dim As Integer I, n=0
For I = 0 To max
If rakete(I).live > 0 Then
With rakete(I)
.vy = .vy + ((.y/8) * t)
.x = .x + (.vx * t)
.y = .y + (.vy * t)
.live = .live - Int(t * 1000)
If (.live < 0) Or _
(.x <= 3) Or _
(.y <= 3) Or _
(.x > breite-3) Or _
(.y > hoehe-15) Then .live = 0
End With
If rakete(I).top =3 Then
If rakete(I).live < 800 Then
If rakete(I).live > 0 Then n -= stern2(I)
End If
End If
n += 1
End If
Next
calc = max - n
End Function
Sub rocket3 (Byval a As Single, Byval e As Single)
Dim As Single v, richtung
Dim As Integer n, poc, farbe, ax, ay
poc = (ppblast\2) + Int(Rnd *(ppblast\4))
ax = 50 + Int(Rnd * (breite -100))
ay = 100 + Int(Rnd * (hoehe\2))
n = 0
Do
If rakete(n).live = 0 Then
richtung = (Pi*a) +Rnd *PI/e
farbe = Rgb(120 +Int(Rnd *135),Int(Rnd *256),Int(Rnd *135))
v = Rnd * 100
With rakete(n)
.x = ax
.y = ay
.vx = Cos(richtung) * v
.vy = Sin(richtung) * v
.top = Int(1 + 2 * Rnd)
.live = 1500 + Int(Rnd * poc*10)
.farbe = farbe
End With
poc += 1
End If
n += 1
Loop Until (poc = ppblast) Or (n = max)
End Sub
Sub rocket2 ()
Dim As Single v, richtung
Dim As Integer n, poc, farbe, ax, ay
poc = 0
ax = 50 + Int(Rnd * (breite -100))
ay = 50 + Int(Rnd * (hoehe\4))
farbe = Rgb(120 +Int(Rnd *136),Int(Rnd *256),0)
n = 0
Do
If rakete(n).live = 0 Then
richtung = PI/10*poc
v = 60+Int(Rnd * 15)
With rakete(n)
.x = ax
.y = ay
.vx = Cos(richtung) * v
.vy = Sin(richtung) * v
.top = 3
.live = 100 + Int(Rnd * lifetime)
.farbe = farbe
End With
poc += 1
End If
n += 1
Loop Until (poc = 20) Or (n = max)
End Sub
Function stern2 (Byval m As Integer) As Integer
Dim As Single v, richtung
Dim As Integer n, poc, farbe, ax, ay
poc = 0
ax = rakete(m).x
ay = rakete(m).y
farbe = Rgb(255,Int(Rnd *256),0) or rakete(m).farbe
n = 0
Do
If rakete(n).live = 0 Then
richtung = PI/9*poc
v = 15+Int(Rnd * 25)
With rakete(n)
.x = ax
.y = ay
.vx = Cos(richtung) * v
.vy = Sin(richtung) * v
.top = Int(1 + 2 * Rnd)
.live = 100 + Int(Rnd * 1200)
.farbe = farbe
End With
poc += 1
End If
n += 1
Loop Until (poc = 18) Or (n = max)
rakete(m).live = 0
stern2 = poc
End Function