Binaryworld - BTree - A class for managing binary trees ... [ VB -> Datastructure ]

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