F# priority queue

Question

Does the F# library include a priority queue? Else can someone point to me an implementation of priority queue in F#?

Answer 1

Take a look at http://lepensemoi.free.fr/index.php/tag/data-structure for a whole bunch of F# implementations of various data structures.

Answer 2

There is a discussion of functional data structures for priority queues in issue 16 of The Monad.Reader, which is interesting.

It includes a description of pairing heaps which are fast and very easy to implement.

Answer 3

EDITED: to correct an error in the deleteMin function of the pure functional version and to add the ofSeq function.

I implemented two versions of a MinHeap Binary Heap based Priority Queue in an answer about F# prime sieves, the first one is pure functional code (slower) and the second is array based (ResizeArray, which is built on the DotNet List that internally uses an Array to store the list). The non-functional version is somewhat justified as the MinHeap is usually implemented as a mutable array binary heap after a genealogical tree based model invented by Michael Eytzinger over 400 years ago.

In that answer, I did not implement the "remove top priority item from queue" function as the algorithm did not need it, but I did implement a "reinsert top item further down the queue" function as the algorithm did need it, and that function is quite similar to what would be required for the "deleteMin" function; the difference is that rather than reinserting the top "minimum" item with new parameters, one would just delete the last item from the queue (found in a similar way as when inserting new items but simpler), and reinsert that item to replace the top (minimum) item in the queue (just call the "reinsertMinAt" function). I also implemented an "adjust" function which applies a function to all queue elements and then reheapifies the final result for efficiency, which function was a requirement of the paged Sieve of Eratosthenes algorithm in that answer.

In the following code, I have implemented the "deleteMin" function described above as well as a "ofSeq" function that can be used to build a new queue from a sequence of priority/contents tuple pair elements that uses the internal "reheapify" function for efficiency.

The MinHeap as per this code can easily be changed into a "MaxHeap" by changing the greater than symbols to less than symbols and vice versa in comparisons related to the priority 'k' values. The Min/Max Heap supports multiple elements of the same unsigned integer "Key" priority but does not preserve the order of entries with the same priority; in other words there is no guaranty that the first element that goes into the queue will be the first element that pops up to the minimum position if there are other entries with the same priority as I did not require that and the current code is more efficient. The code could be modified to preserve the order if that were a requirement (keep moving new insertions down until the past any entries of the same priority).

The Min/Max Heap Priority Queue has the advantages that it has less computational complexity overhead as compared to other types of non-simplistic queues, produces the Min or Max (depending on whether a MinHeap or MaxHeap implementation) in O(1) time, and inserts and deletes with a worst case O(log n) time, while adjusting and building require only O(n) time, where 'n' is the number of elements currently in the queue. The advantage of the "resinsertMinAs" function over a delete and then an insert is that it reduces the worst case time to O(log n) from twice that and is often better than that as reinsertions are often near the beginning of the queue so a full sweep is not required.

As compared to the Binomial Heap with the additional option of a pointer to the minimum value to produce O(1) find minimum value performance, the MinHeap may be slightly simpler and therefore quicker when doing about the same job, especially if one does not need the "merge heap" capabilities offered by the Binomial Heap. It may take longer to "reinsertMinAs" using the Binomial Heap "merge" function as compared to using the MinHeap as it would appear that typically slightly more comparisons need to be made on average.

The MinHeap Priority Queue is particularly suited to the problem of the incremental Sieve of Eratosthenes as in the other linked answer, and is likely the queue used by Melissa E. O'Neill in the work done in her paper showing that the Turner prime sieve is not really the Sieve of Eratosthenes neither as to algorithm nor as to performance.

The following pure functional code adds the "deleteMin" and "ofSeq" functions to that code:

