Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB5,VB6
Expertise: Intermediate
Jul 29, 2000

BTree - A class for managing binary trees

Option Explicit

' Class Name  : BTree
' Author      : John Holfelder
' Date        : 17-Apr-2000  12:08 pm
' Description : This class is a way of creating Binary search
'               trees.  Instead of pointers we use indexes.
'               Supports adding, removing and traversing the tree.
'               This is just the basic logic, file processing will be added
'               at a later time.
'
' Revisions   : This idea was taken from VBPJ May 2000
'               "Data Structures" article, by Francesco Balena


Private Type Node 'The indexes are used as pointers would be in C++
    value As Variant  'ToDO:  Put IsObject checks for this
    Deleteed As Boolean
    ParentIdx As Long '-1 is top of tree
    GEIdx As Long     '-1 is end of tree
    LTIdx As Long     '-1 is end of tree -5 IS FREE
End Type

Dim NodeList() As Node

Dim Root As Long      'Index of top Node
Dim FreeStart As Long 'Index of first Free Node

Const INITIAL_NODES As Long = 50
Const ALLOC_AMT As Long = 50
Const FREE_INDICATOR = -5
Const LEAF_NODE = -1
Const ROOT_NODE = -1


' chucnk size
Private m_ChunkSize As Long

'Count of elements on tree
Private m_Count As Long

Public Function Add(ByVal vKeyVal As Variant) As Long
    Dim ndx As Long
    Dim nextFreeIndx As Long
    Dim EndOfTree As Boolean

    If FreeStart = 0 Then ExpandList m_ChunkSize
    ' use the first free slot
    ndx = FreeStart
    nextFreeIndx = NodeList(ndx).GEIdx
    'Set up new node
    With NodeList(ndx)
        .ParentIdx = ROOT_NODE
        .GEIdx = LEAF_NODE
        .LTIdx = LEAF_NODE
        .Deleteed = False
        .value = vKeyVal
    End With

    'Check if it's first one
    If Root = 0 Then
        Root = ndx
        EndOfTree = True
    End If
    
    If Not EndOfTree Then
        AddHelper ndx, Root
    End If

    FreeStart = nextFreeIndx
    m_Count = m_Count + 1
    Add = ndx
End Function
Public Function Find(vKey As Variant) As Variant
    If Root = 0 Then
        Find = "NOT FOUND"
        Exit Function
    End If
    Find = FindHelper(vKey, Root)
End Function

Public Function Traverse() As Variant
Dim st$
    Process Root, st
    Traverse = st
End Function

Public Function RemoveNode(vKey As Variant) As Variant
' NODE removal needs to be broken into 3 distinct cases,
' of each case, we also need to see if we're removing
' the root node.  If so another node needs to be
' designated as the root.
'
' 3 CASES:
' 1)   The first and simplest case involves removing a bottom
'      node with no children, in this case we simply mark it as deleted.
'      if it's the root we have an empty tree after deletion.
'
' 2)   The next case is a node with 1 child.  In this case if the
'      node being deleted is the root, redisignate the child as
'      the root node, and mark the node as free.  Otherwise
'      simply connect the single child to its Grandparent.
'
' 3)   If the node being removed has 2 children, I chose to take
'      each child seperately and re-add  it to the main tree, after
'      marking the node to be deleted as Free.

Dim IdxToBeRemoved&
    IdxToBeRemoved = FindIndex(vKey)
    RemoveNode = 0
    If IdxToBeRemoved = -5 Then Exit Function 'Not Found
            
    RemoveNode = NodeList(IdxToBeRemoved).value
    m_Count = m_Count - 1
' For nodes with no children, we can just delete them
' This is by far the simplest case.

    If NodeList(IdxToBeRemoved).GEIdx = LEAF_NODE And NodeList(IdxToBeRemoved) _
        .LTIdx = LEAF_NODE Then
        If IdxToBeRemoved = Root Then
                Root = 0 'If this is the root it's a 1 node tree
                MarkNodeAsFree IdxToBeRemoved
                Exit Function
        End If
        If NodeList(NodeList(IdxToBeRemoved).ParentIdx).GEIdx = IdxToBeRemoved _
            Then
             NodeList(NodeList(IdxToBeRemoved).ParentIdx).GEIdx = LEAF_NODE
        Else
             NodeList(NodeList(IdxToBeRemoved).ParentIdx).LTIdx = LEAF_NODE
        End If
     
        MarkNodeAsFree IdxToBeRemoved
        Exit Function
    End If
    
