Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Feuerwerk 2008 mit FBSinCos
| Uploader: |  ytwinky |
| Datum/Zeit: | 02.01.2008 18:48:02 |
'Feuerwerk.bas(8) - by Volta - 29.12.2007
'Partikelsystem aus alten RapidQ-Zeiten, in FB erstaunlich schneller.
'Declare Function PI As Single
'Was liegt näher, als FBSinCos mit dem Programm auszuprobieren, das mich auf die Idee brachte ^^
'Durch die Einführung von fbCos und fbSin sind andere Variablen rausgeflogen
'ich habe nicht getesten, ob das Programm dadurch schneller wird
'ytwinky, 02.01.2008
Declare Sub FBSinCos(Angle As Double, byRef fbSin As Double, byRef fbCos As Double)
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 CtrlC=!"\3", Esc=!"\27", AltF4=!"\255\107"
Const PI=4.0*Atn(1.0)
Const maxPartikel = 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 maxPartikel) As blast 'array
Dim Shared As Integer breite, hoehe, bpp, pitch
Dim Shared As Double fbCos, fbSin
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),"We wish you a very happy new year 2008 Volta & ytwinky", &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
Loop Until Ik=Esc Or Ik=CtrlC Or Ik=AltF4 'ESC oder Ctrl-C oder AltF4 gedrückt, dann raus hier
End
Sub rocket ()
Dim As Single v
Dim As Integer n=0, poc= Int(Rnd * (ppblast \2)), ax, ay
ax = 50 + Int(Rnd * (breite -100))
ay = 50 + Int(Rnd * (hoehe \2))
Do
If rakete(n).live = 0 Then
v = Rnd * 80
With rakete(n)
.x = ax
.y = ay
FBSinCos(Rnd *2 *PI, fbSin, fbCos)
.vx = fbCos * v
.vy = fbSin * v
.top = Int(1 + 2 * Rnd)
.live = 100 + Int(Rnd * lifetime)
.farbe = Rgb(120 +Int(Rnd *135),Int(Rnd *256),Int(Rnd *135))
End With
poc += 1
End If
n += 1
Loop Until (poc = ppblast) Or (n = maxPartikel)
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 maxPartikel
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 maxPartikel
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 = maxPartikel - n
End Function
Sub rocket3 (Byval a As Single, Byval e As Single)
Dim As Single v
Dim As Integer n=0, poc=(ppblast\2) + Int(Rnd *(ppblast\4)), ax, ay
ax = 50 + Int(Rnd * (breite -100))
ay = 100 + Int(Rnd * (hoehe\2))
Do
If rakete(n).live = 0 Then
v = Rnd * 100
With rakete(n)
.x = ax
.y = ay
FBSinCos((Pi*a) +Rnd *PI/e, fbSin, fbCos)
.vx = fbCos * v
.vy = fbSin * v
.top = Int(1 + 2 * Rnd)
.live = 1500 + Int(Rnd * poc*10)
.farbe = Rgb(120 +Int(Rnd *135), Int(Rnd *256), Int(Rnd *135))
End With
poc += 1
End If
n += 1
Loop Until (poc = ppblast) Or (n = maxPartikel)
End Sub
Sub rocket2 ()
Dim As Integer n=0, poc=1, farbe, ax, ay
Dim As Single v
ax = 50 + Int(Rnd * (breite -100))
ay = 50 + Int(Rnd * (hoehe\4))
farbe = Rgb(120+Int(Rnd *136), Int(Rnd *256), 0)
Do
If rakete(n).live = 0 Then
v = 60+Int(Rnd * 15)
With rakete(n)
.x = ax
.y = ay
FBSinCos(PI/10*poc, fbSin, fbCos)
.vx = fbCos * v
.vy = fbSin * v
.top = 3
.live = 100 + Int(Rnd * lifetime)
.farbe = farbe
End With
poc += 1
End If
n += 1
Loop Until (poc = 20) Or (n = maxPartikel)
End Sub
Function stern2 (Byval m As Integer) As Integer
Dim As Integer n=0, poc=1, farbe, ax, ay
Dim As Single v
farbe = Rgb(255, Int(Rnd *256), 0) Or rakete(m).farbe
Do
If rakete(n).live = 0 Then
v = 15+Int(Rnd * 25)
With rakete(n)
.x = rakete(m).x
.y = rakete(m).y
FBSinCos(PI/9*poc, fbSin, fbCos)
.vx = fbCos * v
.vy = fbSin * 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 = maxPartikel)
rakete(m).live = 0
stern2 = poc
End Function
Sub FBSinCos(Angle As Double, byRef fbSin As Double, byRef fbCos As Double)
Dim As Double hcos, hsin
Asm
fld qword Ptr [Angle] 'Angle -> st(0)
fsincos 'compute sin AND cos
fstp qword Ptr [hcos] 'St(0) -> cos
fstp qword Ptr [hsin] 'St(0) -> sin
End Asm
fbCos=hcos
fbSin=hsin
End Sub