QueueHelpers.hs

{-# 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)
-------------------}

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

import Data.Monoid
import Data.Maybe

data MonoidQ m = HQ {elts :: {-# UNPACK #-} !Int, heap :: m}
type HeapQ m = MonoidQ (Maybe 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

{-# INLINE fusing #-}
fusing :: Monoid m => [m] -> Maybe m
fusing = let	meld = mappend
		fuser [] = Nothing
		fuser [t] = Just t
		fuser ts = fuser (fuser' ts)
		fuser' (t1:t2:t3:t4:ts) =
			(t1 `meld` t2) `meld` (t3 `meld` t4) : fuser' ts
		fuser' [t1,t2,t3]	= [t1 `meld` t2 `meld` t3]
		fuser' [t1,t2]		= [t1 `meld` t2]
		fuser' ts		= ts
	in meld `seq` fuser

{-
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)

{-# RULES
	"[] ++" forall l . [] ++ l = l;
	"++ []" forall l . l ++ [] = l;
	"fuseMerge/HeapQ" forall (qs :: Monoid m => [MonoidQ (Maybe m)]) . fuseMerge qs = fuseMergeM qs;
	#-}