' For nodes with only 1 child, just connect
' parent (of node to be deleted) with child.  If
' deleting the root node, make child the root.
    
     If NodeList(IdxToBeRemoved).GEIdx = LEAF_NODE Or NodeList(IdxToBeRemoved) _
         .LTIdx = LEAF_NODE Then
        'If removing root in this case make single child new Root
        If NodeList(IdxToBeRemoved).ParentIdx = ROOT_NODE Then
            MakeSingleChildRoot IdxToBeRemoved
        Else
            PointSingleChildToGrandparent IdxToBeRemoved
        End If
        MarkNodeAsFree IdxToBeRemoved
        Exit Function
     End If
 ' For nodes with 2 children, we must take each child
 ' and add it to the tree after we remove the node.  Each
 ' side should then fall into its proper place on the new
 ' resulting tree.
 
    If NodeList(IdxToBeRemoved).ParentIdx = ROOT_NODE Then
        RootWithTwoChildProcess IdxToBeRemoved
    Else
        TwoChildProcess IdxToBeRemoved
    End If
   
End Function

'--------------------------------------------
' Private procedures
'--------------------------------------------
Private Sub RootWithTwoChildProcess(IdxToBeRemoved&)
' Here we simply take one of the children of the root node,
' and make it the new root node.  The onthr child just gets added,
' this keeps the tree in proper order.

Dim GEChild&, LTChild&

    GEChild = NodeList(IdxToBeRemoved).GEIdx
    LTChild = NodeList(IdxToBeRemoved).LTIdx

    'Arbitrarilly we'll make the Child on the left
    '(GEIdx into the new root)
    NodeList(GEChild).ParentIdx = ROOT_NODE
    Root = GEChild
    MarkNodeAsFree IdxToBeRemoved
    AddTree LTChild, Root
End Sub

Private Sub TwoChildProcess(IdxToBeRemoved&)
' Used for a node with 2 children and a parent.

    Dim GEChild&, LTChild&, GrandParent&
    'First Seperate the 2 children & Grandparent
    GEChild = NodeList(IdxToBeRemoved).GEIdx
    LTChild = NodeList(IdxToBeRemoved).LTIdx
    GrandParent = NodeList(IdxToBeRemoved).ParentIdx
    
    'Make the path to the node being deleted
    'into a LEAF_NODE.
    If NodeList(GrandParent).LTIdx = IdxToBeRemoved Then
       NodeList(GrandParent).LTIdx = LEAF_NODE
    Else
       NodeList(GrandParent).GEIdx = LEAF_NODE
    End If
    
    'Release deleted node
    MarkNodeAsFree IdxToBeRemoved
    
    'Now add each child tree to the main tree in turn.
    'they should fall into their proper place
    AddTree GEChild, Root
    AddTree LTChild, Root
End Sub

Private Sub AddTree(ByRef IdxToAdd&, ByRef idx&)
'Add one tree onto another
    If NodeList(IdxToAdd).value < NodeList(idx).value Then
        If NodeList(idx).LTIdx = LEAF_NODE Then
              NodeList(idx).LTIdx = IdxToAdd
              NodeList(IdxToAdd).ParentIdx = idx
        Else
              AddTree IdxToAdd, NodeList(idx).LTIdx
        End If
    Else
        If NodeList(idx).GEIdx = LEAF_NODE Then
              NodeList(idx).GEIdx = IdxToAdd
              NodeList(IdxToAdd).ParentIdx = idx
        Else
              AddTree IdxToAdd, NodeList(idx).GEIdx
        End If
    End If
End Sub

Private Sub MakeSingleChildRoot(IdxToBeRemoved&)
Dim idx&
' Very similar to removing an atem from a linked list.

    If NodeList(IdxToBeRemoved).GEIdx = LEAF_NODE Then
        idx = NodeList(IdxToBeRemoved).LTIdx
    Else
        idx = NodeList(IdxToBeRemoved).GEIdx
    End If
    NodeList(idx).ParentIdx = ROOT_NODE
    Root = idx
End Sub

Private Sub PointSingleChildToGrandparent(ByRef IdxToBeRemoved&)
' For removal of an internal node with 1 child.
Dim ChildIdx As Long, GrandParent&

    If NodeList(IdxToBeRemoved).GEIdx = LEAF_NODE Then
        ChildIdx = NodeList(IdxToBeRemoved).LTIdx
    Else
        ChildIdx = NodeList(IdxToBeRemoved).GEIdx
    End If
    GrandParent = NodeList(IdxToBeRemoved).ParentIdx
    If NodeList(GrandParent).GEIdx = IdxToBeRemoved Then
        NodeList(GrandParent).GEIdx = ChildIdx
    Else
        NodeList(GrandParent).LTIdx = ChildIdx
    End If
    NodeList(ChildIdx).ParentIdx = GrandParent
