vba 实现红黑树符号表

红黑树

• RedNode
• RedBlackTreeTable

RedNode

Enum NodeColor
    ' 红树
    RED = 0
    ' 黑树
    BLACK = 1
End Enum


' 二叉树左树
Private left As RedNode

' 二叉树右数
Private right As RedNode

Private key As Variant

Private value As Variant

Private treeSize As Long

Private color As NodeColor

Property Let letColor(ByVal b As NodeColor)
    color = b
End Property

Property Let letLeft(ByRef l As RedNode)
    Set left = l
End Property

Property Let letRight(ByRef r As RedNode)
    Set right = r
End Property

Property Let letKey(ByRef k As Variant)
    assign key, k
End Property

Property Let letValue(ByRef v As Variant)
    assign value, v
End Property

Property Let letTreeSize(i As Long)
    treeSize = i
End Property


Property Get getColor() As Integer
    getColor = color
End Property

Property Get getLeft() As RedNode
    Set getLeft = left
End Property

Property Get getRight() As RedNode
    Set getRight = right
End Property

Property Get getKey() As Variant
    assign getKey, key
End Property

Property Get getValue() As Variant
    assign getValue, value
End Property

Property Get getTreeSize() As Long
    getTreeSize = treeSize
End Property



Private Sub assign(ByRef x, ByVal y)

    If IsObject(y) Then
        Set x = y
    Else
        x = y
    End If

End Sub




           

RedBlackTreeTable

' 使用红黑树完成的符号表


Private root As RedNode

Private n As Long


' 暂时省略辅助的增加和缩减，如有需要，参照以前的博客
' 基本的符号表api


Public Sub putValue(key As Variant, val As Variant)
    Set root = doPut(root, key, val)
    root.letColor = BLACK
End Sub


' 数量
Function size() As Long
    size = doSize(root)
End Function

Private Function doSize(ByRef x As RedNode) As Long
    If x Is Nothing Then doSize = 0: Exit Function
    
    doSize = x.getTreeSize
    
End Function

Private Function doPut(x As RedNode, key As Variant, val As Variant) As RedNode
    Dim xKey As Variant
    
    ' 如果节点为空
    If x Is Nothing Then
        Dim newNode As New RedNode
        newNode.letKey = key
        newNode.letValue = val
        newNode.letColor = RED
        newNode.letTreeSize = 1
        Set doPut = newNode
        Exit Function
    End If
    
    xKey = x.getKey
    
    If key > xKey Then
        x.letRight = doPut(x.getRight, key, val)
    ElseIf key < xKey Then
        x.letLeft = doPut(x.getLeft, key, val)
    Else
        x.letValue = val
    End If
    
    '1. 如果右边是红树，且左边不是红树，就左旋，类似于插入3-中间值的第一次处理，交由步骤2处理，
    If isRed(x.getRight) Then
        If Not isRed(x.getLeft) Then Set x = rotateLeft(x)
    End If
    
    '2. 如果左边是红树，左边的左边还是红树，就对左边的树进行右旋，类似于插入3-最小的值，由步骤3将节点变为黑树
    If isRed(x.getLeft) Then
        If isRed(x.getLeft.getLeft) Then Set x = rotateRight(x)
    End If
    
    ' 如果左边也是红树，右边也是红树，将两个节点变为黑树，类似于插入最大值，最简单的模型
    If isRed(x.getRight) Then
        If isRed(x.getLeft) Then flipColors x
    End If
    
    x.letTreeSize = 1 + doSize(x.getLeft) + doSize(x.getRight)
    Set doPut = x
End Function


' 获取键的值，如果键为空，就返回空
Function getValue(key As Variant) As Variant
    Dim node As RedNode
    
    
    Set node = doGet(key, root)
    If node Is Nothing Then getValue = Null: Exit Function
     getValue = node.getValue
End Function

Private Function doGet(key As Variant, x As RedNode) As RedNode
    Dim xKey As Variant
    
    If x Is Nothing Then Set doGet = Nothing: Exit Function
    xKey = x.getKey
    
    If key < xKey Then
        Set doGet = doGet(key, x.getLeft)
    ElseIf key > xKey Then
        Set doGet = doGet(key, x.getRight)
    Else
        Set doGet = x
    End If
End Function


' 删除最小的键
Sub deleteMin()
    Set root = doDeleteMin(root)
End Sub


Function doDeleteMin(x As RedNode) As RedNode
    Dim lNode As RedNode
    
    Set lNode = x.getLeft
    
    ' 如果左边为空，说明已经到了最小值，返回右边的节点，即使是空
    If lNode Is Nothing Then
        Set doDeleteMin = x.getRight
    Else
        ' 如果左边不为空，则说明没有到最小的节点，继续查找，将返回的节点挂入左边，如果最小节点右边没有节点，将返回nothing,也删除了最小节点，如果最小节点右边有节点，则返回的右边节点，挂入当前节点的左节点
        x.letLeft = doDeleteMin(x.getLeft)
        ' 删除一个，数量递归减去一个
        x.letThreeSize = x.getThreeSize - 1
        Set doDeleteMin = x
    End If

