Task: Priority queue








VB: Type Tuple
    Priority As Integer
    Data As String
End Type
Dim a() As Tuple
Dim n As Integer 
Private Function Left(i As Integer) As Integer
    Left = 2 * i + 1
End Function
Private Function Right(i As Integer) As Integer
    Right = 2 * i + 2
End Function
Private Function Parent(i As Integer) As Integer
    Parent = (i - 1) \ 2
End Function
Private Sub Add(fPriority As Integer, fData As String)
    n = n + 1
    If n > UBound(a) Then ReDim Preserve a(2 * n)
    a(n - 1).Priority = fPriority
    a(n - 1).Data = fData
    bubbleUp (n - 1)
End Sub
Private Sub Swap(i As Integer, j As Integer)
    Dim t As Tuple
    t = a(i)
    a(i) = a(j)
    a(j) = t
End Sub
Private Sub bubbleUp(i As Integer)
    Dim p As Integer
    p = Parent(i)
    Do While i > 0 And a(i).Priority < a(p).Priority
        Swap i, p
        i = p
        p = Parent(i)
    Loop
End Sub
Private Function Remove() As Tuple
    Dim x As Tuple
    x = a(0)
    a(0) = a(n - 1)
    n = n - 1
    trickleDown 0
    If 3 * n < UBound(a) Then ReDim Preserve a(UBound(a) \ 2)
    Remove = x
End Function
Private Sub trickleDown(i As Integer)
    Dim j As Integer, l As Integer, r As Integer
    Do
        j = -1
        r = Right(i)
        If r < n And a(r).Priority < a(i).Priority Then
            l = Left(i)
            If a(l).Priority < a(r).Priority Then
                j = l
            Else
                j = r
            End If
        Else
            l = Left(i)
            If l < n And a(l).Priority < a(i).Priority Then j = l
        End If
        If j >= 0 Then Swap i, j
        i = j
    Loop While i >= 0
End Sub
Public Sub PQ()
    ReDim a(4)
    Add 3, "Clear drains"
    Add 4, "Feed cat"
    Add 5, "Make tea"
    Add 1, "Solve RC tasks"
    Add 2, "Tax return"
    Dim t As Tuple
    Do While n > 0
        t = Remove
        Debug.Print t.Priority, t.Data
    Loop
End Sub



Fortran: module priority_queue_mod
implicit none

type node
  character (len=100)              :: task
  integer                          :: priority
end type

type queue
  type(node), allocatable :: buf(:)
  integer                 :: n = 0
contains
  procedure :: top
  procedure :: enqueue
  procedure :: siftdown
end type

contains

subroutine siftdown(this, a)
  class (queue)           :: this
  integer                 :: a, parent, child
  associate (x => this%buf)
  parent = a
  do while(parent*2 <= this%n)
    child = parent*2
    if (child + 1 <= this%n) then 
      if (x(child+1)%priority > x(child)%priority ) then
        child = child +1 
      end if
    end if
    if (x(parent)%priority < x(child)%priority) then
      x([child, parent]) = x([parent, child])
      parent = child
    else
      exit
    end if  
  end do      
  end associate
end subroutine

function top(this) result (res)
  class(queue) :: this
  type(node)   :: res
  res = this%buf(1)
  this%buf(1) = this%buf(this%n)
  this%n = this%n - 1
  call this%siftdown(1)
end function

subroutine enqueue(this, priority, task)
  class(queue), intent(inout) :: this
  integer                     :: priority
  character(len=*)            :: task
  type(node)                  :: x
  type(node), allocatable     :: tmp(:)
  integer                     :: i
  x%priority = priority
  x%task = task
  this%n = this%n +1  
  if (.not.allocated(this%buf)) allocate(this%buf(1))
  if (size(this%buf)<this%n) then
    allocate(tmp(2*size(this%buf)))
    tmp(1:this%n-1) = this%buf
    call move_alloc(tmp, this%buf)
  end if
  this%buf(this%n) = x
  i = this%n
  do 
    i = i / 2
    if (i==0) exit
    call this%siftdown(i)
  end do
end subroutine
end module 

program main
  use priority_queue_mod

  type (queue) :: q
  type (node)  :: x 

  call q%enqueue(3, "Clear drains")
  call q%enqueue(4, "Feed cat")
  call q%enqueue(5, "Make Tea")
  call q%enqueue(1, "Solve RC tasks")
  call q%enqueue(2, "Tax return")

  do while (q%n >0) 
    x = q%top()
    print "(g0,a,a)", x%priority, " -> ", trim(x%task)
  end do

end program