Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
FlowNet.bas
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 05.06.2008 11:26:14 |
'################################################################################
' TPM - FlowNet - 03.06.2008
'################################################################################
'################################################################################
'a = 1 Partikel hinzufügen (1x pro tastendruck)
'b = 1 Partikel hinzufügen (solange taste gedrückt)
'm = 10 Partikel hinzufügen (solange taste gedrückt)
'c = Alle Partikel löschen
'o = Druckfarbe / Zählerfarbe umschalten
'w = Flusswand abschalten / einschalten
'n = Wand hinzufügen
'Linke masutaste = Wand verschieben
'Rechte Maustaste = Wand löschen
'Mausrad = Wandgrösse ändern
'################################################################################
Dim Shared G_Room_Width as UInteger = 600
Dim Shared G_Room_Height as UInteger = 400
Type G_Particle_2D_Type
V_InUse as UByte
X as Single
Y as Single
SpeedX as Single
SpeedY as Single
LX as Single
LY as Single
InertiaX as Single
InertiaY as Single
InertiaTime as Single
V_Presure as Single
V_Color as UInteger
End Type
Dim Shared G_ParticleD() as G_Particle_2D_Type
Dim Shared G_ParticleC as UInteger
Dim Shared G_TColorG as UByte
Dim Shared G_TColorB as UByte
Dim Shared G_ShowTColor as UByte
Type G_Obj_2D_Type
V_InUse as UByte
X as Integer
Y as Integer
Size as UInteger
TColor as UInteger
End Type
Dim Shared G_ObjD() as G_Obj_2D_Type
Dim Shared G_ObjC as UInteger
Dim Shared G_Density as Single = 20
Dim Shared G_FlowReaction as Single = 0.1
Dim Shared G_ChaosReaction as Single = 30000
Dim Shared G_SubRuntime as UInteger = 6
Dim Shared G_ShowSize as UInteger = 5
Dim Shared G_InertiaTime as Single = 1.2
Dim Shared G_FlowOff as UByte = 1
Sub Particle_Add()
Dim XID as UInteger
For X as ULong = 1 to G_ParticleC
If G_ParticleD(X).V_InUse = 0 Then XID = X: Exit For
Next
If XID = 0 Then
G_ParticleC += 1
XID = G_ParticleC
Redim Preserve G_ParticleD(G_ParticleC) as G_Particle_2D_Type
End If
If G_TColorG Mod 2 = G_TColorB mod 2 Then
G_TColorB += 1
Else: G_TColorG += 1
End if
With G_ParticleD(XID)
.V_InUse = 1
.X = 0
.Y = Int((Rnd * G_Room_Height) + 1)
.SpeedX = 0
.SpeedY = 0
.LX = .LX
.LY = .LY
.InertiaX = 0
.InertiaY = 0
.InertiaTime = 0
.V_Presure = 0
.V_Color = RGB(255, G_TColorG, G_TColorB)
End With
End Sub
Function Obj_Add() as UInteger
Dim XID as UInteger
For X as ULong = 1 to G_ObjC
If G_ObjD(X).V_InUse = 0 Then XID = X: Exit For
Next
If XID = 0 Then
G_ObjC += 1
XID = G_ObjC
Redim Preserve G_ObjD(G_ObjC) as G_Obj_2D_Type
End If
With G_ObjD(XID)
.V_InUse = 1
.X = 0
.Y = 0
.Size = 100
.TColor = RGB(100 + Int((Rnd * 155) + 1), 100 + Int((Rnd * 155) + 1), 100 + Int((Rnd * 155) + 1))
End With
Return XID
End Function
Function Obj_GetOnMouse(V_X as Integer, V_Y as Integer) as UInteger
For X as ULong = G_ObjC to 1 Step - 1
With G_ObjD(X)
If V_X >= .X and V_X <= .X + .Size and V_Y >= .Y and V_Y <= .Y + .Size Then Return X
End With
Next
End Function
Sub Particle_Calculate_Reorientation()
Dim X as ULong
Dim Y as ULong
Dim RX as Single
Dim RY as Single
Dim NX as Single
Dim NY as Single
Dim DX as UByte
Dim DY as UByte
For X = 1 to G_ParticleC
With G_ParticleD(X)
If .V_InUse = 1 Then
.InertiaTime += G_InertiaTime
If .InertiaTime >= 3 Then
.InertiaX /= 2
.InertiaY /= 2
.InertiaTime = 0
End If
.X += .InertiaX
.Y += .InertiaY
.V_Presure = 0
For Y = 1 To G_ParticleC
If G_ParticleD(Y).V_InUse = 1 Then
If X <> Y Then
If .X < G_ParticleD(Y).X Then
If .Y < G_ParticleD(Y).Y Then
If G_ParticleD(Y).X - .X < G_Density Then
If G_ParticleD(Y).Y - .Y < G_Density Then
RX = ((G_Density - (G_ParticleD(Y).X - .X)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.X -= RX
G_ParticleD(Y).X += RX
RY = ((G_Density - (G_ParticleD(Y).Y - .Y)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.Y -= RY
G_ParticleD(Y).Y += RY
.SpeedX = -RX * G_SubRuntime
.SpeedY = -RY * G_SubRuntime
.V_Presure = 1024 / G_Density * ((abs(RX) + abs(RY)) / 2)
End If
End If
Else
If G_ParticleD(Y).X - .X < G_Density Then
If .Y - G_ParticleD(Y).Y < G_Density Then
RX = ((G_Density - (G_ParticleD(Y).X - .X)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.X -= RX
G_ParticleD(Y).X += RX
RY = ((G_Density - (.Y - G_ParticleD(Y).Y)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.Y += RY
G_ParticleD(Y).Y -= RY
.SpeedX = -RX * G_SubRuntime
.SpeedY = +RY * G_SubRuntime
.V_Presure = 1024 / G_Density * ((abs(RX) + abs(RY)) / 2)
End If
End If
End If
Else
If .Y < G_ParticleD(Y).Y Then
If .X - G_ParticleD(Y).X < G_Density Then
If G_ParticleD(Y).Y - .Y < G_Density Then
RX = ((G_Density - (.X - G_ParticleD(Y).X)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.X += RX
G_ParticleD(Y).X -= RX
RY = ((G_Density - (G_ParticleD(Y).Y - .Y)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.Y -= RY
G_ParticleD(Y).Y += RY
.SpeedX = +RX * G_SubRuntime
.SpeedY = -RY * G_SubRuntime
.V_Presure = 1024 / G_Density * ((abs(RX) + abs(RY)) / 2)
End If
End If
Else
If .X - G_ParticleD(Y).X < G_Density Then
If .Y - G_ParticleD(Y).Y < G_Density Then
RX = ((G_Density - (.X - G_ParticleD(Y).X)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.X += RX
G_ParticleD(Y).X -= RX
RY = ((G_Density - (.Y - G_ParticleD(Y).Y)) * G_FlowReaction) + (int((rnd * 10) + 1) / G_ChaosReaction)
.Y += RY
G_ParticleD(Y).Y -= RY
.SpeedX = +RX * G_SubRuntime
.SpeedY = +RY * G_SubRuntime
.V_Presure = 1024 / G_Density * ((abs(RX) + abs(RY)) / 2)
End If
End If
End If
End If
End If
End If
Next
For Y = 1 to G_ObjC
If G_ObjD(Y).V_InUse = 1 Then
If (.X > G_ObjD(Y).X - G_Density) and (.X < G_ObjD(Y).X + G_ObjD(Y).Size + G_Density) Then
If (.Y > G_ObjD(Y).Y - G_Density) and (.Y < G_ObjD(Y).Y + G_ObjD(Y).Size + G_Density) Then
If .X - (G_ObjD(Y).X - G_Density) < (G_ObjD(Y).X + G_ObjD(Y).Size + G_Density) - .X Then
NX = .X - (G_ObjD(Y).X - G_Density): DX = 1
Else: NX = (G_ObjD(Y).X + G_ObjD(Y).Size + G_Density) - .X: DX = 2
End If
If .Y - (G_ObjD(Y).Y - G_Density) < (G_ObjD(Y).Y + G_ObjD(Y).Size + G_Density) - .Y Then
NY = .Y - (G_ObjD(Y).Y - G_Density): DY = 1
Else: NY = (G_ObjD(Y).Y + G_ObjD(Y).Size + G_Density) - .Y: DY = 2
End If
If NX < NY Then
If DX = 1 Then
.X = G_ObjD(Y).X - G_Density
Else: .X = G_ObjD(Y).X + G_ObjD(Y).Size + G_Density
End If
Else
If DY = 1 Then
.Y = G_ObjD(Y).Y - G_Density
Else: .Y = G_ObjD(Y).Y + G_ObjD(Y).Size + G_Density
End IF
End If
End If
End if
End if
Next
.InertiaX += (.X - .LX) / 4
.InertiaY += (.Y - .LY) / 4
.LX = .X
.LY = .Y
DY = 0
If .X - G_Density < 0 Then DY = 1: .X = G_Density + ((abs(.X - G_Density) * G_FlowReaction) / 2) + (int((rnd * 10) + 1) / G_ChaosReaction)
If .Y - G_Density < 0 Then DY = DY Or 2: .Y = G_Density + ((abs(.Y - G_Density) * G_FlowReaction) / 2) + (int((rnd * 10) + 1) / G_ChaosReaction)
If .X + G_Density > G_Room_Width Then
If G_FlowOff = 1 Then
DY = DY or 1
.X = (G_Room_Width - G_Density) - (abs((.X + G_Density) - G_Room_Width))' * G_FlowReaction) / 2) + (int((rnd * 10) + 1) / G_ChaosReaction)
Else: .V_InUse = 0
End If
End If
If .Y + G_Density > G_Room_Height Then DY = DY or 2: .Y = (G_Room_Height - G_Density) - (abs((.Y + G_Density) - G_Room_Height))' * G_FlowReaction) / 2) + (int((rnd * 10) + 1) / G_ChaosReaction)
If DY and 1 <> 0 Then
.InertiaX = (.X - .LX) / 4
.LX = .X
End If
If (DY And 2 <> 0) then
.InertiaY = (.Y - .LY) / 4
.LY = .Y
End If
' If .X - G_Density < 0 Then .X = (((-.X) + G_Density) * G_FlowReaction)) + (int((rnd * 10) + 1) / G_ChaosReaction)
' If .Y - G_Density < 0 Then .Y = G_Density + (int((rnd * 10) + 1) / G_ChaosReaction)
' If .X + G_Density > G_Room_Width Then .V_InUse = 0
' If .Y + G_Density > G_Room_Height Then .Y = G_Room_Height - G_Density - (int((rnd * 10) + 1) / G_ChaosReaction)
End If
End With
Next
End Sub
Screenres G_Room_Width + 6, G_Room_Height + 6, 24
Randomize Timer
Dim XTot as Double
Dim X as ULong
Dim AKey as String
Dim LKey as String
Dim XCol as UInteger
Dim MX as Integer
Dim MY as Integer
Dim MZ as Integer
Dim MB as Integer
Dim MZL as Integer
Dim TZ as Integer
Dim OBJID as UInteger
Dim LOBJID as UInteger
For X = 1 to 200
Particle_Add()
Next
Dim XParCount as ULong
Do
XParCount = 0
For X = 1 to G_ParticleC
If G_ParticleD(X).V_InUse = 1 Then XParCount += 1
Next
If XParCount < G_ParticleC Then
For X = 1 to G_ParticleC - XParCount
Particle_Add()
Next
End If
Particle_Calculate_Reorientation()
ScreenLock
Line (0, 0)-(G_Room_Width + 6, G_Room_Height + 6), RGB(0, 0, 0), BF
For X = 1 to G_ObjC
With G_ObjD(X)
If .V_InUse = 1 Then Line (.X, .Y)-(.X + .Size, .Y + .Size), .TColor, BF
End With
Next
For X = 1 to G_ParticleC
With G_ParticleD(X)
If .V_InUse = 1 Then
If G_ShowTColor = 0 Then
MX = .V_Presure * 5
If MX > 255 Then MX = 255
If MX < 0 Then MX = 0
XCol = RGB(MX, 255 - MX, 0)
Else: XCol = .V_Color
End If
'PSet (3 + .X, 3 + .Y), XCol
' Line (1 + .X - G_ShowSize, 1 + .Y - G_ShowSize)-(1 + G_ShowSize + .X, 1 + G_ShowSize + .Y), XCol, BF
Circle (1 + .X, 1 + .Y),G_ShowSize, XCol, , , , F
End If
End With
Next
ScreenUnlock
AKey = InKey()
If AKey <> LKey Then
Select Case asc(AKey)
Case 27: Exit Do
Case asc("a"): Particle_Add()
Case asc("c")
G_ParticleC = 0
Redim G_ParticleD(G_ParticleC) as G_Particle_2D_Type
Case asc("m")
For X = 1 to 10
Particle_Add()
Next
Case asc("o"): If G_ShowTColor = 0 Then G_ShowTColor = 1 Else G_ShowTColor = 0
Case asc("n"): Obj_Add()
Case asc("w"): If G_FlowOff = 0 Then G_FlowOff = 1 Else G_FlowOff = 0
End Select
LKey = AKey
Else
If AKey = "b" Then Particle_Add()
End If
GetMouse MX, MY, MZ, MB
TZ = (MZ - MZL) * 5
If MB > 0 or (MB = 0 and TZ <> 0) Then
If LOBJID = 0 Then OBJID = Obj_GetOnMouse(MX, MY)
If OBJID > 0 Then
LOBJID = OBJID
With G_ObjD(OBJID)
If MB = 1 Then
.X = MX - (.Size / 2)
.Y = MY - (.Size / 2)
End If
.Size += TZ
If .Size < 10 Then .Size = 10
If .Size > 200 Then .Size = 200
End With
If MB = 2 Then G_ObjD(OBJID).V_InUse = 0
End If
MZL = MZ
Else: If MB = 0 Then LOBJID = 0
End If
If XTot < Timer Then
Sleep 1, 1
XTot = Timer + 0.01
End If
Loop
Screen 0
End