Attribute VB_Name = "Bin" Option Explicit ' binary tree algorithm, object method Private Root As CBin ' root of binary tree Private Function FindNode(ByVal KeyVal As Variant) As CBin ' inputs: ' KeyVal key of node to find ' returns: ' location of node ' action: ' Finds node with key KeyVal. ' errors: ' Dim x As CBin ' find node specified by key Set x = Root Do While Not x Is Nothing If x.Key = KeyVal Then Set FindNode = x Exit Function Else If KeyVal < x.Key Then Set x = x.Left Else Set x = x.Right End If End If Loop Raise errKeyNotFound, "Bin.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 CBin Dim current As CBin Dim Parent As CBin ' allocate node for data and insert in tree ' find x's parent Set current = Root Set Parent = Nothing Do While Not current Is Nothing If current.Key = KeyVal Then Raise errDuplicateKey, "Bin.Insert" Set Parent = current If KeyVal < current.Key Then Set current = current.Left Else Set current = current.Right End If Loop ' setup new node Set x = New CBin Set x.Parent = Parent Set x.Left = Nothing Set x.Right = Nothing ' copy fields to node x.Key = KeyVal x.Rec = RecVal ' insert x in tree If Not Parent Is Nothing Then If x.Key < Parent.Key Then Set Parent.Left = x Else Set Parent.Right = x End If Else Set 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 CBin Dim y As CBin Dim z As CBin Set z = FindNode(KeyVal) ' delete node z from tree ' find tree successor If z.Left Is Nothing Or z.Right Is Nothing Then Set y = z Else Set y = z.Right Do While Not y.Left Is Nothing Set y = y.Left Loop End If ' x is y's only child If Not y.Left Is Nothing Then Set x = y.Left Else Set x = y.Right End If ' remove y from the parent chain If Not x Is Nothing Then Set x.Parent = y.Parent If Not y.Parent Is Nothing Then If y Is y.Parent.Left Then Set y.Parent.Left = x Else Set y.Parent.Right = x End If Else Set Root = x End If ' if z and y are not the same, replace z with y. If Not y Is z Then Set y.Left = z.Left If Not y.Left Is Nothing Then Set y.Left.Parent = y Set y.Right = z.Right If Not y.Right Is Nothing Then Set y.Right.Parent = y Set y.Parent = z.Parent If Not z.Parent Is Nothing Then If z Is z.Parent.Left Then Set z.Parent.Left = y Else Set z.Parent.Right = y End If Else Set Root = y End If ' z is no longer referenced, and is automatically freed Else ' y is no longer referenced, and is automatically freed 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 = FindNode(KeyVal).Rec End Function Public Sub Init() ' action: ' initialize memory ' Set Root = Nothing End Sub Private Sub ZapNode(x As CBin) ' inputs: ' x pointer to node ' action ' recursively set x's parents to Nothing ' If x Is Nothing Then Exit Sub Set x.Parent = Nothing ZapNode x.Left ZapNode x.Right End Sub Public Sub Term() ' action: ' free memory ' If Root Is Nothing Then Exit Sub ' remove all parent pointers ZapNode Root.Left ZapNode Root.Right ' now, freeing root will free whole tree Set Root = Nothing End Sub