QueueHelpers.hs

{-# LANGUAGE FlexibleContexts, ViewPatterns #-}
{-# OPTIONS -fno-warn-name-shadowing -fno-warn-overlapping-patterns #-}

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

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, order, unfoldList) where

import Data.Semigroup
--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 (Point m)

instance Semigroup m => Semigroup (MonoidQ m) where
	HQ n1 h1 `sappend` HQ n2 h2 = HQ (n1 + n2) (h1 `sappend` h2)
	sconcat qs = fmap (HQ $ sum [n | HQ n _ <- qs]) (sconcat [q | HQ _ q <- qs])

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 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 = HQ (sum [n | HQ n _ <- qs]) (mconcat [t | HQ _ t <- qs])

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

{-# INLINE unfoldList #-}
unfoldList :: (b -> (a, [b])) -> b -> [a]
unfoldList branch root = build (\ c n -> unfoldToList c n branch root)
	where	unfoldToList cons nil branch root = unfold' root nil where
			unfold' (branch -> (x, ts)) nil = x `cons` foldr unfold' nil ts


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