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 BalenaPrivate 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 FREEEnd TypeDim NodeList() As NodeDim Root As Long      'Index of top NodeDim FreeStart As Long 'Index of first Free NodeConst INITIAL_NODES As Long = 50Const ALLOC_AMT As Long = 50Const FREE_INDICATOR = -5Const LEAF_NODE = -1Const ROOT_NODE = -1' chucnk sizePrivate m_ChunkSize As Long'Count of elements on treePrivate m_Count As LongPublic 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 = ndxEnd FunctionPublic Function Find(vKey As Variant) As Variant    If Root = 0 Then        Find = "NOT FOUND"        Exit Function    End If    Find = FindHelper(vKey, Root)End FunctionPublic Function Traverse() As VariantDim st$    Process Root, st    Traverse = stEnd FunctionPublic 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, RootEnd SubPrivate 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, RootEnd SubPrivate 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 IfEnd SubPrivate 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 = idxEnd SubPrivate 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 = GrandParentEnd SubPrivate Sub Class_Initialize()    ' initialize the linked list of free slots    ReDim NodeList(0) As Node    ExpandList INITIAL_NODES    m_ChunkSize = ALLOC_AMTEnd SubPrivate 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 = newFreeNdxEnd Sub' check whether an index is validSub CheckIndex(ByVal Index As Long)    If Index <= 0 Or Index > UBound(NodeList) Then Err.Raise 5    If NodeList(Index).ParentIdx < 0 Then Err.Raise 5End SubPrivate 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 FunctionPrivate 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 WithEnd SubPrivate 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 = newFreeIndxEnd SubPrivate 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 FunctionPrivate 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 IfEnd FunctionPrivate 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 IfEnd SubPublic Property Get Count() As Long    Count = m_CountEnd PropertyPublic Sub RemoveAll()    Root = 0    FreeStart = 0    ReDim NodeList(0) As Node    m_Count = 0End SubPrivate Sub Class_Terminate()    RemoveAllEnd Sub