QueueHelpers.hs

{-# LANGUAGE FlexibleContexts, BangPatterns #-}
{-# 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
	...

-------------------}

module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, endoMaybe, order, fusing, fuseMerge) 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 endoMaybe #-}
endoMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
endoMaybe f (Just a) (Just b)	= Just (f a b)
endoMaybe _ ma Nothing		= ma
endoMaybe _ _ mb		= mb

{-# INLINE fusing #-}
fusing :: Monoid m => [m] -> Maybe m
fusing = let	meld = mappend
		fuser [] = Nothing
		fuser (t:ts) = Just (t `fuse1` ts)
		t `fuse1` [] = t
		t1 `fuse1` (t2:ts) = (t1 `meld` t2) `fuse1` fuse ts
		fuse (t1:t2:ts) = t1 `meld` t2 : fuse ts
		fuse 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 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))

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 => [HeapQ m]) . fuseMerge qs = fuseMergeM qs;
	#-}