Basisklassen

Public Class PriorityQueue
 
    Private a As ArrayList
    Private updown As Integer ' extract liefert Maximum (+1) oder Minimum (-1)

    Public Sub New(ByVal updown_ As Integer)
        a = New ArrayList()
        updown = updown_
    End Sub

    ' Objekt x mit Priorität p einfügen
    Public Sub insert(ByVal p As Double, ByVal x As Object)
        a.Add(New PqItem(p, x))   ' an ArrayList anhängen
        upheap()
    End Sub

    ' Eintrag maximaler Priorität zurückgeben und löschen
    Public Function extract() As PqItem
        Dim z As PqItem
        exchange(root(), lastLeaf())
        z = a.Item(lastLeaf())
        a.Remove(z)
        downheap()
        Return z
    End Function

    ' Objekt maximaler Priorität zurückgeben und löschen
    Public Function extractObj() As Object
        Return extract().getObject()
    End Function

    Private Sub upheap()
        Dim u, v As Integer
        v = lastLeaf()
        Do While Not isRoot(v)      ' v ist nicht die Wurzel
            u = pred(v)        ' u ist der Vorgänger
            If p(u) >= p(v) Then ' u hat die Heap-Eigenschaft
                Return
            Else
                exchange(u, v)
                v = u      ' weiter mit u
            End If
        Loop
    End Sub

    Private Sub downheap()
        Dim w, v As Integer
        v = root()
        Do While Not isLeaf(v)      ' v ist kein Blatt
            w = succ(v)        ' erster Nachfolger
            If exists(w + 1) Then ' gibt es einen zweiten Nachfolger?
                If p(w + 1) > p(w) Then
                    w = w + 1
                End If
            End If
            ' w ist der Nachfolger mit der größeren Markierung
            If (p(v) >= p(w)) Then ' v hat die Heap-Eigenschaft
                Return
            Else
                exchange(v, w)
                v = w            ' weiter mit w
            End If
        Loop
    End Sub

    ' liefert die Priorität des Eintrags v
    Private Function p(ByVal v As Integer) As Double
        Return updown*a.Item(v).getPriority()
    End Function

    ' Einträge an Position i und j vertauschen
    Private Sub exchange(ByVal i As Integer, ByVal j As Integer)
        Dim h As PqItem
        h = a.Item(i)
        a.Item(i) = a.Item(j)
        a.Item(j) = h
    End Sub

    ' Wurzel
    Private Function root() As Integer
        Return 0
    End Function

    ' letztes Blatt
    Private Function lastLeaf() As Integer
        Return size() - 1
    End Function

    ' Vorgänger
    Private Function pred(ByVal v As Integer) As Integer
        Return (v - 1) \ 2
    End Function

    ' erster Nachfolger
    Private Function succ(ByVal v As Integer) As Integer
        Return v*2 + 1
    End Function

    ' true, wenn v die Wurzel ist
    Private Function isRoot(ByVal v As Integer) As Integer
        Return v = 0
    End Function

    ' true, wenn v ein Blatt ist
    Private Function isLeaf(ByVal v As Integer) As Boolean
        Return v >= size() \ 2
    End Function

    ' true, wenn v existiert
    Private Function exists(ByVal v As Integer) As Boolean
        Return v < size()
    End Function

    ' true, wenn die Liste leer ist
    Public Function isEmpty() As Boolean
        Return size() = 0
    End Function

    ' Länge der Liste
    Public Function size() As Integer
        Return a.Count
    End Function

End Class

    Private Sub testPriorityQueue()
        Dim s, t As String
        Dim p As New PriorityQueue(-1)
        p.insert(3, "drei")
        p.insert(-1, "minus1")
        p.insert(4, "vier")
        p.insert(-3, "minus3")
        p.insert(2, "zwei")
        s = p.extractObj()
        t = p.extractObj()
        Label2.Text = s & " " & t
    End Sub

Public Class PqItem

    Private p As Double
    Private x As Object

    Public Sub New(ByVal p_ As Double, ByVal x_ As Object)
        p = p_
        x = x_
    End Sub

    Public Function getPriority() As Double
        getPriority = p
    End Function

    Public Function getObject() As Object
        getObject = x
    End Function

End Class