PQueue.hs

{-# LANGUAGE 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, drawQueue) where --, IQueue(..), QueueKey(..)) where

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

import qualified Data.Tree as T
	
import Data.Maybe
import Data.Monoid

import Control.Monad

-- The real meat of the pairing heap is the merge operation, and in the "balanced" merging of subtrees.  This balancing idea is sufficiently general that it's implemented in QueueHelpers, to be automatically inferred from a monoid instance, and a perfectly correct implementation falls out almost immediately.

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

drawQueue :: Show e => PQueue e -> String
drawQueue (PQ (HQ _ t)) = maybe "" (T.drawTree . fmap show . T.unfoldTree (\ (T x ts) -> (x, ts))) t

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 => IQueue (PQueue e) where
	{-# INLINE toList_ #-}
	{-# INLINE mergeAll #-}
	{-# INLINE insertAll #-}

	type QueueKey (PQueue e) = e

	empty = mempty
	singleton = PQ . single
	fromList xs = PQ $ fuseMergeM [single x | x <- xs]

	xs `insertAll` q = q `mappend` fromList xs
	merge = mappend
	mergeAll qs = PQ (fuseMergeM [h | PQ h <- qs])

	extract (PQ (HQ n t)) = fmap (fmap (PQ . HQ (n-1)) . extract') t
		where	extract' (T x ts) = (x, fusing ts)
	toList_ (PQ (HQ _ t)) = maybe [] flatten t
		where	flatten (T x ts) = x:concatMap flatten ts
	size (PQ (HQ n _)) = n

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

{-# RULES
-- 	"singleton/PQueue" forall (x :: Ord e => e) . singleton x = PQ (single x);
	#-}