{-# LANGUAGE BangPatterns, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
{- | 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.Monoid
import Data.Maybe
import Control.Monad
import Data.Tree
import Data.Queue.Class
import GHC.Exts

newtype Heap e = H (Maybe (Tree e)) deriving (Read, Show)
-- data Rk e = Rk {-# UNPACK #-} !Int e deriving (Read, Show)
-- type RkTree e = Tree (Rk e)
data PQueue e = PQ {-# UNPACK #-} !Int {-# UNPACK #-} !(Heap e) deriving (Read, Show)

instance Ord e => Monoid (Heap e) where
	mempty = H Nothing
	H (Just t1) `mappend` H (Just t2) = H (Just (t1 `meld` t2))
	h1 `mappend` H Nothing = h1
	H Nothing `mappend` h2 = h2
	mconcat hs = fuse [t | H (Just t) <- hs]

instance Ord e => Monoid (PQueue e) where
	mempty = PQ 0 mempty
	PQ n1 h1 `mappend` PQ n2 h2 = PQ (n1 + n2) (h1 `mappend` h2)
	mconcat qs = let (n, ts) = fuser 0 [] qs in PQ n (fuse ts) where
		fuser !n ts qs = case qs of
			[]	-> (n, ts)
			(PQ m (H h):qs)	-> case h of	Nothing	-> fuser n ts qs
							Just t	-> fuser (n+m) (t:ts) qs

{-# INLINE meld #-}
meld :: Ord e => Tree e -> Tree e -> Tree e
t1@(Node x1 ts1) `meld` t2@(Node x2 ts2) = 
	if x1 > x2 then Node x2 (t1:ts2) else Node x1 (t2:ts1)

fuse :: Ord e => [Tree e] -> Heap e
fuse [] = H Nothing
fuse [t] = H (Just t)
fuse ts = fuse (fuser ts) where
	fuser (x1:x2:xs) = (x1 `meld` x2) : fuser xs
	fuser xs = xs

instance Ord e => Queuelike (PQueue e) e where
	singleton x = PQ 1 (H (Just (Node x [])))
	extract (PQ n (H h)) = fmap (\ (Node x ts) -> (x, PQ (n-1) $ fuse ts)) h
	isEmpty (PQ _ (H h)) = isNothing h
	size (PQ n _) = n
	{-# INLINE fromList #-}
	fromList xs = mconcat (map singleton xs)
	{-# INLINE toList_ #-}
	toList_ (PQ _ (H h)) = maybe [] flatten h
	merge = mappend
	empty = mempty
	{-# INLINE insertAll #-}
	xs `insertAll` q = q `merge` fromList xs

{-# NOINLINE [0] flattenFB #-}
flattenFB :: Tree a -> (a -> b -> b) -> b -> b
flattenFB (Node x ts) c n = x `c` foldr (flip flattenFB c) n ts

{-# RULES
	"flatten" [~1] forall t . flatten t = build (flattenFB t);
	"flattenList" [1] forall t . build (flattenFB t) = flatten t;
	#-}