End Sub

Private Sub Class_Initialize()
    ' initialize the linked list of free slots
    ReDim NodeList(0) As Node
    ExpandList INITIAL_NODES
    m_ChunkSize = ALLOC_AMT
End Sub

Private Sub ExpandList(ByVal numEls As Long)
    Dim ndx As Long, newFreeNdx As Long
    
    ' this will be the first free slot
    newFreeNdx = UBound(NodeList) + 1
    ' expand the list
    ReDim Preserve NodeList(UBound(NodeList) + numEls) As Node
    ' initialize the links for free items
    ' (note that the nextNdx value for the last element isn't correct
    For ndx = newFreeNdx To UBound(NodeList)
        NodeList(ndx).GEIdx = ndx + 1
        NodeList(ndx).LTIdx = FREE_INDICATOR
        NodeList(ndx).ParentIdx = -1
        NodeList(ndx).Deleteed = False
    Next
    ' append the existing chain of free slots
    ' (fixes the invalid value stored previously)
    NodeList(UBound(NodeList)).GEIdx = FreeStart
    ' this is the new start of the free list
    FreeStart = newFreeNdx
End Sub

' check whether an index is valid

Sub CheckIndex(ByVal Index As Long)
    If Index <= 0 Or Index > UBound(NodeList) Then Err.Raise 5
    If NodeList(Index).ParentIdx < 0 Then Err.Raise 5
End Sub

Private Function FindHelper(ByRef vKey As Variant, ByRef idx&) As Variant
        
' If matching key is found, return NodeList(idx).Value
' otherwise return NOT FOUND.
' Use recursive processing to walk the tree
     
        If idx = LEAF_NODE Then
            FindHelper = "NOT FOUND"
        ElseIf vKey = NodeList(idx).value And Not NodeList(idx).Deleteed Then
            FindHelper = NodeList(idx).value
        ElseIf vKey < NodeList(idx).value Then
            FindHelper = FindHelper(vKey, NodeList(idx).LTIdx)
        Else
            FindHelper = FindHelper(vKey, NodeList(idx).GEIdx)
        End If
      
End Function

Private Sub Process(ByRef idx&, ByRef ret$)
    If idx = LEAF_NODE Or idx = 0 Then
        Exit Sub
    End If
    With NodeList(idx)
        Process .GEIdx, ret
        If Not .Deleteed Then
            ret = ret & ", " & .value
        End If
        Process .LTIdx, ret
    End With
End Sub

Private Sub MarkNodeAsFree(newFreeIndx&)
'Place newly free node at top of the list
        With NodeList(newFreeIndx)
           .GEIdx = FreeStart
           .LTIdx = FREE_INDICATOR
           .ParentIdx = LEAF_NODE
           .value = FREE_INDICATOR
        End With
        FreeStart = newFreeIndx
End Sub

Private Function FindIndex(vKey As Variant) As Long
'Finds the index of the node with this key
'Returns -5 if not found
    If Root = 0 Then
        FindIndex = -5
        Exit Function
    End If
    FindIndex = FindIndexHelper(vKey, Root)
End Function

Private Function FindIndexHelper(vKey As Variant, idx&) As Long
        If idx = LEAF_NODE Then
            FindIndexHelper = -5
        ElseIf vKey = NodeList(idx).value And Not NodeList(idx).Deleteed Then
            FindIndexHelper = idx
        ElseIf vKey < NodeList(idx).value Then
            FindIndexHelper = FindIndexHelper(vKey, NodeList(idx).LTIdx)
        Else
            FindIndexHelper = FindIndexHelper(vKey, NodeList(idx).GEIdx)
        End If
End Function

Private Sub AddHelper(ByRef idxAdded&, ByRef idx&)
        If NodeList(idxAdded).value < NodeList(idx).value Then
            If NodeList(idx).LTIdx = LEAF_NODE Then
                'insert value
                NodeList(idx).LTIdx = idxAdded
                NodeList(idxAdded).ParentIdx = idx
            Else
                AddHelper idxAdded, NodeList(idx).LTIdx
            End If
        Else
            If NodeList(idx).GEIdx = LEAF_NODE Then
                'insert value
                NodeList(idx).GEIdx = idxAdded
                NodeList(idxAdded).ParentIdx = idx
            Else
                AddHelper idxAdded, NodeList(idx).GEIdx
            End If
        End If
End Sub

Public Property Get Count() As Long
    Count = m_Count
End Property

Public Sub RemoveAll()
    Root = 0
    FreeStart = 0
    ReDim NodeList(0) As Node
    m_Count = 0
End Sub

Private Sub Class_Terminate()
    RemoveAll
End Sub
John Holfelder
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date