End Function

' 删除最大的键
Sub deleteMax()
    Set root = doDeleteMax(root)
End Sub

Function doDeleteMax(x As RedNode) As RedNode
    Dim rNode As RedNode
    
    
    Set rNode = x.getRight
    
    If rNode Is Nothing Then
        Set doDeleteMax = x.getLeft
    Else
        x.letRight = doDeleteMax(x.getRight)
        x.letThreeSize = x.getThreeSize - 1
        Set doDeleteMax = x
    End If
End Function

' 从表中删除主键
Sub delete(key As Variant)

    
End Sub


Function doDelete(x As RedNode, key As Variant) As RedNode
    
    
End Function


' 主键是否存在于符号表中
Function contains(key As Variant) As Boolean

End Function

' 是否为空
Function isEmpty() As Boolean
    isEmpty = n = 0
End Function

' 最小的主键
Function min() As Variant
    Dim minNode As RedNode
    
    Set minNode = doMin(root)
    
    assign min, minNode.getValue
End Function

Function doMin(x As RedNode) As RedNode
    If x.getLeft Is Nothing Then
        Set doMin = x
    Else
        Set doMin = doMin(x.getLeft)
    End If
End Function

' 最大的主键
Function max() As Variant
    Dim maxNode As RedNode
    
    Set maxNode = doMax(root)
    
    assign max, maxNode.getValue
End Function

Function doMax(x As RedNode) As RedNode
    If x.getRight Is Nothing Then
        Set doMax = x
    Else
        Set doMax = doMax(x.getRight)
    End If
End Function

' 小于等于key的最大键
Function floor(key As Variant) As Variant
    
    Dim n As RedNode
    
    Set n = doFloor(root, key)
    
    If n Is Nothing Then assign floor, Null: Exit Function
    
    assign floor, n.getValue
    

End Function

' 抽象出通用操作
' 需要取出小于等于key的最大值
' 如果相等，返回节点，这没什么说的，后面不讨论相等情况
' 如果值从左边返回，结果为null,那么就是没有找到，因为需要找到比key小的 key，排除相等，必须找到一个比key小的key，然后取右边节点。左边返回null，只能说明整颗树或者子树中都没有找到
' 如果右边返回null，说明就是当前节点，直接返回当前节点
Function doFloor(x As RedNode, key As Variant) As RedNode
    Dim xKey As Variant
    
    Dim temp As RedNode
    
    If x Is Nothing Then
        Set doFloor = Nothing
    Else
        assign xKey, x.getKey
        
        If key = xKey Then Set doFloor = x: Exit Function
        
        If key < xKey Then Set doFloor = doFloor(x.getLeft, key): Exit Function
        
        If key > xKey Then
            Set temp = doFloor(x.getRight, key)
            If temp Is Nothing Then
                Set doFloor = x
            Else
                Set doFloor = temp
            End If
        End If
        
    End If
    
End Function

' 大于等于key的最小键
Function ceiling(key As Variant) As Variant
    Dim n As RedNode
    
    Set n = doCeiling(root, key)
    If n Is Nothing Then assign ceiling, Null: Exit Function
    
    assign ceiling, n.getValue
    
End Function


' 抽象出通用操作
' 需要取出大于等于key的最小值
' 如果相等，返回节点，这没什么说的，后面不讨论相等情况
' 如果值从右边返回，结果为null,那么就是没有找到，因为需要找到比key大的 key，排除相等，必须找到一个比key大的key，然后取左边节点。右边返回null，只能说明整颗树或者子树中都没有找到
' 如果左边返回null，说明就是当前节点，直接返回当前节点
Function doCeiling(x As RedNode, key As Variant) As RedNode
    
    Dim xKey As Variant
    
    Dim temp As RedNode
    
    If x Is Nothing Then
        Set doCeiling = Nothing
    Else
        assign xKey, x.getKey
        If key = xKey Then Set doCeiling = x: Exit Function
        
        If key > xKey Then
            Set doCeiling = doCeiling(x.getRight, key): Exit Function
        End If
        
        If key < xKey Then
            Set temp = doCeiling(x.getLeft, key)
            
            If temp Is Nothing Then
                Set doCeiling = x
            Else
                Set doCeiling = temp
            End If
            
        End If
        
        
    
    End If
    
End Function

' 小于key的数量
Function rank(key As Variant) As Long
    rank = doRank(root, key)
End Function


Function doRank(x As RedNode, key As Variant) As Long
    Dim xKey As Variant
    Dim lSize As Long
    
    If x Is Nothing Then doRank = 0: Exit Function
    
    lSize = doSize(x.getLeft)
    
    xKey = x.getKey
    
    If key > xKey Then
        doRank = lSize + 1 + doRank(x.getRight, key)
    ElseIf key < xKey Then
        doRank = doRank(x.getLeft, key)
    Else
        doRank = lSize
    End If
    
    
