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.Semigroup
--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)

instance Show e => Show (PQueue e) where
	show = drawQueue

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

instance Ord e => Semigroup (Tree e) where
	t1@(T x1 ts1) `sappend` 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 = PQ mempty
	singleton = PQ . single
	fromList xs = PQ (HQ (length xs) (Pt $ sconcat [T x [] | x <- xs]))

	xs `insertAll` q = q `mappend` fromList xs
	merge = mappend
	mergeAll = mconcat

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

	null (PQ (HQ _ (Pt Nothing))) = True
	null _ = False
	size (PQ (HQ n _)) = n

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

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