算法4 vba实现优先队列笔记

普通最大堆

' 优先队列


Private pq() As Variant

Private n As Integer


'创建一个优先队列
Private Sub class_initialize()

    ' 0 位置没有使用
    n = 0
    ReDim pq(1)
End Sub

' 创建一个初始容量为max的优先队列


'用 a[] 中的元素创建一个优先队列

Private Sub resize(max As Integer)
    ReDim Preserve pq(max)
End Sub

' 返回最大元素
Public Sub insert(i As Variant)
    ' 由于pq(0)不使用，所以少一个长度
    If n = UBound(pq) Then resize (2 * (UBound(pq)))
    n = n + 1
    pq(n) = i
    ' 上浮到合适的位置
    swim n
End Sub

' 删除并返回最大元素
Public Function delMax() As Variant

    Dim max As Variant
    
    ' 获取最大的元素
    max = pq(1)
    
    ' 和尾节点交换
    exch n, 1
    
    ' pq(n) = Null
    
    n = n - 1
    
    ' 下沉到合适位置
    sink 1
    
    
    delMax = max
    

End Function


' 返回队列是否为空
 Public Function isEmpty() As Boolean
 
    isEmpty = n = 0
    
 End Function
 
 ' 返回数量
 Public Function size() As Integer
 
    size = n
 
 End Function

' 上浮
Private Sub swim(ByVal i As Integer)

    While i > 1 And less(i / 2, i)
        exch i / 2, i
        i = i / 2
    Wend

End Sub


' 下沉
Private Sub sink(ByVal i As Integer, Optional num = 0)
    
    Dim j As Integer
    
    If num = 0 Then num = n
    
    ' 不能超过最后节点
    While 2 * i <= num
    
        ' 向下搜索节点 * 2
        j = 2 * i
        
        ' 先比较大的，如果是右边比较大，那么移动到右边节点
        If j < num Then
        
            If less(j, j + 1) Then j = j + 1
        End If
        ' 如果 pq(i) >= pq(j) 那么就退出，由于是下沉，此时已经移动到合适的节点，所以可以退出了
        If Not less(i, j) Then Exit Sub
        
        ' 交换到合适的节点
        exch i, j
        
        ' 索引也开始推进
        i = j
        
        
    Wend

End Sub

Private Function less(i As Variant, j As Variant)
    less = pq(i) < pq(j)
End Function

Private Sub exch(i As Variant, j As Variant)
    Dim temp As Variant
    
    temp = pq(i)
    
    pq(i) = pq(j)
    
    pq(j) = temp
End Sub

索引优先队列最小堆

做了很多细节上的优化，使用最小堆实现

' 索引优先队列，最小堆实现

' 索引二叉堆，由1开始，保证最小值的索引在最顶部
Private pq() As Variant

' pq的逆序
Private qp() As Variant

' pq中的数量
Private n As Integer

' 有优先级之分的元素
Private keys() As Variant


'创建一个优先队列
Private Sub class_initialize()

    ' 0 位置没有使用
    n = 0
    ReDim pq(1)
    ReDim qp(1)
    ReDim keys(1)
    
    qp(0) = -1
    qp(1) = -1
End Sub


' 新增元素，和索引i 关联
Public Sub insert(i As Integer, key As Variant)

    ' 由于pq(0)不使用，所以少一个长度
    checkMax pq, n
    
    n = n + 1
    
    ' 存储索引
    pq(n) = i
    
    checkMax qp, i, -1
    ' 逆
    qp(i) = n
    
    checkMax keys, i
    
    ' 关联元素
    keys(i) = key
    
    '把索引上浮到合适的位置
    swim n
End Sub



' 将索引i 的元素设置为s
Public Sub change(ByVal i As Integer, ByVal s As Variant)

    If Not contains(i) Then Err.Raise 404, "IndexMinPQ.change", "没有找到索引"
    
    '改变实际元素
    keys(i) = s
    
    ' 寻找合适的位置，将pq的索引上浮，下沉
    swim qp(i)
    sink qp(i)
End Sub

' 是否存在索引为i 的元素
Public Function contains(ByVal i As Integer) As Boolean

    contains = qp(i) <> -1

End Function

' 删除索引为i的元素
Public Sub delete(ByVal i As Integer)

    Dim index As Integer
    
    ' 找出pq索引
    index = qp(i)
    
    ' 和尾节点进行交换
    exch index, n
    
    n = n - 1
    
    ' 索引上浮
    swim index
    
    ' 索引下沉
    sink index
    
    ' 0 为无效值
    keys(i) = 0
    
    ' 保证正确的状态
    qp(i) = -1
    
    
    ' 如果删除的是最后的索引，检查是否需要压缩pq,keys数组
    If i = n + 1 Then checkMin qp, i - 1: checkMin keys, i - 1
    

End Sub

' 返回最小的元素
Public Function min() As Variant

    min = keys(pq(1))
    
End Function

' 返回最小元素的索引
Public Function minIndex() As Integer

    minIndex = pq(1)
    
End Function

