Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Quadtree_Variante1
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 22.05.2012 14:12:18 |
'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 - Objekt-Verweise sind nur einmal vorhanden, eine Prüfung ob Objekt bereits gezeichnet wurde entfällt
'Nachteil - Eine Menge (nicht sichtbare) überflüssiger Objekte wird gezeichnet
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)
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) )
'Prüfen ob Node noch teilbar ist (QuadMaxDepth)
If .Depth < QuadMaxDepth Then
'Prüfen ob Object in einem tieferen Node passt
'links oben?
If ((NewObject -> Min_X) >= .Min_X ) and ((NewObject -> Min_Y) >= .Min_Y ) and _
((NewObject -> Max_X) <= CenterX) and ((NewObject -> Max_Y) <= CenterY) Then
'Object passt eine Ebene tiefer, ins Node links oben!
'Wenn Node noch nicht geteilt ist, dann jetzt teilen.
If (.IsSplit = 0) Then .Split()
'Objekt ins nächste Child Node übergeben.
.Node(0) -> AddObject(NewObject)
Exit Sub
End If'elseif verwenden?
' rechts oben?
If ((NewObject -> Min_X) >= CenterX) and ((NewObject -> Min_Y) >= .Min_Y ) and _
((NewObject -> Max_X) <= .Max_X ) and ((NewObject -> Max_Y) <= CenterY) Then
'Object passt eine Ebene tiefer, ins Node links oben!
'Wenn Node noch nicht geteilt ist, dann jetzt teilen.
If (.IsSplit = 0) Then .Split()
'Objekt ins nächste Child Node übergeben.
.Node(1) -> AddObject(NewObject)
Exit Sub
End If
' links unten?
If ((NewObject -> Min_X) >= .Min_X ) and ((NewObject -> Min_Y) >= CenterY) and _
((NewObject -> Max_X) <= CenterX) and ((NewObject -> Max_Y) <= .Max_Y ) Then
'Object passt eine Ebene tiefer, ins Node links oben!
'Wenn Node noch nicht geteilt ist, dann jetzt teilen.
If (.IsSplit = 0) Then .Split()
'Objekt ins nächste Child Node übergeben.
.Node(2) -> AddObject(NewObject)
Exit Sub
End If
' rechts unten?
If ((NewObject -> Min_X) >= CenterX) and ((NewObject -> Min_Y) >= CenterY) and _
((NewObject -> Max_X) <= .Max_X ) and ((NewObject -> Max_Y) <= .Max_Y ) Then
'Object passt eine Ebene tiefer, ins Node links oben!
'Wenn Node noch nicht geteilt ist, dann jetzt teilen.
If (.IsSplit = 0) Then .Split()
'Objekt ins nächste Child Node übergeben.
.Node(3) -> AddObject(NewObject)
Exit Sub
End If
End If
'Objekt passt in keine tiefere Ebene oder maximale teilung ist erreicht
'Objekt Verweis hier speichern
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
End With
End Sub
'Sub Quadtree.Draw()
Sub Quadtree.Draw(minx as integer, miny as integer, maxx as integer, maxy 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!
'Schneidet dieses Node unseren Sichtbaren Bereich?
If IfBoxKollision(.Min_X, .Min_Y, .Max_X, .Max_Y, _
minx, miny, maxx, maxy) = 1 Then
If (.Objects_Count > 0) Then
'Befinden wir uns in der Wurzel des Baums
If (.Depth = 0) Then
'Jedes Objekt auf sichtbarkeit prüfen
for i as integer=0 to Objects_Count-1
If IfBoxKollision( (.Objects_Data[i] -> Min_X), (.Objects_Data[i] -> Min_Y), _
(.Objects_Data[i] -> Max_X), (.Objects_Data[i] -> Max_Y), _
minx, miny, maxx, maxy ) = 1 Then Objects_Data[i] -> Draw()
Next i
Else
for i as integer=0 to Objects_Count-1
Objects_Data[i] -> Draw()
next i
End If
'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) -> 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 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)