PQueue.hs

{-# LANGUAGE NamedFieldPuns, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}
{-# OPTIONS -fno-warn-missing-methods -fno-warn-name-shadowing #-}
{- | An efficient implementation of a priority queue.

The implementation of 'PQueue' is based on a /pairing heap/, a simple and efficient implementation of a general-purpose priority queue.  'PQueue' supports 'insert', 'merge', and 'peek' in constant time, and 'extract' and 'delete' in logarithmic time.
-}

module Data.Queue.PQueue (PQueue) where

import Data.Queue.Class
import Data.Queue.QueueHelpers

import Data.Maybe
import Data.Monoid

import Control.Monad

data Tree e = T e [Tree e]
newtype PQueue e = PQ (HeapQ (Tree e)) deriving (Monoid, Queuelike)

single :: e -> HeapQ (Tree e)
single x = HQ 1 $ Just (T x [])

instance Ord e => Monoid (Tree e) where
	-- no actual mzero instance, but induces a correct Monoid instance for Heap e
	t1@(T x1 ts1) `mappend` t2@(T x2 ts2) 
		| x1 <= x2	= T x1 (t2:ts1)
		| otherwise	= T x2 (t1:ts2)

instance Ord e => Queuelike (HeapQ (Tree e)) where
	{-# INLINE fromList #-}
	{-# INLINE toList_ #-}
	{-# INLINE mergeAll #-}
	{-# INLINE insertAll #-}

	type QueueKey (HeapQ (Tree e)) = e

	empty = mempty
	singleton = single
	fromList ts = mconcat (map single ts)

	x `insert` q = q `mappend` single x
	xs `insertAll` q = q `mappend` fromList xs
	merge = mappend
	mergeAll = mconcat
	
	extract (HQ n t) = fmap (\ (T x ts) ->  (x, HQ (n-1) (fusing ts))) t
	toList_ = maybe [] flatten . heap
	size = elts

flatten :: Tree e -> [e]
flatten (T x ts) = [x] ++ concatMap flatten ts