' 删除并返回最小元素索引
Public Function delMin() As Integer

    Dim indexOfMin As Integer
    
    ' 找出头节点
    indexOfMin = pq(1)
    
    ' 和尾节点交换
    exch 1, n
    
    n = n - 1
    
    ' 最大索引下沉
    sink 1
    
    ' 清理工作
    keys(pq(n + 1)) = 0
    
    qp(pq(n + 1)) = -1
    
    
    checkMin pq, n: checkMin keys, qp(n): checkMin pq, pq(n)
    
    delMin = indexOfMin
End Function


' 返回队列是否为空
 Public Function isEmpty() As Boolean
 
    isEmpty = n = 0
    
 End Function
 
 ' 返回数量
 Public Function size() As Integer
 
    size = n
 
 End Function


' 检查最大越界
Private Sub checkMax(ByRef a() As Variant, _
                        ByVal n As Integer, _
                        Optional ByVal initValue As Integer = 0)
    Dim oldLength As Integer
    
    Dim index As Integer
    
    oldLength = UBound(a)
    
    '0 位置当作哨兵使用
    While n >= UBound(a)
        resize a, 2 * (UBound(a))
        
        ' qp 初始化需要稳定状态
        If initValue <> 0 Then
            For index = oldLength + 1 To UBound(a)
                a(index) = initValue
            Next
        
        End If
        oldLength = UBound(a)
    Wend
     
End Sub

' 检查最小越界
Private Sub checkMin(ByRef a() As Variant, ByVal n As Integer)

    While n > 0 And n <= UBound(a) / 4
        resize a, UBound(a) / 2
    Wend
    
End Sub

Private Sub resize(a() As Variant, max As Integer)

    ReDim Preserve a(max)
End Sub

' 更小上浮
Private Function swim(ByVal i As Integer) As Integer
    ' 如果 更小，就上浮
    While i > 1 And less(i, i / 2)
        exch i / 2, i
        i = i / 2
    Wend

    swim = i
End Function


' 更大下沉
Private Function sink(ByVal i As Integer) As Integer
    
    Dim j As Integer
    
    ' 不能超过最后节点
    While 2 * i <= n
    
        ' 向下搜索节点 * 2
        j = 2 * i
        
        
        ' 由于不能够短路，所以需要两层
        If j < n Then
            ' 这里是先比较小的，如果是右边比较小，那么移动到右边节点
             If less(j + 1, j) Then j = j + 1
             
        End If
        
        ' 如果 pq(i) <= pq(j) 那么就退出，由于是下沉，此时已经移动到合适的节点，所以可以退出了
        If Not less(j, i) Then Exit Function
        
        ' 交换到合适的节点
        exch i, j
        
        ' 索引也开始推进
        i = j
        
        
    Wend
    
    sink = i

End Function


Private Function less(i As Integer, j As Integer)
    less = keys(pq(i)) < keys(pq(j))
End Function

Private Function greater(i As Integer, j As Integer)
    less = keys(pq(i)) > keys(pq(j))
End Function

Private Sub exch(i As Integer, j As Integer)

    ' key 索引，存储于pq中
    Dim keyIndex As Integer
    ' pq索引，存储于qp中
    Dim pqIndex As Integer
    ' 元素索引
    keyIndex = pq(i)

    ' pq索引
    pqIndex = qp(keyIndex)
    
    qp(pq(i)) = qp(pq(j))
    
    pq(i) = pq(j)
    
    ' pq(i) 已经改变
    qp(pq(i)) = pqIndex
   
    pq(j) = keyIndex
    
End Sub

索引优先队列案例

索引优先队列可能比较难以明白使用场景，在哪种情况下，需要使用索引优先的队列？最常见的是把多个有序的输入流归并为一个有序的输出流。这里使用有序queue来代替有序流，实际中并不是这样，可以想象使用minPQ来创造源源不断的输入流，比如多个地点的火车时刻表（按时间排序），多家电影院的电影放映时间等等，如果数量是已知的，可以使用排序算法，但如果使用索引优先队列，无论有多长，都可以对他们完全读入并排序;queue代码，请参考以前的博客：

Sub fillQueue(a(), ByRef b As Queue)
    Dim j As Integer
    
    For j = 0 To UBound(a)
        b.enqueue a(j)
    Next

End Sub

' 索引优先队列用例
Sub multiWay()

    Dim d As New Queue
    
    Dim e As New Queue
    
    Dim f As New Queue
    
    Dim a()
    
    Dim b()
    
    Dim c()
    
    

    Dim shellSort As New shellSort
    
    a = Array(1, 4, 9, 8, 7, 0)
    shellSort.shellSort a
    fillQueue a, d
    
    b = Array(23, 3, 4, 0, 9, 4, 33)
    shellSort.shellSort b
    fillQueue b, e
    
    c = Array(2, 0, 90, 290, 8, 98, 890)
    shellSort.shellSort c
    fillQueue c, f

    Dim minPQ As New IndexMinPQ
    
    Dim i As Integer
    
    Dim arr() As Variant
    
    arr = Array(d, e, f)
    
    For i = 0 To UBound(arr)
        If Not arr(i).isEmpty() Then
            minPQ.insert i, CInt(arr(i).dequeue)
        End If
    Next

    While Not minPQ.isEmpty()
        Debug.Print minPQ.min
        
        ' 第几个数组中的数据被删除，从其中添加
        i = minPQ.delMin
        
        If Not arr(i).isEmpty() Then
            minPQ.insert i, CInt(arr(i).dequeue)
        End If
        
    Wend

End Sub