{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -fno-warn-name-shadowing #-}

{------------------

This module builds structure common to instances of functional heaps, using monoidal structure.
A HeapQ consists of a size tag and a monoidally structured tree type, probably lacking a 'true' mzero.
This module automatically lifts monoidal stucture from the tree type to the HeapQ, and provides a common mconcat implementation
that provides balanced, linear-time heap merging.  Then a new heap can work as follows:

data FooHeap e = ...
newtype FooQueue e = FQ (HeapQ (FooHeap e)) deriving (Monoid)

instance Queuelike (FooQueue e) where
	empty = mempty
	merge = mappend
	mergeAll = mconcat
	...

In particular, this almost immediately yields a correct pairing heap implementation (cf. PQueue)

In general, the fusing function provided by this module implements a balanced
monoid merging operation used by nearly every priority queue implementation in this package.
-------------------}

module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, fusing', endoMaybe, order, fusing, fuseMerge, fuseMergeM) where

import Data.Monoid
import Data.Maybe
import Data.List(unfoldr)
import GHC.Exts(build)

data MonoidQ m = HQ {elts :: Int, heap :: m} deriving (Eq, Ord, Show)
type HeapQ m = MonoidQ (Maybe m)

instance Functor MonoidQ where
	fmap f (HQ n m) = HQ n (f m)

instance Monoid m => Monoid (MonoidQ m) where
	{-# INLINE mappend #-}
	{-# INLINE mconcat #-}

	mempty = HQ 0 mempty
	HQ n1 h1 `mappend` HQ n2 h2 = HQ (n1 + n2) (h1 `mappend` h2)
	mconcat = fuseMerge

--{-# INLINE on #-}
-- on f g x y = f (g x) (g y)
-- {-# INLINE incr #-}
-- incr :: (e -> e) -> MonoidQ e -> MonoidQ e
-- incr f (HQ n x) = HQ (n+1) (f x)

-- {-# INLINE decr #-}
-- decr :: (e -> e) -> MonoidQ e -> Maybe (MonoidQ e)
-- decr f (HQ (n+1) x) = Just (HQ n (f x))
-- decr f (HQ 0 x) = Nothing


{-# INLINE endoMaybe #-}
endoMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
endoMaybe f (Just a) (Just b)	= Just (f a b)
endoMaybe _ ma mb		= maybe mb Just ma

fusing' :: (m -> m -> m) -> [m] -> Maybe m
fusing' (><) = let
		fuser [] = Nothing
		fuser [t] = Just t
		fuser ts = fuser (fuser' ts)
		fuser' (t1:t2:t3:t4:ts) =
			(t1 >< t2) >< (t3 >< t4) : fuser' ts
		fuser' [t1,t2,t3]	= [t1 >< t2 >< t3]
		fuser' [t1,t2]		= [t1 >< t2]
		fuser' ts		= ts
	in fuser

fusing :: Monoid m => [m] -> Maybe m
fusing = fusing' mappend

{-
fusing [] = Nothing
fusing [t] = Just t
fusing ts = fusing (fuse ts) where
	fuse [] = []
	fuse [t] = [t]
	fuse (t1:t2:ts) = (t1 `mappend` t2):fuse ts
-}

{-# INLINE order #-}
order :: (e -> e -> Ordering) -> e -> e -> (e, e)
order cmp x y	| cmp x y == GT	= (y, x)
		| otherwise	= (x, y)

data IntAcc e = IA {-# UNPACK #-} !Int e

{-# INLINE [2] fuseMerge #-}
fuseMerge :: Monoid m => [MonoidQ m] -> MonoidQ m
fuseMerge qs = let	merger (HQ size t) (IA n ts) = IA (n + size) (t:ts)
			in case foldr merger (IA 0 []) qs of
			IA n ts -> HQ n (fromMaybe mempty (fusing ts))

{-# INLINE fuseMergeM #-}
fuseMergeM :: Monoid m => [HeapQ m] -> HeapQ m
fuseMergeM qs = let	merger (HQ size (Just t)) (IA n ts) = IA (n + size) (t:ts)
			merger _ (IA n ts) = IA n ts
			in case foldr merger (IA 0 []) qs of
			IA n ts -> HQ n (fusing ts)

{-# INLINE [0] unfoldFB #-}
unfoldFB :: (b -> Maybe (a, b)) -> b -> (a -> c -> c) -> c -> c
unfoldFB suc s0 c nil = unfold' s0 where
	unfold' s = case suc s of
		Nothing	-> nil
		Just (x, s') -> x `c` unfold' s'

{-# RULES
	"[] ++" forall l . [] ++ l = l;
	"++ []" forall l . l ++ [] = l;
	"fuseMerge/HeapQ" forall (qs :: Monoid m => [MonoidQ (Maybe m)]) . fuseMerge qs = fuseMergeM qs;
--	"unfold" [~1] forall suc s0 . unfoldr suc s0 = build (unfoldrFB suc s0)
	#-}