End Function

' 排名为key的键
Function find(k As Long) As Variant
    
    Dim fNode As RedNode
    
    Set fNode = doFind(root, k)
    
    If fNode Is Nothing Then assign find, Null
    
    assign find, fNode.getKey
    
    
End Function


Function doFind(x As RedNode, k As Long) As RedNode
    Dim lSize As Long
    
    ' 正常情况下，是不可能到这个地方的。在某个节点必有满足k = lSize的情况
    If x Is Nothing Then Set doFind = Nothing: Exit Function
    
    lSize = doSize(x.getLeft)
    
    If lSize > k Then
        ' 完全满足，可以放心继续探查
        Set doFind = doFind(x.getLeft, k)
        
    ElseIf lSize < k Then
        ' 如果lSize < k 说明左边的节点不能满足k排名，需要向右边继续查找，不过不需要在查找key,需要查找k - lSize - 1
        Set doFind = doFind(x.getRight, k - lSize - 1)
    Else
        Set doFind = x
    End If
    
    
End Function


' 键之间的数量
Function sizeRange(low As Variant, high As Variant)
    sizeRange = doSizeRange(root, low, high)
End Function

Function doSizeRange(x As RedNode, low As Variant, high As Variant) As Long
    If x Is Nothing Then doSizeRange = 0: Exit Function
    
    Dim xKey As Variant
    Dim size As Long
    
    assign xKey, x.getKey
    
    If xKey > low Then
        size = size + doSizeRange(x.getLeft, low, high)
    End If
    
    If xKey >= low And xKey <= high Then
        size = size + 1
    End If
    
    If xKey < high Then
        size = size + doSizeRange(x.getRight, low, high)
    End If
    doSizeRange = size
    
End Function
' 键之间的所有主键
Function keysRange(low As Variant, high As Variant) As Collection
    Dim c As New Collection
    
    doKeysRange root, c, low, high
    Set keysRange = c
End Function

' 中序遍历
Sub doKeysRange(x As RedNode, c As Collection, low As Variant, high As Variant)
    If x Is Nothing Then Exit Sub
    
    Dim xKey As Variant
    
    assign xKey, x.getKey
    
    If xKey > low Then
        doKeysRange x.getLeft, c, low, high
    End If
    
    If xKey >= low And xKey <= high Then
        c.add xKey
    End If
    
    If xKey < high Then
        doKeysRange x.getRight, c, low, high
    End If
End Sub

' 所有主键
Function keysAll() As Collection
    Dim c As New Collection
    
    doKeysRange root, c, min(), max()
    
    Set keysAll = c
End Function






'---------- 保证有序性和平衡性的辅助方法----------------------

' --------- 放入公共部分，如果放入节点，太占空间，因为节点可能有很多---------

' 是否是红连接
Public Function isRed(x As RedNode) As Boolean
    If x Is Nothing Then isRed = False: Exit Function
    Dim color As NodeColor
    color = x.getColor
    isRed = color = RED
End Function

' 节点左旋转
Public Function rotateLeft(x As RedNode) As RedNode
    Dim rNode As RedNode
    Set rNode = x.getRight
    '  介于两者之间的节点（rNode.getLeft）需要挂到合适的节点，在这里是返回节点的左节点的右子节点，可以画图分析
    x.letRight = rNode.getLeft
    
    rNode.letLeft = x
    rNode.letColor = x.getColor
    ' 自己成为红节点
    x.letColor = RED

    ' 右边节点的数量继承自己的数量
    rNode.letTreeSize = treeSize
    '
    x.letTreeSize = 1 + doSize(x.getRight) + doSize(x.getLeft)
    Set rotateLeft = rNode
End Function

' 节点右旋转
Public Function rotateRight(x As RedNode) As RedNode
    Dim lNode As RedNode
    
    Set lNode = x.getLeft
    
    ' 介于两者之间的节点需要挂到合适的节点，在这里是返回节点的右节点的左子节点，可以画图分析
    x.letLeft = lNode.getRight
    
    lNode.letRight = x
    lNode.letColor = x.getColor
    x.letColor = RED

    lNode.letTreeSize = treeSize
    
    x.letTreeSize = 1 + doSize(x.getLeft) + doSize(x.getRight)
    
    Set rotateRight = lNode
End Function

' 两个节点变黑，由于自己处于中间节点，上升了一层，所有自己变红
Sub flipColors(x As RedNode)
    x.letColor = RED
    x.getRight.letColor = BLACK
    x.getLeft.letColor = BLACK
End Sub

Private Sub assign(ByRef x, ByVal y)

    If IsObject(y) Then
        Set x = y
    Else
        x = y
    End If

End Sub