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