Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Quadtree_Variante2
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 22.05.2012 14:12:38 |
'Objekte werden nach Ihrer Grösser ins Quadtree abgelegt und ein Verweis nur einmal im gesamten Baum gespeichert
'Sonderfallbehandlung: Objekte werden auch in der Wurzel des Baums abgelegt
'Vorteil - Es werden nur ein minimum an Sichtbaren Objekte gezeichnet
'Nachteil - Das einlagern erfordert je nach maximaler Tiefe mehr Zeit
' Objekte werden mehrfach im Baum verwiesen und müssen daher geprüft werden ob sie bereits gezeichnet sind
' Quadtree wird IMMER bis zur maximaltiefe geteilt
Randomize Timer
Const AnzahlObjekte as Integer = 1200
Const QuadMaxDepth as Integer = 6
'' Diese Klasse ist nur zu testzwecken
Type ObjectData
'Hält die Eckpunkte (bounding box) des Objekts fest
Min_X as Integer
Max_X as Integer
Min_Y as Integer
Max_Y as Integer
col as integer
'Hier können später sonstige relevanten Daten eingefügt werden
'sind für diesen Test aber nicht erforderlich
'Zeichnet das Objekt
Declare Sub Draw()
'Debug
hasdraw as integer
End Type
Sub ObjectData.Draw()
with this
line (.Min_X, .Min_Y) - (.Max_X, .Max_Y), .col, BF
'.hasdraw = 1
end with
End Sub
Function IfBoxKollision(BoxA_MinX as Integer, BoxA_MinY as Integer, BoxA_MaxX as Integer, BoxA_MaxY as Integer, _
BoxB_MinX as Integer, BoxB_MinY as Integer, BoxB_MaxX as Integer, BoxB_MaxY as Integer) as Integer
Dim as Integer XLeft, YUp, XRight, YDown 'Eckpunkte des umschriebenen Rechtecks
Dim as Integer BoxA_LenX, BoxA_LenY, BoxB_LenX, BoxB_LenY 'Seitenlänge beider Rechtecke
'Seitenlänge der Boxen feststellen
BoxA_LenX = BoxA_MaxX-BoxA_MinX
BoxA_LenY = BoxA_MaxY-BoxA_MinY
BoxB_LenX = BoxB_MaxX-BoxB_MinX
BoxB_LenY = BoxB_MaxY-BoxB_MinY
'Bestimmen der Eckpunktkoordinaten
XLeft = IIF(BoxA_MinX<BoxB_MinX, BoxA_MinX, BoxB_MinX) 'links
YUp = IIF(BoxA_MinY<BoxB_MinY, BoxA_MinY, BoxB_MinY) 'oben
XRight = IIF(BoxA_MaxX>BoxB_MaxX, BoxA_MaxX, BoxB_MaxX) 'rechts
YDown = IIF(BoxA_MaxY>BoxB_MaxY, BoxA_MaxY, BoxB_MaxY) 'unten
'Prüfen auf Kollision
If ( (BoxA_LenX + BoxB_LenX) > (XRight - XLeft) ) And ( (BoxA_LenY + BoxB_LenY) > (YDown - YUp)) Then Return 1
Return 0
End Function
'' Quadtree
Type Quadtree
Declare Constructor()
Declare Constructor(minx as Integer, miny as Integer, maxx as integer, maxy as integer)
'Enthält die Eckpunkte des Node
Min_X as Integer
Max_X as Integer
Min_Y as Integer
Max_Y as Integer
'Tiefe des Baums (0 = Wurzel)
Depth as Integer
'IsSplit: wurde bereits geteilt? (TRUE/FALSE)
IsSplit as Integer
'Enthält die 4 Child Nodes
Node(0 to 3) as Quadtree ptr
'Teilt das Node in 4 neue Child Nodes
Declare Function Split() as Integer
'Trägt einen Verweis eines Objekts in den Baum
Declare Sub AddObject(NewObject as ObjectData ptr)
'Enthält die Anzahl eingetragener Verweise zu Objekten
Objects_Count as Integer
'Liste der Verweise auf Objekte
Objects_Data as ObjectData ptr ptr
'Declare Sub Draw() ''Bei 3D wird die 'sichtbare Box' durch ein Frustum check ersetzt
'Alle sichtbaren Nodes/Objekte im Baum zeichnen
Declare Sub Draw(minx as integer, miny as integer, maxx as integer, maxy as integer)
Private:
FrameID as Integer
Declare Sub RealDraw(ID as integer)
End Type
Constructor Quadtree()
End Constructor
Constructor Quadtree(minx as Integer, miny as Integer, maxx as integer, maxy as integer)
with this
.Min_X = minx
.Max_X = maxx
.Min_Y = miny
.Max_Y = maxy
end with
End Constructor
Function Quadtree.Split() as Integer
Dim as Integer CenterX, CenterY
With this
'Wenn Node bereits aufgeteilt ist ODER die maximale
'Tiefe erreicht hat, nicht weiter aufteilen.
If (.IsSplit = 1) or (Depth = QuadMaxDepth) Then Return 0
'Mittelpunkt des Nodes ermitteln
CenterX = (.Min_X + ((.Max_X - .Min_X) / 2) )
CenterY = (.Min_Y + ((.Max_Y - .Min_Y) / 2) )
'4 Child Nodes erstellen
'links oben
.Node(0) = NEW Quadtree
'Eckpunkte
.Node(0) -> Min_X = .Min_X
.Node(0) -> Max_X = CenterX
.Node(0) -> Min_Y = .Min_Y
.Node(0) -> Max_Y = CenterY
'Tiefe
.Node(0) -> Depth = .Depth+1
'recht oben
.Node(1) = NEW Quadtree
.Node(1) -> Min_X = CenterX
.Node(1) -> Max_X = .Max_X
.Node(1) -> Min_Y = .Min_Y
.Node(1) -> Max_Y = CenterY
'Tiefe
.Node(1) -> Depth = .Depth+1
'links unten
.Node(2) = NEW Quadtree
.Node(2) -> Min_X = .Min_X
.Node(2) -> Max_X = CenterX
.Node(2) -> Min_Y = CenterY
.Node(2) -> Max_Y = .Max_Y
'Tiefe
.Node(2) -> Depth = .Depth+1
'rechts unten
.Node(3) = NEW Quadtree
.Node(3) -> Min_X = CenterX
.Node(3) -> Max_X = .Max_X
.Node(3) -> Min_Y = CenterY
.Node(3) -> Max_Y = .Max_Y
'Tiefe
.Node(3) -> Depth = .Depth+1
'Festhalten das Node geteilt wurde
.IsSplit = 1
End With
Return 1
End Function
Sub Quadtree.AddObject(NewObject as ObjectData ptr)
'Dim CenterX as Integer
'Dim CenterY as Integer
Dim Temp as any ptr
with this
'Mittelpunkt des Nodes ermitteln
'CenterX = (.Min_X + ((.Max_X - .Min_X) / 2) )
'CenterY = (.Min_Y + ((.Max_Y - .Min_Y) / 2) )
'Schneidet dieses Objekt dieses Node?
If IfBoxKollision ((NewObject -> Min_X), (NewObject -> Min_Y), (NewObject -> Max_X), (NewObject -> Max_Y), _
.Min_X, .Min_Y, .Max_X, .Max_Y) = 1 Then
'Objekt Verweis hinzufügen
Temp = reallocate (.Objects_Data, (.Objects_Count+1)*4) 'Speicher realloziieren
.Objects_Data = Temp
.Objects_Data[.Objects_Count] = NewObject 'Neuen Verweis eintragen
.Objects_Count += 1 'Objektzähler um 1 erhöhen
'Prüfen ob Node noch teilbar ist (QuadMaxDepth)
If .Depth < QuadMaxDepth Then
'Teilen
If (.IsSplit = 0) Then .Split()
'Objekt in tieferen Nodes Prüfen und ggfl. Verweis hinzufügen
.Node(0) -> AddObject(NewObject)
.Node(1) -> AddObject(NewObject)
.Node(2) -> AddObject(NewObject)
.Node(3) -> AddObject(NewObject)
End If
End If
End With
End Sub
Sub Quadtree.Draw(minx as integer, miny as integer, maxx as integer, maxy as integer)
Dim NewID as Integer
with this
Do
NewID = int(rnd*1000)
Loop while (NewID = .FrameID)
.FrameID = NewID
If (.Min_X >= minx) and (.Min_Y >= miny) and (.Max_X <= maxx) and (.Max_Y <= maxy) Then
.RealDraw(.FrameID)
Exit Sub
End If
If (.IsSplit = 1) Then
Node(0) -> Draw(minx, miny, maxx, maxy)
Node(1) -> Draw(minx, miny, maxx, maxy)
Node(2) -> Draw(minx, miny, maxx, maxy)
Node(3) -> Draw(minx, miny, maxx, maxy)
End If
end with
End Sub
'Sub Quadtree.Draw()
Sub Quadtree.RealDraw(ID as Integer)
with this
'Sonderfall!
'Objekte die, wegen ihrer grösser und/oder position nur in der
'Wurzel passten, müssen einzeln auf Sichtbarkeit geprüft werden!
'Ist dieses Node GANZ sichtbar?
'If (.Min_X >= minx) and (.Min_Y >= miny) and (.Max_X <= maxx) and (.Max_Y <= maxy) Then
'Befinden sich Objekte in diesem Node?
If (.Objects_Count > 0) Then
for i as integer=0 to Objects_Count-1
'Wurde Objekt schon gezeichnet?
If (.Objects_Data[i] -> hasdraw) <> ID Then
'Wenn nein, dann Zeichnen
.Objects_Data[i] -> hasdraw = ID
.Objects_Data[i] -> Draw()
End If
Next i
'Debugline
line (.Min_X, .Min_Y) - (.Max_X, .Max_Y), &hFFFFFFFF, B
End If
'Wenn Node geteilt dann untere Bäume Zeichnen
If (.IsSplit=1) Then
.Node(0) -> RealDraw(ID)
.Node(1) -> RealDraw(ID)
.Node(2) -> RealDraw(ID)
.Node(3) -> RealDraw(ID)
End If
'End If
End with
End Sub
''Screen
Screenres 800,600,32
''Welt/Quadtree
Dim Welt as Quadtree
Welt=Type<Quadtree>(0,0,800,600)
''Testobjekte erstellen
Dim as Integer o_StartX, o_StartY, o_Size, o_Col
Dim testobjekte as ObjectData ptr ptr
testobjekte=callocate(AnzahlObjekte*4)
'Dim as Integer XS, YS
for i as integer=0 to AnzahlObjekte-1
'o_StartX = rnd * 800
'o_StartY = rnd * 600
o_Size = 18'rnd * 50
o_Col = &hFFFF0000'rnd * &hFF0000
testobjekte[i] = NEW ObjectData
testobjekte[i] -> Min_X = o_StartX
testobjekte[i] -> Min_Y = o_StartY
testobjekte[i] -> Max_X = o_StartX+o_Size
testobjekte[i] -> Max_Y = o_StartY+o_Size
testobjekte[i] -> col = o_col
Welt.AddObject(testobjekte[i])
o_StartX += 20 : if (o_StartX > 799) Then o_StartY += 20 : o_StartX = 0
next i
Dim as Integer MouseX, MouseY
Dim as Integer vminX, vminY, vmaxX, vmaxY
Dim csize as integer=50
Dim switchcam as Integer
Dim FPS as Integer
Dim FTimer as Double
Dim LastFPS as Integer
FTimer = Timer
Dim NumDrawnObjects as Integer
do
If switchcam=0 then
getmouse MouseX, MouseY
vminX=MouseX-csize : if vminX<0 then vminX=0
vminY=MouseY-csize : if vminY<0 then vminY=0
vmaxX=MouseX+csize : if vmaxX>799 then vmaxX=799
vmaxY=MouseY+csize : if vmaxY>599 then vmaxY=599
Else
vminX=0:vmaxX=799
vminY=0:vmaxY=599
End If
If multikey(&h3B) Then
if switchcam=0 then
switchcam=1
Else
switchcam=0
end if
while multikey(&h3B):wend
end if
screenlock
cls
Welt.Draw(vminX,vminY,vmaxX,vmaxY)
NumDrawnObjects = 0
For i as integer=0 to AnzahlObjekte-1
If (testobjekte[i] -> hasdraw) = 1 Then NumDrawnObjects += 1
testobjekte[i] -> hasdraw = 0
Next i
line (vminX,vminY) - (vmaxX, vmaxY), &hFF333333, B
locate 1,1:?LastFPS,NumDrawnObjects
screenunlock
FPS+=1
If (Timer-FTimer) >= 1 Then
LastFPS = FPS : FPS = 0
FTimer += 1
End If
sleep 1
loop until multikey(&h01)