VB-2012 / 2-cеместр / Дневники / Самостоятельная работа / trees / QTRNODE

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "QtreeNode"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
' ************************************************
' QtrNode.CLS
'
' Quadtree node class for quadtree program.
' ************************************************
' Copyright (C) 1997 John Wiley & Sons, Inc.
' All rights reserved. See additional copyright
' information in RIGHTS.TXT.
' ************************************************
Option Explicit

Const MAX_PER_NODE = 100 ' Max items per node.

' The children.
Public NWchild As QtreeNode
Public NEchild As QtreeNode
Public SWchild As QtreeNode
Public SEchild As QtreeNode

' The items.
Public Items As New Collection
' ************************************************
' Divide this node if necessary.
' ************************************************
Public Sub DivideNode(xmin As Single, xmax As Single, ymin As Single, ymax As Single)
Dim xmid As Single
Dim ymid As Single
Dim obj As QtreeItem

If Items.Count <= MAX_PER_NODE Then Exit Sub

' Create the children.
Set NWchild = New QtreeNode
Set NEchild = New QtreeNode
Set SWchild = New QtreeNode
Set SEchild = New QtreeNode

' Divide the items among the children.
xmid = (xmin + xmax) / 2
ymid = (ymin + ymax) / 2

Do While Items.Count > 0
Set obj = Items.Item(1)

' See in which child the item belongs.
If obj.X <= xmid Then
If obj.Y <= ymid Then
' NW child.
NWchild.Items.Add obj
Else
' SW child.
SWchild.Items.Add obj
End If
Else
If obj.Y <= ymid Then
' NE child.
NEchild.Items.Add obj
Else
' SE child.
SEchild.Items.Add obj
End If
End If

' Remove the item from this node.
Items.Remove 1
Loop

' Recursively divide the children if necessary.
NWchild.DivideNode xmin, xmid, ymin, ymid
NEchild.DivideNode xmid, xmax, ymin, ymid
SWchild.DivideNode xmin, xmid, ymid, ymax
SEchild.DivideNode xmid, xmax, ymid, ymax
End Sub

' ************************************************
' Find the quadtree leaf node that includes this
' point.
' ************************************************
Public Function LocateLeaf(X As Single, Y As Single, xmin As Single, xmax As Single, ymin As Single, ymax As Single) As QtreeNode
Dim xmid As Single
Dim ymid As Single
Dim node As QtreeNode

If NWchild Is Nothing Then
' We have no children. It must be this node.
Set LocateLeaf = Me
Exit Function
End If

' Search the appropriate child.
xmid = (xmax + xmin) / 2
ymid = (ymax + ymin) / 2
If X <= xmid Then
If Y <= ymid Then
Set LocateLeaf = NWchild.LocateLeaf( _
X, Y, xmin, xmid, ymin, ymid)
Else
Set LocateLeaf = SWchild.LocateLeaf( _
X, Y, xmin, xmid, ymid, ymax)
End If
Else
If Y <= ymid Then
Set LocateLeaf = NEchild.LocateLeaf( _
X, Y, xmid, xmax, ymin, ymid)
Else
Set LocateLeaf = SEchild.LocateLeaf( _
X, Y, xmid, xmax, ymid, ymax)
End If
End If
End Function

' ************************************************
' Find the closest item to the indicated point
' within this leaf node.
' ************************************************
Public Sub NearPointInLeaf(X As Single, Y As Single, best_item As QtreeItem, best_dist As Single, comparisons As Long)
Dim new_item As QtreeItem
Dim Dx As Single
Dim Dy As Single
Dim new_dist As Single

' Start with a terrible solution.
best_dist = 10000000
Set best_item = Nothing

' If there are no items in the leaf, stop now.
If Items.Count < 1 Then Exit Sub

For Each new_item In Items
comparisons = comparisons + 1
Dx = new_item.X - X
Dy = new_item.Y - Y
new_dist = Dx * Dx + Dy * Dy
If best_dist > new_dist Then
best_dist = new_dist
Set best_item = new_item
End If
Next new_item
End Sub

' ************************************************
' Check leaves near the indicated leaf to see if
' they have items closer to the given item than
' the best found so far.
' ************************************************
Public Sub CheckNearbyLeaves(exclude As QtreeNode, X As Single, Y As Single, best_item As QtreeItem, best_dist As Single, comparisons As Long, xmin As Single, xmax As Single, ymin As Single, ymax As Single)
Dim xmid As Single
Dim ymid As Single
Dim new_dist As Single
Dim new_item As QtreeItem

' If this is the leaf we are to exclude,
' do nothing.
If Me Is exclude Then Exit Sub

' If this is a leaf node, check it out.
If SWchild Is Nothing Then
NearPointInLeaf X, Y, new_item, new_dist, comparisons
If best_dist > new_dist Then
best_dist = new_dist
Set best_item = new_item
End If
Exit Sub
End If

' See which children fall within best_dist
' of the point.
xmid = (xmax + xmin) / 2
ymid = (ymax + ymin) / 2
If X - Sqr(best_dist) <= xmid Then
' The West children are eligible.
If Y - Sqr(best_dist) <= ymid Then
' Check the NorthWest child.
NWchild.CheckNearbyLeaves _
exclude, X, Y, best_item, _
best_dist, comparisons, _
xmin, xmid, ymin, ymid
End If
If Y + Sqr(best_dist) > ymid Then
' Check the SouthWest child.
SWchild.CheckNearbyLeaves _
exclude, X, Y, best_item, _
best_dist, comparisons, _
xmin, xmid, ymid, ymax
End If
End If
If X + Sqr(best_dist) > xmid Then
' The East children are eligible.
If Y - Sqr(best_dist) <= ymid Then
' Check the NorthEast child.
NEchild.CheckNearbyLeaves _
exclude, X, Y, best_item, _
best_dist, comparisons, _
xmid, xmax, ymin, ymid
End If
If Y + Sqr(best_dist) > ymid Then
' Check the SouthEast child.
SEchild.CheckNearbyLeaves _
exclude, X, Y, best_item, _
best_dist, comparisons, _
xmid, xmax, ymid, ymax
End If
End If
End Sub