[<RequireQualifiedAccess>]
module MinHeap =

  type MinHeapTreeEntry<'T> = class val k:uint32 val v:'T new(k,v) = { k=k;v=v } end
  [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
  [<NoEquality; NoComparison>]
  type MinHeapTree<'T> = 
      | HeapEmpty 
      | HeapOne of MinHeapTreeEntry<'T>
      | HeapNode of MinHeapTreeEntry<'T> * MinHeapTree<'T> * MinHeapTree<'T> * uint32

  let empty = HeapEmpty

  let getMin pq = match pq with | HeapOne(kv) | HeapNode(kv,_,_,_) -> Some kv | _ -> None

  let insert k v pq =
    let kv = MinHeapTreeEntry(k,v)
    let rec insert' kv msk pq =
      match pq with
        | HeapEmpty -> HeapOne kv
        | HeapOne kvn -> if k < kvn.k then HeapNode(kv,pq,HeapEmpty,2u)
                         else HeapNode(kvn,HeapOne kv,HeapEmpty,2u)
        | HeapNode(kvn,l,r,cnt) ->
          let nc = cnt + 1u
          let nmsk = if msk <> 0u then msk <<< 1 else
                     let s = int32 (System.Math.Log (float nc) / System.Math.Log(2.0))
                     (nc <<< (32 - s)) ||| 1u //never ever zero again with the or'ed 1
          if k <= kvn.k then if (nmsk &&& 0x80000000u) = 0u then HeapNode(kv,insert' kvn nmsk l,r,nc)
                                                            else HeapNode(kv,l,insert' kvn nmsk r,nc)
          else if (nmsk &&& 0x80000000u) = 0u then HeapNode(kvn,insert' kv nmsk l,r,nc)
               else HeapNode(kvn,l,insert' kv nmsk r,nc)
    insert' kv 0u pq

  let private reheapify kv k pq =
    let rec reheapify' pq =
      match pq with
        | HeapEmpty | HeapOne _ -> HeapOne kv
        | HeapNode(kvn,l,r,cnt) ->
            match r with
              | HeapOne kvr when k > kvr.k ->
                  match l with //never HeapEmpty
                    | HeapOne kvl when k > kvl.k -> //both qualify, choose least
                        if kvl.k > kvr.k then HeapNode(kvr,l,HeapOne kv,cnt)
                        else HeapNode(kvl,HeapOne kv,r,cnt)
                    | HeapNode(kvl,_,_,_) when k > kvl.k -> //both qualify, choose least
                        if kvl.k > kvr.k then HeapNode(kvr,l,HeapOne kv,cnt)
                        else HeapNode(kvl,reheapify' l,r,cnt)
                    | _ -> HeapNode(kvr,l,HeapOne kv,cnt) //only right qualifies
              | HeapNode(kvr,_,_,_) when k > kvr.k -> //need adjusting for left leaf or else left leaf
                  match l with //never HeapEmpty or HeapOne
                    | HeapNode(kvl,_,_,_) when k > kvl.k -> //both qualify, choose least
                        if kvl.k > kvr.k then HeapNode(kvr,l,reheapify' r,cnt)
                        else HeapNode(kvl,reheapify' l,r,cnt)
                    | _ -> HeapNode(kvr,l,reheapify' r,cnt) //only right qualifies
              | _ -> match l with //r could be HeapEmpty but l never HeapEmpty
                        | HeapOne(kvl) when k > kvl.k -> HeapNode(kvl,HeapOne kv,r,cnt)
                        | HeapNode(kvl,_,_,_) when k > kvl.k -> HeapNode(kvl,reheapify' l,r,cnt)
                        | _ -> HeapNode(kv,l,r,cnt) //just replace the contents of pq node with sub leaves the same
    reheapify' pq


  let reinsertMinAs k v pq =
    let kv = MinHeapTreeEntry(k,v)
    reheapify kv k pq

  let deleteMin pq =
    let rec delete' kv msk pq =
      match pq with
        | HeapEmpty -> kv,empty //should never get here as should flock off up before an empty is reached
        | HeapOne kvn -> kvn,empty
        | HeapNode(kvn,l,r,cnt) ->
          let nmsk = if msk <> 0u then msk <<< 1 else
                     let s = int32 (System.Math.Log (float cnt) / System.Math.Log(2.0))
                     (cnt <<< (32 - s)) ||| 1u //never ever zero again with the or'ed 1
          if (nmsk &&& 0x80000000u) = 0u then let kvl,pql = delete' kvn nmsk l
                                              match pql with
                                                | HeapEmpty -> kvl,HeapOne kvn
                                                | HeapOne _ | HeapNode _ -> kvl,HeapNode(kvn,pql,r,cnt - 1u)
                                         else let kvr,pqr = delete' kvn nmsk r
                                              kvr,HeapNode(kvn,l,pqr,cnt - 1u)
    match pq with
      | HeapEmpty | HeapOne _ -> empty //for the case of deleting from queue either empty or one entry
      | HeapNode(kv,_,_,cnt) -> let nkv,npq = delete' kv 0u pq in reinsertMinAs nkv.k nkv.v npq

  let adjust f (pq:MinHeapTree<_>) = //adjust all the contents using the function, then rebuild by reheapify
    let rec adjust' pq =
      match pq with
        | HeapEmpty -> pq
        | HeapOne kv -> HeapOne(MinHeapTreeEntry(f kv.k kv.v))
        | HeapNode (kv,l,r,cnt) -> let nkv = MinHeapTreeEntry(f kv.k kv.v)
                                   reheapify nkv nkv.k (HeapNode(kv,adjust' l,adjust' r,cnt))
    adjust' pq

  let ofSeq (sq:seq<MinHeapTreeEntry<_>>) =
    let cnt = sq |> Seq.length |> uint32 in let hcnt = cnt / 2u in let nmrtr = sq.GetEnumerator()
    let rec build' i =
      if nmrtr.MoveNext() && i <= cnt then
        if i > hcnt then HeapOne(nmrtr.Current)
        else let i2 = i + i in HeapNode(nmrtr.Current,build' i2,build' (i2 + 1u),cnt - i)
      else HeapEmpty
    build' 1u

and the following code adds the deleteMin and ofSeq functions to the array based version:

[<RequireQualifiedAccess>]
module MinHeap =

  type MinHeapTreeEntry<'T> = class val k:uint32 val v:'T new(k,v) = { k=k;v=v } end
  type MinHeapTree<'T> = ResizeArray<MinHeapTreeEntry<'T>>

  let empty<'T> = MinHeapTree<MinHeapTreeEntry<'T>>()

  let getMin (pq:MinHeapTree<_>) = if pq.Count > 0 then Some pq.[0] else None

  let insert k v (pq:MinHeapTree<_>) =
    if pq.Count = 0 then pq.Add(MinHeapTreeEntry(0xFFFFFFFFu,v)) //add an extra entry so there's always a right max node
    let mutable nxtlvl = pq.Count in let mutable lvl = nxtlvl <<< 1 //1 past index of value added times 2
    pq.Add(pq.[nxtlvl - 1]) //copy bottom entry then do bubble up while less than next level up
    while ((lvl <- lvl >>> 1); nxtlvl <- nxtlvl >>> 1; nxtlvl <> 0) do
      let t = pq.[nxtlvl - 1] in if t.k > k then pq.[lvl - 1] <- t else lvl <- lvl <<< 1; nxtlvl <- 0 //causes loop break
    pq.[lvl - 1] <-  MinHeapTreeEntry(k,v); pq

  let reinsertMinAs k v (pq:MinHeapTree<_>) = //do minify down for value to insert
    let mutable nxtlvl = 1 in let mutable lvl = nxtlvl in let cnt = pq.Count
    while (nxtlvl <- nxtlvl <<< 1; nxtlvl < cnt) do
      let lk = pq.[nxtlvl - 1].k in let rk = pq.[nxtlvl].k in let oldlvl = lvl
      let k = if k > lk then lvl <- nxtlvl; lk else k in if k > rk then nxtlvl <- nxtlvl + 1; lvl <- nxtlvl
      if lvl <> oldlvl then pq.[oldlvl - 1] <- pq.[lvl - 1] else nxtlvl <- cnt //causes loop break
    pq.[lvl - 1] <- MinHeapTreeEntry(k,v); pq

  let deleteMin (pq:MinHeapTree<_>) =
    if pq.Count <= 2 then empty else //if contains one or less entries, return empty queue
    let btmi = pq.Count - 2 in let btm = pq.[btmi] in pq.RemoveAt btmi
    reinsertMinAs btm.k btm.v pq

  let adjust f (pq:MinHeapTree<_>) = //adjust all the contents using the function, then re-heapify
    if pq <> null then 
      let cnt = pq.Count
      if cnt > 1 then
        for i = 0 to cnt - 2 do //change contents using function
          let e = pq.[i] in let k,v = e.k,e.v in pq.[i] <- MinHeapTreeEntry (f k v)
        for i = cnt/2 downto 1 do //rebuild by reheapify
          let kv = pq.[i - 1] in let k = kv.k
          let mutable nxtlvl = i in let mutable lvl = nxtlvl
          while (nxtlvl <- nxtlvl <<< 1; nxtlvl < cnt) do
            let lk = pq.[nxtlvl - 1].k in let rk = pq.[nxtlvl].k in let oldlvl = lvl
            let k = if k > lk then lvl <- nxtlvl; lk else k in if k > rk then nxtlvl <- nxtlvl + 1; lvl <- nxtlvl
            if lvl <> oldlvl then pq.[oldlvl - 1] <- pq.[lvl - 1] else nxtlvl <- cnt //causes loop break
          pq.[lvl - 1] <- kv
    pq

Answer 4

It is amazing that the accepted answer still almost works with all the changes to F# over the intervening over seven years with the exception that there no longer is a Pervasives.compare function and the "compare" function has now been merged into the base operators at Microsoft.FSharp.Core.Operators.compare.

That said, that referenced blog entry implements the Binomial Heap as a general purpose Heap and not as for the specific requirements of a Priority Queue as to not requiring a generic type for the priority which can just be an integer type for efficiency in comparisons, and it speaks of but does not implement the additional improvement to preserve the minimum as a separate field for efficiency in just checking the top priority item in the queue.

The following module code implements the Binomial Heap Priority Queue as derived from that code with the improved efficiency that it does not use generic comparisons for the priority comparisons and the more efficient O(1) method for checking the top of the queue (although at the cost of more overhead for inserting and deleting entries although they are still O(log n) - n being the number of entries in the queue). This code is more suitable for the usual application of priority queues where the top of the queue is read more often than insertions and/or top item deletions are performed. Note that it isn't as efficient as the MinHeap when one is deleting the top element and reinserting it further down the queue as a full "deleteMin" and "insert" must be performed with much more of a computational overhead. The code is as follows:

[<RequireQualifiedAccess>]
module BinomialHeapPQ =

//  type 'a treeElement = Element of uint32 * 'a
  type 'a treeElement = class val k:uint32 val v:'a new(k,v) = { k=k;v=v } end

  type 'a tree = Node of uint32 * 'a treeElement * 'a tree list

  type 'a heap = 'a tree list

  type 'a outerheap = | HeapEmpty | HeapNotEmpty of 'a treeElement * 'a heap

  let empty = HeapEmpty

  let isEmpty = function | HeapEmpty -> true | _ -> false

  let inline private rank (Node(r,_,_)) = r

  let inline private root (Node(_,x,_)) = x

  exception Empty_Heap

  let getMin = function | HeapEmpty -> None
                        | HeapNotEmpty(min,_) -> Some min

  let rec private findMin heap =
    match heap with | [] -> raise Empty_Heap //guarded so should never happen
                    | [node] -> root node,[]
                    | topnode::heap' ->
                      let min,subheap = findMin heap' in let rtn = root topnode
                      match subheap with
                        | [] -> if rtn.k > min.k then min,[] else rtn,[]
                        | minnode::heap'' ->
                          let rmn = root minnode
                          if rtn.k <= rmn.k then rtn,heap
                          else rmn,minnode::topnode::heap''

  let private mergeTree (Node(r,kv1,ts1) as tree1) (Node (_,kv2,ts2) as tree2) =
    if kv1.k > kv2.k then Node(r+1u,kv2,tree1::ts2)
    else Node(r+1u,kv1,tree2::ts1)

  let rec private insTree (newnode: 'a tree) heap =
    match heap with
      | [] -> [newnode]
      | topnode::heap' -> if (rank newnode) < (rank topnode) then newnode::heap
                          else insTree (mergeTree newnode topnode) heap'

  let insert k v = let kv = treeElement(k,v) in let nn = Node(0u,kv,[])
                   function | HeapEmpty -> HeapNotEmpty(kv,[nn])
                            | HeapNotEmpty(min,heap) -> let nmin = if k > min.k then min else kv
                                                        HeapNotEmpty(nmin,insTree nn heap)

  let rec private merge' heap1 heap2 = //doesn't guaranty minimum tree node as head!!!
    match heap1,heap2 with
      | _,[] -> heap1
      | [],_ -> heap2
      | topheap1::heap1',topheap2::heap2' ->
        match compare (rank topheap1) (rank topheap2) with
          | -1 -> topheap1::merge' heap1' heap2
          | 1 -> topheap2::merge' heap1 heap2'
          | _ -> insTree (mergeTree topheap1 topheap2) (merge' heap1' heap2')

  let merge oheap1 oheap2 = match oheap1,oheap2 with
                              | _,HeapEmpty -> oheap1
                              | HeapEmpty,_ -> oheap2
                              | HeapNotEmpty(min1,heap1),HeapNotEmpty(min2,heap2) ->
                                  let min = if min1.k > min2.k then min2 else min1
                                  HeapNotEmpty(min,merge' heap1 heap2)

  let rec private removeMinTree = function
                          | [] -> raise Empty_Heap // will never happen as already guarded
                          | [node] -> node,[]
                          | t::ts -> let t',ts' = removeMinTree ts
                                     if (root t).k <= (root t').k then t,ts else t',t::ts'

  let deleteMin =
    function | HeapEmpty -> HeapEmpty
             | HeapNotEmpty(_,heap) ->
               match heap with
                 | [] -> HeapEmpty // should never occur: non empty heap with no elements
                 | [Node(_,_,heap')] -> match heap' with
                                          | [] -> HeapEmpty
                                          | _ -> let min,_ = findMin heap'
                                                 HeapNotEmpty(min,heap')
                 | _::_ -> let Node(_,_,ts1),ts2 = removeMinTree heap
                           let nheap = merge' (List.rev ts1) ts2 in let min,_ = findMin nheap
                           HeapNotEmpty(min,nheap)

  let reinsertMinAs k v pq = insert k v (deleteMin pq)

Note that there are two options in the form of the type "treeElement" in order to suit the way this is tested. In the application as noted in my answer about using priority queues to sieve primes, the above code is about 80% slower than the functional implementation of the MinHeap (non multi-processing mode, as the above binomial heap does not lend itself well to in-place adjustments); this is because of the additional computational complexity of the "delete followed by insert" operation for the Binomial Heap rather than the ability to combine these operations efficiently for the MinHeap implementation.

Thus, the MinHeap Priority Queue is more suitable for this type of application and also where efficient in-place adjustments are required, whereas the Binomial Heap Priority Queue is more suitable where one requires the ability to efficiently merge two queues into one.

Answer 5

FSharpx.Collections includes a functional Heap collection https://github.com/fsharp/fsharpx/blob/master/src/FSharpx.Core/Collections/Heap.fsi as well as a PriortityQueue interface for it https://github.com/fsharp/fsharpx/blob/master/src/FSharpx.Core/Collections/PriorityQueue.fs

Answer 6

Just use an F# Set of pairs of your element type with a unique int (to allow duplicates) and extract your elements with set.MinElement or set.MaxElement. All of the relevant operations are O(log n) time complexity. If you really need O(1) repeated access to the minimum element you can simply cache it and update the cache upon insertion if a new minimum element is found.

There are many kinds of heap data structures that you could try (skew heaps, splay heaps, pairing heaps, binomial heaps, skew binomial heaps, bootstrapped variants of the above). For a detailed analysis of their design, implementation and real-world performance see the article Data structures: heaps in The F#.NET Journal.