Home

Add

Edit

Without Linenumbers

Code in Textfield

Download

  1. '###########################################################################################################################
    
  2. Const MaxQuadDepth As Integer = 6
    
  3. 
    
  4. 
    
  5. 
    
  6. '###########################################################################################################################
    
  7. Type vec2
    
  8.     X As Single
    
  9.     Z As Single
    
  10. End Type
    
  11. '---------------------------------------------------------------------------------------------------------------------------
    
  12. Type tesTobj
    
  13.     min As vec2
    
  14.     max As vec2
    
  15.     col As Integer
    
  16.     HasDraw As Ubyte
    
  17. End Type
    
  18. 
    
  19. 
    
  20. 
    
  21. '###########################################################################################################################
    
  22. Sub CMsg (Byval Msg As String)
    
  23.     Dim FF As Integer
    
  24.     FF = Freefile
    
  25.     Open Cons For Output As #FF
    
  26.     Print #FF, Msg
    
  27.     Close #FF
    
  28. End Sub
    
  29. 
    
  30. 
    
  31. 
    
  32. '###########################################################################################################################
    
  33. ''Quadtree
    
  34. Type Quadtree
    
  35.     Declare Constructor()
    
  36.     Declare Constructor(lo As vec2, hi As vec2, QuadDepth As Integer = 0)
    
  37. 
    
  38.     Bound_lo      As vec2
    
  39.     Bound_hi      As vec2
    
  40.     Center        As vec2
    
  41. 
    
  42.     IsSplit       As Integer
    
  43.     Declare Function Split() As Integer
    
  44. 
    
  45.     QuadDepth     As Integer
    
  46.     Nodes(0 To 3) As Quadtree Ptr
    
  47. 
    
  48.     Declare Function AddObject(objdata As tesTobj Ptr) As Integer
    
  49. 
    
  50.     Objects_Count As Integer
    
  51.     Objects_Data  As tesTobj Ptr Ptr
    
  52. 
    
  53.     Declare Function Draw(min As vec2, max As vec2) As Integer
    
  54. End Type
    
  55. 
    
  56. 
    
  57. 
    
  58. '###########################################################################################################################
    
  59. Constructor Quadtree()
    
  60. With This
    
  61.     .Bound_lo      = Type(0, 0)
    
  62.     .Bound_hi      = Type(0, 0)
    
  63.     .Center        = Type(0, 0)
    
  64.     .QuadDepth     = 0
    
  65.     .Objects_Count = 0
    
  66.     .IsSplit       = 0
    
  67. End With
    
  68. End Constructor
    
  69. 
    
  70. 
    
  71. 
    
  72. '###########################################################################################################################
    
  73. Constructor Quadtree(lo As vec2, hi As vec2, QuadDepth As Integer = 0)
    
  74. With This
    
  75.     .Bound_lo      = lo
    
  76.     .Bound_hi      = hi
    
  77.     ''2D test!
    
  78.         .Center    = Type(lo.X + ((hi.X - lo.X) / 2), lo.Z + ((hi.Z - lo.Z) / 2))
    
  79.     ''3D
    
  80.         'this.Center.X =
    
  81.         'this.Center.Z =
    
  82.     .QuadDepth     = QuadDepth
    
  83.     .Objects_Count = 0
    
  84.     .IsSplit       = 0
    
  85. End With
    
  86. End Constructor
    
  87. 
    
  88. 
    
  89. 
    
  90. '###########################################################################################################################
    
  91. ''Quelle: http://www.back-side.net/codingrects.html
    
  92. Function QuadIntersection(Q1Start As vec2, Q1Len As vec2, Q2Start As vec2, Q2Len As vec2) As Integer
    
  93. Dim As Integer xl, zo, xr, zu 'Eckpunkte des umschriebenen Rechtecks: (xl,yo)-(xr-1,yu-1)
    
  94. 
    
  95. 'Bestimmen der Eckpunktkoordinaten
    
  96. xl = Q1Start.X           'links
    
  97. zo = Q1Start.Z           'oben
    
  98. xr = Q2Start.X + Q2Len.X 'rechts + 1
    
  99. zu = Q2Start.Z + Q2Len.Z 'unten  + 1
    
  100. 
    
  101. If Q2Start.X < Q1Start.X Then xl = Q2Start.X
    
  102. If Q2Start.Z < Q1Start.Z Then zo = Q2Start.Z
    
  103. 
    
  104. If (Q1Start.X + Q1Len.X) > (Q2Start.X + Q2Len.X) Then xr = Q1Start.X + Q1Len.X
    
  105. If (Q1Start.Z + Q1Len.Z) > (Q2Start.Z + Q2Len.Z) Then zu = Q1Start.Z + Q1Len.Z
    
  106. 
    
  107. 'Prüfen auf Kollision
    
  108. If ((Q1Len.X + Q2Len.X) > (xr - xl)) And ((Q1Len.Z + Q2Len.Z) > (zu - zo)) Then Return 1
    
  109. Return 0
    
  110. End Function
    
  111. 
    
  112. 
    
  113. 
    
  114. '###########################################################################################################################
    
  115. Function Quadtree.Split() As Integer
    
  116. With This
    
  117.     If (.IsSplit = 1) Or (.QuadDepth = MaxQuadDepth) Then Return 0
    
  118. 
    
  119.     'Upper Left
    
  120.     .Nodes(0)  = New Quadtree
    
  121.     *.Nodes(0) = Type<Quadtree>( Type<vec2>(.Bound_lo.X, .Bound_lo.Z), Type<vec2>(.Center.X, .Center.Z)    , .QuadDepth + 1)
    
  122. 
    
  123.     'Upper Right
    
  124.     .Nodes(1)  = New Quadtree
    
  125.     *.Nodes(1) = Type<Quadtree>( Type<vec2>(.Center.X, .Bound_lo.Z)  , Type<vec2>(.Bound_hi.X, .Center.Z)  , .QuadDepth + 1)
    
  126. 
    
  127.     'BotTom Left
    
  128.     .Nodes(2)  = New Quadtree
    
  129.     *.Nodes(2) = Type<Quadtree>( Type<vec2>(.Bound_lo.X, .Center.Z)  , Type<vec2>(.Center.X, .Bound_hi.Z)  , .QuadDepth + 1)
    
  130. 
    
  131.     'BotTom Right
    
  132.     .Nodes(3)  = New Quadtree
    
  133.     *.Nodes(3) = Type<Quadtree>( Type<vec2>(.Center.X, .Center.Z)    , Type<vec2>(.Bound_hi.X, .Bound_hi.Z), .QuadDepth + 1)
    
  134. 
    
  135.     .IsSplit = 1
    
  136. End With
    
  137. CMsg "Splitted:" + Str(QuadDepth + 1)
    
  138. Return 1
    
  139. End Function
    
  140. 
    
  141. 
    
  142. 
    
  143. '###########################################################################################################################
    
  144. Function Quadtree.Draw(min As vec2, max As vec2) As Integer
    
  145. With This 'With vereinfache die übersicht
    
  146.     'klammern sind unerlässlich!!!
    
  147.     If (.Bound_lo.X > min.X) And (.Bound_lo.Z > min.Z) And (.Bound_hi.X < max.X) And (.Bound_hi.Z < max.Z) And (.Objects_Count > 0) Then
    
  148.         For i As Integer = 0 To .Objects_Count - 1
    
  149.             With *.Objects_Data[i]
    
  150.                 If .HasDraw = 0 Then
    
  151.                     Line(.min.X, .min.Z)-(.max.X, .max.Z), .col, BF
    
  152.                     .HasDraw = 1
    
  153.                 End If
    
  154.             End With
    
  155.         Next i
    
  156.         Line (.Bound_lo.X, .Bound_lo.Z)-(.Bound_hi.X, .Bound_hi.Z), &hFF999999, B
    
  157.     End If
    
  158.     If .IsSplit = 1 Then
    
  159.         .Nodes(0)->Draw(min, max)
    
  160.         .Nodes(1)->Draw(min, max)
    
  161.         .Nodes(2)->Draw(min, max)
    
  162.         .Nodes(3)->Draw(min, max)
    
  163.     End If
    
  164. End With
    
  165. Return 0
    
  166. End Function   
    
  167. 
    
  168. 
    
  169. 
    
  170. '###########################################################################################################################
    
  171. Function Quadtree.AddObject(objdata As tesTobj Ptr) As Integer
    
  172. Dim QuadLen As vec2
    
  173. Dim ObjLen  As vec2
    
  174. With This
    
  175.     QuadLen = Type<vec2>(.Bound_hi.X - .Bound_lo.X, .Bound_hi.Z - .Bound_lo.Z)
    
  176.     ObjLen  = Type<vec2>((objdata->max.X) - (objdata->min.X) , (objdata->max.Z) - (objdata->min.Z))
    
  177.     If QuadIntersection(.Bound_lo, QuadLen, (objdata->min), ObjLen) = 1 Then
    
  178.         Dim Temp As Any Ptr = Reallocate(.Objects_Data, (.Objects_Count + 1) * 4)
    
  179.         .Objects_Data = Temp
    
  180.         .Objects_Data[.Objects_Count] = objdata
    
  181.         .Objects_Count += 1
    
  182.         If (.IsSplit = 1) Or (.Split() = 1) Then
    
  183.             .Nodes(0)->AddObject(objdata)
    
  184.             .Nodes(1)->AddObject(objdata)
    
  185.             .Nodes(2)->AddObject(objdata)
    
  186.             .Nodes(3)->AddObject(objdata)
    
  187.         End If
    
  188.         CMsg "Object Stored"
    
  189.     End If
    
  190. End With
    
  191. Return 0
    
  192. End Function
    
  193. 
    
  194. 
    
  195. 
    
  196. '###########################################################################################################################
    
  197. 'test Quadtree
    
  198. Randomize Timer
    
  199. Screen 19,32
    
  200. 
    
  201. Dim MyTree As Quadtree Ptr = New Quadtree
    
  202. *MyTree = Type<Quadtree>(Type<vec2>(0, 0), Type<vec2>(800, 600))
    
  203. 
    
  204. Dim TesToBJ         As tesTobj Ptr Ptr
    
  205. Dim TesToBJCount    As Uinteger = 99
    
  206. Dim TesToBJTemp     As tesTobj Ptr Ptr
    
  207. TesToBJ = Callocate(100 * 4)
    
  208. 
    
  209. Dim As Integer RndStartX, RndStartZ, RndSize, RndColor
    
  210. 
    
  211. For i As Integer = 0 To TesToBJCount
    
  212.     RndStartX = Rnd() * 800
    
  213.     RndStartZ = Rnd() * 600
    
  214.     RndSize   = Rnd() * 150
    
  215.     RndColor  = Rnd() * &hFFFFFF
    
  216.         
    
  217.     TesToBJ[i] = New tesTobj
    
  218.     With *TesToBJ[i]
    
  219.         .min = Type<vec2>(RndStartX, RndStartZ)
    
  220.         .max = Type<vec2>(RndStartX + RndSize, RndStartZ + RndSize)
    
  221.         .col = RndColor
    
  222.     End With
    
  223.     MyTree->AddObject(TesToBJ[i])
    
  224. Next i
    
  225. CMsg "Done"
    
  226. 
    
  227. Dim As Integer MouseX, MouseY
    
  228. Dim As Single vminX, vminZ, vmaxX, vmaxZ
    
  229. Dim switchcam As Integer
    
  230. 
    
  231. Do
    
  232.     Getmouse MouseX, MouseY
    
  233. 
    
  234.     If switchcam=0 Then
    
  235.         vminX=MouseX - 100: If vminX < 0 Then vminX = 0
    
  236.         vminZ=MouseY - 100: If vminZ < 0 Then vminZ = 0
    
  237. 
    
  238.         vmaxX=MouseX + 100: If vmaxX > 799 Then vmaxX = 799
    
  239.         vmaxZ=MouseY + 100: If vmaxZ > 599 Then vmaxZ = 599
    
  240.     Else
    
  241.         vminX = 0: vmaxX = 800
    
  242.         vminZ = 0: vmaxZ = 600
    
  243.     End If
    
  244. 
    
  245. 
    
  246.     If Multikey(99) Then
    
  247.         If switchcam=0 Then
    
  248.             switchcam=1
    
  249.         Else
    
  250.             switchcam=0
    
  251.         End If
    
  252.         While Multikey(99): Wend
    
  253.     End If
    
  254. 
    
  255.     'tree clear
    
  256.     TesToBJTemp = TesToBJ
    
  257.     For X As Uinteger = 1 To TesToBJCount
    
  258.         TesToBJTemp[X - 1]->HasDraw = 0
    
  259.     Next
    
  260.     
    
  261.     
    
  262.     Screenlock()
    
  263.         Cls()
    
  264.         MyTree->Draw(Type<vec2>(vminX, vminZ), Type<vec2>(vmaxX, vmaxZ))
    
  265.         Line(vminX, vminZ)-(vmaxX, vmaxZ), &hFF333333, B
    
  266.     Screenunlock()
    
  267. 
    
  268.     Sleep 1
    
  269. Loop Until Multikey(&h01) 
    
  270. 
    
  271.