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