MonoidQueue2.hs

{-# LANGUAGE TypeFamilies, TypeOperators, PatternGuards #-}

module Data.Queue.TrieQueue.MonoidQueue2 (MQueue, extractSingle, replace) where

import Data.Queue.PQueue
import Data.Queue.Class
import Data.Queue.QueueHelpers (fusing, fusing')

import Data.Queue.TrieQueue.Edge

import Data.Maybe
import Data.Monoid
import Prelude hiding (null)

data MQueue k m = Nil | MQ {-# UNPACK #-} !(k :- m) {-# UNPACK #-} !(PQueue (k :- m)) deriving (Show)

instance (Ord k, Monoid m) => Monoid (MQueue k m) where
	mempty = Nil
	mappend = mergeMQ
{-
Here we organize on the queues themselves.  We require that fromList not be defined in terms of mergeAll, of course -- in fact, if it is defined using toQueue as it is below,
this gives us the best of both worlds -- balanced merging both on the values associated with the minimum key (provided by fromList), and balanced merging on the remaining queues.
We lose some partial merging opportunities, but this implementation does none, so that's not an issue.
-}
	mconcat qs = case mkMQueue [k :- (m, q) | MQ (k :- m) q <- qs] of
		Nil	-> Nil
		MQ (k :- (m, pq)) qOfMQs -> 
			let q' = pq `merge` mergeAll 
					[(k :- m) `insert` q | k :- (m, q) <- toList_ qOfMQs]
				in MQ (k :- m) q'
		where	mkMQueue :: (Ord k, Monoid m) => [k :- m] -> MQueue k m
			mkMQueue = fromList

--	mconcat = fromMaybe Nil . fusing' mergeMQ

mergeMQ' :: Ord k => (k -> k -> Ordering) -> (m -> m -> m) -> MQueue k m -> MQueue k m -> MQueue k m
mergeMQ' cmp (><) (MQ x1@(k1 :- m1) q1) (MQ x2@(k2 :- m2) q2) = case cmp k1 k2 of
	LT	-> MQ x1 (x2 `insert` q)
	EQ	-> MQ (k1 :- (m1 >< m2)) q
	GT	-> MQ x2 (x1 `insert` q)
	where	q = q1 `merge` q2
mergeMQ' _ _ q Nil = q
mergeMQ' _ _ Nil q = q

mergeMQ :: (Ord k, Monoid m) => MQueue k m -> MQueue k m -> MQueue k m
mergeMQ = mergeMQ' compare mappend

instance (Ord k, Monoid m) => IQueue (MQueue k m) where
	type QueueKey (MQueue k m) = (k :- m)
	empty = Nil
	singleton = (`MQ` empty)
	fromList = toQueue . fromList

	merge = mappend
	mergeAll = mconcat

	null Nil = True
	null _ = False
	
	extract Nil = Nothing
	extract (MQ x q) = Just (x, toQueue q)

	toList_ Nil = []
	toList_ (MQ x q) = x:toList_ q

-- This version ignores balancing and does a totally simple merge on values with the minimal key in common.
toQueue :: (Ord k, Monoid m) => PQueue (k :- m) -> MQueue k m
toQueue q = case extract q of
	Nothing		-> Nil
	Just (k :- m, q') -> let toQueue' ms q = case extract q of	Just (k' :- m', q')
										| k == k'	-> toQueue' (m':ms) q'
--									_			-> MQ (k :- maybe m (mappend m) (fusing ms)) q
									_	| [] <- ms	-> MQ (k :- m) q
										| otherwise	-> MQ (k :- (m `mappend` mconcat ms)) q
					in toQueue' [] q'

extractSingle :: Ord k => MQueue k m -> Maybe (k :- m)
extractSingle (MQ x q)
	| null q	= Just x
extractSingle _ = Nothing

replace :: (Ord k, Monoid m) => (k :- m) -> MQueue k m -> MQueue k m
replace (k :- m) (MQ _ q) = MQ (k :- m) q
replace _ Nil = error "Attempt to modify head of an empty queue"