VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CBin" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit ' binary tree, array Method Private GrowthFactor As Single Private InitialAlloc As Long ' fields associated with each node Private Left() As Long ' left child Private Right() As Long ' right child Private Parent() As Long ' parent Private key() As Variant ' user's key Private rec() As Variant ' user's data associated with key Private Root As Long ' root of binary tree Private Node As CNode ' class for allocating nodes Private Function FindNode(ByVal KeyVal As Variant) As Long ' inputs: ' KeyVal key of node to find ' returns: ' location of node ' action: ' Finds node with key KeyVal. ' errors: ' Dim x As Long ' find node specified by key x = Root Do While x <> 0 If key(x) = KeyVal Then FindNode = x Exit Function Else If KeyVal < key(x) Then x = Left(x) Else x = Right(x) End If End If Loop Raise errKeyNotFound, "CBin.FindNode" End Function Public Sub Insert(ByVal KeyVal, ByRef RecVal As Variant) ' inputs: ' KeyVal key of node to insert ' RecVal record associated with key ' action: ' Inserts record RecVal with key KeyVal. ' error: ' errDuplicateKey ' Dim x As Long Dim current As Long Dim p As Long ' allocate node for data and insert in tree ' find x's parent current = Root p = 0 Do While current <> 0 If key(current) = KeyVal Then Raise errDuplicateKey, "CBin.Insert" p = current If KeyVal < key(current) Then current = Left(current) Else current = Right(current) End If Loop ' setup new node x = Node.Alloc() If x > UBound(key) Then ReDim Preserve Left(1 To UBound(Left) * GrowthFactor) ReDim Preserve Right(1 To UBound(Right) * GrowthFactor) ReDim Preserve Parent(1 To UBound(Parent) * GrowthFactor) ReDim Preserve key(1 To UBound(key) * GrowthFactor) ReDim Preserve rec(1 To UBound(rec) * GrowthFactor) End If Parent(x) = p Left(x) = 0 Right(x) = 0 ' copy fields to node key(x) = KeyVal rec(x) = RecVal ' insert x in tree If p <> 0 Then If key(x) < key(p) Then Left(p) = x Else Right(p) = x End If Else Root = x End If End Sub Public Sub Delete(ByVal KeyVal As Variant) ' inputs: ' KeyVal key of node to delete ' action: ' Deletes record with key KeyVal. ' error: ' errKeyNotFound ' Dim x As Long Dim y As Long Dim z As Long z = FindNode(KeyVal) ' delete node z from tree ' find tree successor If Left(z) = 0 Or Right(z) = 0 Then y = z Else y = Right(z) Do While Left(y) <> 0 y = Left(y) Loop End If ' x is y's only child If Left(y) <> 0 Then x = Left(y) Else x = Right(y) End If ' remove y from the parent chain If x <> 0 Then Parent(x) = Parent(y) If Parent(y) <> 0 Then If y = Left(Parent(y)) Then Left(Parent(y)) = x Else Right(Parent(y)) = x End If Else Root = x End If ' if z and y are not the same, replace z with y. If y <> z Then Left(y) = Left(z) If Left(y) <> 0 Then Parent(Left(y)) = y Right(y) = Right(z) If Right(y) <> 0 Then Parent(Right(y)) = y Parent(y) = Parent(z) If Parent(z) <> 0 Then If z = Left(Parent(z)) Then Left(Parent(z)) = y Else Right(Parent(z)) = y End If Else Root = y End If Node.Free (z) Set rec(z) = Nothing Else Node.Free (y) Set rec(y) = Nothing End If End Sub Public Function Find(ByVal KeyVal) As Variant ' inputs: ' KeyVal key of node to delete ' returns: ' record associated with key ' action: ' Finds record with key KeyVal ' error: ' errKeyNotFound ' Find = rec(FindNode(KeyVal)) End Function Public Sub Init(ByVal InitialAllocVal As Long, ByVal GrowthFactorVal As Single) ' inputs: ' InitialAlloc initial allocation of nodes ' GrowthFactor amount for reallocation of nodes (.GT. 1) ' action: ' Initializes Bin class. Call once after allocating class. ' Root = 0 GrowthFactor = GrowthFactorVal ReDim Left(1 To InitialAllocVal) ReDim Right(1 To InitialAllocVal) ReDim Parent(1 To InitialAllocVal) ReDim key(1 To InitialAllocVal) ReDim rec(1 To InitialAllocVal) Set Node = New CNode Node.Init InitialAllocVal, GrowthFactorVal End Sub Public Sub Class_Terminate() Set Node = Nothing End Sub