queuelike 1.0.5 → 1.0.6

raw patch · 11 files changed

+459/−139 lines, 11 filesdep −utility-htPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: utility-ht

API changes (from Hackage documentation)

Files

• Data/MQueue/Heap.hs +3/−2
• Data/Queue/Class.hs +2/−0
• Data/Queue/PQueue.hs +6/−0
• Data/Queue/Queue.hs +29/−14
• Data/Queue/QueueHelpers.hs +28/−9
• Data/Queue/TrieQueue.hs +105/−108
• Data/Queue/TrieQueue/Edge.hs +14/−0
• Data/Queue/TrieQueue/MonoidQueue.hs +111/−0
• Data/Queue/TrieQueue/MonoidQueue2.hs +84/−0
• Data/Queue/TrieQueue/TrieLabel.hs +69/−0
• queuelike.cabal +8/−6

@@ -7,8 +7,9 @@ import Data.MQueue.Class import Data.MQueue.MonadHelpers +import Control.Arrow((***)) import Control.Monad.ST.Class-import Data.Tuple.HT+--import Data.Tuple.HT  import Data.Array.Base @@ -42,7 +43,7 @@ newHeap = liftM H (liftM (STH 0) (newArray_ (0, 15)) >>= newSTRef) pushHeap h = onHeap_ h . pusher pushAllHeap h ks = onHeap_ h (\ h@STH{size} -> uncurry (with . flip ensureSize h) (foldr accumulator (size, \ _ -> return ()) ks))-	where	accumulator k = mapPair ((+1), liftM2 (>>) (unsafePusher k))+	where	accumulator k = ((+1) *** liftM2 (>>) (unsafePusher k)) popHeap_ h = onHeap_ h popper peekHeap h = queryHeap h (\ STH{..} -> if size > 0 then liftM Just (unsafeRead arr 0) else return Nothing) getHeapSize h = queryHeap h (return . size)

@@ -3,8 +3,10 @@ -- | Abstracts the implementation details of a single-insertion, single-extraction queuelike structure. module Data.Queue.Class where +--import Data.Foldable(Foldable(..)) import Data.List(unfoldr) import Data.Maybe+import qualified Data.List as Fold  import Control.Monad.Instances() import Control.Monad

@@ -22,6 +22,9 @@ data Tree e = T e [Tree e] newtype PQueue e = PQ (HeapQ (Tree e)) deriving (Monoid) +instance Show e => Show (PQueue e) where+	show = drawQueue+ drawQueue :: Show e => PQueue e -> String drawQueue (PQ (HQ _ t)) = maybe "" (T.drawTree . fmap show . T.unfoldTree (\ (T x ts) -> (x, ts))) t @@ -50,6 +53,9 @@ 		where	extract' (T x ts) = (x, fusing ts) 	toList_ (PQ (HQ _ t)) = maybe [] flatten t 		where	flatten (T x ts) = x:concatMap flatten ts++	null (PQ (HQ _ Nothing)) = True+	null _ = False 	size (PQ (HQ n _)) = n  single :: e -> HeapQ (Tree e)

@@ -2,7 +2,7 @@ {-# OPTIONS -fno-warn-name-shadowing #-}  -- | A basic first-in, first-out queue implementation implementing the 'Queuelike' abstraction.  Bootstrapped from "Data.Sequence".-module Data.Queue.Queue (Queue) where+module Data.Queue.Queue (Queue, cons) where  import Data.Monoid import Data.Queue.Class@@ -11,23 +11,38 @@ import qualified Data.Foldable as Fold import Prelude hiding (null) -newtype Queue e = Queue (Seq e) deriving (Monoid, Fold.Foldable, Functor)+--newtype Queue e = Queue (Seq e) deriving (Monoid, Fold.Foldable, Functor)+data Queue e = Queue Int [e] [e] [e]+	-- we never actually look at the spine of a+	-- and if we're performing fmap operations, it+	-- actually helps to existentially quantify the type +instance Functor Queue where+	fmap f (Queue n l r a) = Queue n (map f l) (map f r) (map f a)+ instance IQueue (Queue e) where 	type QueueKey (Queue e) = e-	empty = mempty-	singleton = Queue . Seq.singleton-	fromList = Queue . Seq.fromList+	empty = Queue 0 [] [] []+	singleton x = let l = [x] in Queue 1 l [] l+	fromList xs = Queue (length xs) xs [] xs 	-	null (Queue q) = Seq.null q-	size (Queue q) = Seq.length q+	null (Queue _ [] _ _) = True+	null _ = False+	size (Queue n _ _ _) = n -	x `insert` Queue q = Queue (q |> x)-	extract (Queue q) = case viewl q of-		EmptyL	-> Nothing-		x :< q'	-> Just (x, Queue q')+	x `insert` Queue n l r a = rot (n+1) l (x:r) a+	extract (Queue n (l:ls) r a) = Just (l, rot (n-1) ls r a)+	extract _ = Nothing -	merge = mappend-	mergeAll = mconcat+--	toList (Queue _ l r _) = l ++ reverse r -	toList = Fold.toList+rot :: Int -> [e] -> [e] -> [e] -> Queue e+rot n l r (_:as) = Queue n l r as+rot n l r [] = let	rot' (l:ls) (r:rs) a = l:rot' ls rs (r:a)+			rot' ls [] a = ls ++ a+			rot' [] (r:_) a = r:a+			l' = rot' l r []+			in Queue n l' [] l'++cons :: e -> Queue e -> Queue e+cons x (Queue n l r a) = Queue (n+1) (x:l) r a

@@ -18,16 +18,24 @@ 	...  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, endoMaybe, order, fusing, fuseMerge, fuseMergeM) where+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 :: {-# UNPACK #-} !Int, heap :: m} deriving (Eq, Ord, Show)+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 #-}@@ -53,19 +61,21 @@ 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+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 `meld` t2) `meld` (t3 `meld` t4) : fuser' ts-		fuser' [t1,t2,t3]	= [t1 `meld` t2 `meld` t3]-		fuser' [t1,t2]		= [t1 `meld` t2]+			(t1 >< t2) >< (t3 >< t4) : fuser' ts+		fuser' [t1,t2,t3]	= [t1 >< t2 >< t3]+		fuser' [t1,t2]		= [t1 >< t2] 		fuser' ts		= ts-	in meld `seq` fuser+	in fuser +fusing :: Monoid m => [m] -> Maybe m+fusing = fusing' mappend+ {- fusing [] = Nothing fusing [t] = Just t@@ -95,8 +105,17 @@ 			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) 	#-}+

@@ -1,135 +1,132 @@-{-# LANGUAGE PatternGuards, TypeFamilies, GeneralizedNewtypeDeriving #-}-{-# OPTIONS -fno-warn-missing-methods #-}+{-# LANGUAGE TypeFamilies, PatternGuards #-} --- | An experimental trie-based priority queue for lists.-module Data.Queue.TrieQueue where--- Data.Sequence-labelled trie implementation, bootstrapping monoid structure to achieve maximum great justice.+-- | @TrieQueue e@ is a priority queue @IQueue@ instance satisfying @QueueKey (TrieQueue e) ~ [e]@, with the property that this queue frequently performs better than any other queue+-- implementation in this package for keys of type @[e]@.  +-- +-- This particular implementation is highly experimental and possibly a genuinely new data structure.  See the source code for details.+-- However, for many cases this priority queue may be used for a heap sort that runs faster than the "Data.List" implementation,+-- or the vanilla "Data.Queue.PQueue" implementation. -import Data.Queue.Class-import Data.Queue.QueueHelpers+module Data.Queue.TrieQueue (TrieQueue) where  import Control.Arrow((***))-import Control.Monad(liftM2)--import Data.Function-import Data.Maybe-import Data.List (sortBy, groupBy)+import Control.Monad import Data.Monoid-import Data.Ord-import Data.Sequence (Seq, viewl, ViewL(..), (><), (|>), (<|))-import qualified Data.Sequence as Seq-import Data.Map (Map, findMin, minViewWithKey, fromDistinctAscList)-import qualified Data.Map as Map-import qualified Data.Foldable as Fold (toList)+import Data.Maybe +import Data.Queue.Class+import Data.Queue.QueueHelpers(fusing')++import Data.Queue.TrieQueue.Edge+import Data.Queue.TrieQueue.MonoidQueue+import Data.Queue.TrieQueue.TrieLabel+ import GHC.Exts -type Label e = Seq e+import Prelude hiding (null) --- Type of a nonempty trie.-data Trie e = 	Leaf (Label e) {-# UNPACK #-} !Int 	-- Leaf xs n represents n occurrences of the string xs.  n is always strictly positive.-	      | Edge (Label e) {-# UNPACK #-} !Int (Map e (Trie e)) -- Edge xs n m represents n occurrences of xs, and xs prepended to each element of the map.-		deriving (Eq)-type MTrie e = Maybe (Trie e)-newtype TrieQueue e = TQ (HeapQ (Trie e)) deriving (Eq, Show, Monoid)+-- On the back end it uses something called a /monoid queue/,+-- which takes ordered keys associated with monoid values and returns (k, m') pairs where m' is the concatenation of every monoid value associated with k,+-- with no guarantees made upon the order of the concatenation.  Essentially, it is a priority queue which internally "merges" values with equal keys.+-- See Data.Queue.TrieQueue.MonoidQueue for details and a list of alternative implementations. -{-# INLINE mkTQ #-}-mkTQ :: Int -> Trie e -> TrieQueue e-mkTQ n t = TQ (HQ n (Just t))+-- After some experimentation, trie edge labels are currently implemented as vanilla lists; however, the implementation is modularized in+-- Data.Queue.TrieQueue.EdgeLabel.  (Other possible implementations include mergeable deques and Data.Sequence finger trees.) -mkLab :: [e] -> Label e-mkLab = Seq.fromList+-- A trie, now, consists of an edge label xs, the number of strings ending with that label, and a monoid queue associating characters in the string to+-- tries consisting of strings prefixed by that character.  This is the key variation in this implementation, and it exploits the fact that+-- random-access string lookup is not required in a priority queue: only extract-min and insert, operations perfectly well suited to a monoid queue.+-- Note that the monoid values in the monoid queue are themselves tries, which get recursively merged as necessary. -instance Show e => Show (Trie e) where-	show (Leaf xs xn) = "(" ++ show xn ++ "x" ++ show (Fold.toList xs) ++ ")"-	show (Edge xs xn m) = "==" ++ show xn ++ "x" ++ show (Fold.toList xs) ++ "==>" ++ show m+data Trie e = Trie (Label e) {-# UNPACK #-} !Int (MQueue e (Trie e)) deriving (Show)+data TrieQueue e = TQ Int (Maybe (Trie e)) deriving (Show) +-- This monoid instance can now get exploited for great justice by the monoid queue. instance Ord e => Monoid (Trie e) where-	-- not a true monoid instance; only a semigroup-	mappend = merger+	mempty = Trie mempty 0 mempty+	mappend = mergeTrie+	mconcat = fromMaybe mempty . mergeTries -instance Ord e => IQueue (TrieQueue e) where-	type QueueKey (TrieQueue e) = [e]-	empty = mempty-	merge = mappend-	mergeAll = mconcat+{-# INLINE forceOrd #-}+forceOrd :: Ord e => Trie e -> x -> x+forceOrd t x = cmp t `seq` x where+	cmp :: Ord e => Trie e -> (e -> e -> Ordering)+	cmp _ = compare -	singleton xs = mkTQ 1 $ Leaf (mkLab xs) 1---	fromList = TQ . liftM2 HQ length trieFromList+catTrie :: Ord e => Label e -> Trie e -> Trie e+xs `catTrie` Trie ys yn yQ = Trie (xs `mappend` ys) yn yQ -	extract (TQ (HQ n t)) = fmap ((Fold.toList *** (TQ . HQ (n-1))) . extractMin') t-	size (TQ (HQ n _)) = n+consTrie :: Ord e => e -> Trie e -> Trie e+x `consTrie` Trie xs xn xQ = Trie (x `cons` xs) xn xQ -catTrie :: Ord e => Label e -> Trie e -> Trie e-catTrie xs (Leaf ys n) = Leaf (xs >< ys) n-catTrie xs (Edge ys n m) = compactTrie (Edge (xs >< ys) n m)+mergeTrie :: Ord e => Trie e -> Trie e -> Trie e+xT@(Trie xs0 xn xQ) `mergeTrie` yT@(Trie ys0 yn yQ) = merging xs0 ys0 split (tail xT yT) (tail yT xT) xy where+	end (Trie _ xn xQ) x xs = x :- Trie xs xn xQ+	split pfx x xs y ys = let xEnd = end xT x xs; yEnd = end yT y ys in Trie pfx 0 (xEnd `insert` singleton yEnd)+	tail (Trie xs xn xQ) yT y ys = let yEnd = end yT y ys in Trie xs xn (yEnd `insert` xQ)+	xy = Trie xs0 (xn + yn) (xQ `merge` yQ) -compactTrie :: Ord e => Trie e -> Trie e-compactTrie = fromJust . compactTrie'+{-# INLINE compactTrie #-}+compactTrie :: Ord e => Trie e -> Maybe (Trie e)+compactTrie (Trie xs 0 xQ)+	| null xQ	= Nothing+	| Just (y :- t) <- extractSingle xQ+			= Just (xs `catTrie` (y `consTrie` t))+compactTrie t = Just t -compactTrie' :: Ord e => Trie e -> MTrie e-compactTrie' t@(Edge xs 0 m)-	| Map.null m	= Nothing-	| Map.size m == 1, (y, yT) <- findMin m-			= Just $ catTrie (xs |> y) yT-	| otherwise	= Just t-compactTrie' (Edge xs n m)-	| Map.null m	= Just $ Leaf xs n-compactTrie' (Leaf _ 0) = Nothing-compactTrie' t = Just t+data Acc e = A {-# UNPACK #-} !Int e +-- Note that a monoid queue is built up and (sometimes) torn down for each character.  If every label on every trie being merged matches+-- on the first character, then the monoid queue simply automatically becomes a singleton, a case handled by compactTrie with a specialized+-- implementation based on extractSingle.  If the labels do not match, or there are tries being merged with empty labels,+-- then the monoid queue is exactly what we needed anyway.+mergeTries :: Ord e => [Trie e] -> Maybe (Trie e)+mergeTries ts0 = compactTrie (Trie mempty nEmpty ([x :- Trie xs xn xQ | Trie (x:xs) xn xQ <- ts0] `insertAll` mergeAll qs))+	where	A nEmpty qs = foldr procEmpty (A 0 []) ts0+		procEmpty (Trie [] n q) (A nEmpty qs) = A (n + nEmpty) (q:qs)+		procEmpty _ acc = acc +--mergeTries = fusing' mergeTrie -extractMin' :: Ord e => Trie e -> (Label e, MTrie e)-extractMin' (Leaf xs n) = (xs, compactTrie' (Leaf xs (n-1)))-extractMin' (Edge xs (n+1) m) = (xs, compactTrie' (Edge xs n m))-extractMin' (Edge xs 0 m)-	| Just ((y, yT), m') <- minViewWithKey m,-		(ys, yT') <- extractMin' yT-	= (xs >< (y <| ys), maybe (compactTrie' (Edge xs 0 m')) (\ yT' -> Just $ Edge xs 0 $ Map.insert y yT' m') yT')-extractMin' _ = error "Internal failure to note empty queue"+{-# INLINE fin #-}+fin :: Ord e => Trie e -> Maybe (Trie e)+fin (Trie _ 0 q) | null q = Nothing+fin t = Just t ---extractMin :: Ord e => Trie e -> Maybe ([e], Trie e)---extractMin = fmap (first toList) . extractMin'+-- If there are strings ending at this label, we obviously process those.  Otherwise, we recurse to the first hanging trie from the monoid queue.+-- If it is not exhausted, then we can simply replace the value in the monoid queue; if it is exhausted we may possibly compact the trie+-- (e.g. if there is now only one child trie and we may in fact combine those edges).+extractTrie :: Ord e => Trie e -> (Label e, Maybe (Trie e))+extractTrie (Trie xs (n+1) xQ) = (xs, inline compactTrie (Trie xs n xQ))+extractTrie (Trie xs 0 xQ)+	| Just (y :- t, xQ') <- extract xQ, (ys, t') <- extractTrie t+		= (xs `mappend` (y `cons` ys), case t' of+			Nothing	-> inline compactTrie (Trie xs 0 xQ')+			Just t'	-> fin (Trie xs 0 $ replace (y :- t') xQ))+extractTrie _ = error "Failure to detect empty queue" -type TailMaker e = Label e -> Trie e+instance Ord e => Monoid (TrieQueue e) where+	mempty = TQ 0 Nothing+	TQ n1 t1 `mappend` TQ n2 t2 = TQ (n1 + n2) (t1 `mappend` t2)+	mconcat ts = TQ (sum [n | TQ n _ <- ts]) (mergeTries [t | TQ _ (Just t) <- ts]) -{-# INLINE merge' #-}-merge' :: Ord e => Label e -> Label e -> TailMaker e -> TailMaker e -> (e -> TailMaker e) -> (e -> TailMaker e) -> Trie e -> Trie e-merge' xs0 ys0 xTail yTail xCons yCons xy = merge'' 0 xs0 ys0 where-	merge'' n xs ys = case (viewl xs, viewl ys) of-		(x :< xs1, y :< ys1) -> let pfx = Seq.take n xs0; xT = xTail xs1; yT = yTail ys1; in case x `compare` y of-			LT	-> Edge pfx 0 $ fromDistinctAscList [(x, xT), (y, yT)]-			EQ	-> merge'' (n+1) xs1 ys1-			GT	-> Edge pfx 0 $ fromDistinctAscList [(y, yT), (x, xT)]-		(x :< xs1, EmptyL)	-> yCons x xs1-		(EmptyL, y :< ys1)	-> xCons y ys1-		(EmptyL, EmptyL)	-> xy+instance Ord e => IQueue (TrieQueue e) where+	type QueueKey (TrieQueue e) = [e]+	empty = mempty+	merge = mappend+	mergeAll = mconcat 	-merger :: Ord e => Trie e -> Trie e -> Trie e	-Leaf xs0 xn `merger` Leaf ys0 yn =-	merge' xs0 ys0 (flip Leaf xn) (flip Leaf yn) (edger xs0 xn yn) (edger ys0 yn xn) (Leaf xs0 (xn + yn))-	where	edger xs xn yn y ys = Edge xs xn $ Map.singleton y (Leaf ys yn)-Leaf xs0 xn `merger` Edge ys0 yn yM =-	merge' xs0 ys0 (flip Leaf xn) (\ ys -> Edge ys yn yM) (\ y ys -> Edge xs0 xn $ Map.singleton y (Edge ys yn yM))-		(\ x xs -> Edge ys0 yn $ Map.insertWith merger x (Leaf xs xn) yM) (Edge xs0 (xn + yn) yM)-x@Edge{} `merger` y@Leaf{} = merger y x-Edge xs0 xn xM `merger` Edge ys0 yn yM-	= merge' xs0 ys0 (edger xn xM) (edger yn yM) (cons xs0 xn yn yM) (cons ys0 yn xn xM)-			(Edge xs0 (xn + yn) $ Map.unionWith merger xM yM)-	where	edger n m l = Edge l n m-		cons xs xn yn yM y = Edge xs xn . Map.singleton y . edger yn yM+	singleton = TQ 1 . Just . single+	insertAll = mappend . fromListTrie+	fromList = fromListTrie -trieFromList :: Ord e => [[e]] -> MTrie e-trieFromList = extractCommon mempty-	where	groupHeads = groupBy ((==) `on` listToMaybe) . sortBy (comparing listToMaybe)-		extractCommon pfx xs = case groupHeads xs of-			[]			-> Nothing-			[empties@([]:_)]	-> Just $ Leaf pfx (length empties)-			(empties@([]:_):xss)	-> Just $ Edge pfx (length empties) (fromGroups xss)-				-- even if there's only one other group, we end the edge here-				-- a more optimized implementation might specialize for this case-			[(y:ys):yss]		-> extractCommon (pfx |> y) (ys:map tail yss)-				-- if there's but a single group with a shared first character, snoc it onto the accumulated prefix-				-- and recurse-			xss			-> Just $ Edge pfx 0 (fromGroups xss)-		fromGroups xss = fromDistinctAscList [(y, fromJust $ trieFromList $ ys : map tail yss) | ((y:ys):yss) <- xss]+	extract (TQ n t) = fmap ((labelToList *** TQ (n-1)) . extractTrie) t+	null (TQ _ Nothing) = True+	null _ = False++	size (TQ n _) = n++fromListTrie :: Ord e => [[e]] -> TrieQueue e+fromListTrie = liftM2 TQ length (mergeTries . map single)++single :: Ord e => [e] -> Trie e+single xs = Trie (labelFromList xs) 1 mempty

@@ -0,0 +1,14 @@+{-# LANGUAGE TypeFamilies, TypeOperators #-}++-- | As simple as it looks: an edge type constructor that performs comparisons only on its key.+module Data.Queue.TrieQueue.Edge ((:-)(..)) where++data k :- m = k :- m deriving (Show)++instance Eq k => Eq (k :- m) where+	(x :- _) == (y :- _) = x == y++instance Ord k => Ord (k :- m) where+	(x :- _) `compare` (y :- _) = x `compare` y+	(x :- _) <= (y :- _) = x <= y+

@@ -0,0 +1,111 @@+{-# LANGUAGE TypeFamilies, TypeOperators, PatternGuards #-}+{-# OPTIONS -fno-warn-missing-methods #-}++{- |+This module implements the functionality of a /monoid queue/, which is essentially a priority queue that merges values with equal keys.  Several implementations were considered:++* A pairing heap which, as part of its merging operation, merges any identical-keyed values it encounters.  This may result in partial merging of equal-keyed values for several different keys+	during a single delete-min operation, decreasing the number of nodes in the queue without costing any additional comparisons.  In addition, it naturally falls out that+	the values associated with the minimum key are always fully merged.  Disadvantages include no control over the balancedness of complete merges, and possible extra polymorphism overhead.+* This considerably simpler bootstrap on a vanilla @PQueue@, which keeps the totally merged value associated with its very minimum key and performs no partial merging until a+	key becomes the minimum. (The fact that no partial merging is performed allows an optimized and balanced 'mconcat' to be used on all the values associated with a key at once.)++The primary difference between these two is the compromise between /performance of the heap itself/ and /performance of the merging of the monoids/:+	* The first implementation speculatively takes advantage of opportunities to merge nodes with equal keys.  No actual extra work is being done -- the same number of comparisons+		is made, and the actual merging is performed lazily.  As a result, truly the only disadvantages of this approach are the completely uncontrolled balance of the merges,+		and possible polymorphism overhead that can be carefully hand-removed.+	* The second implementation allows an optimized bulk merge operation, which -- in the case of tries, which is what after all the motivation for this structure --+		has extremely significant advantages.++A version of the second implementation is included with the Cabal distribution in +"Data.Queue.TrieQueue.MonoidQueue2", and can serve as a literal drop-in replacement for this module.+See its implementation notes for further details.++-}+module Data.Queue.TrieQueue.MonoidQueue (MQueue, extractSingle, replace) where++import Data.Queue.Class+import Data.Queue.QueueHelpers(fusing')+import Data.Maybe+import Data.Monoid+import qualified Data.Tree as Tree++import Data.Queue.TrieQueue.Edge++-- | A pairing heap node in the monoid queue; nonempty.+data MNode k m = Node k m (MForest k m)+type MForest k m = [MNode k m]+-- | A full-fledged priority queue, including empty queues.+newtype MQueue k m = MQ (Maybe (MNode k m)) deriving (Show)++instance (Show k, Show m) => Show (MNode k m) where+	show = Tree.drawTree . Tree.unfoldTree (\ (Node k m ts) -> (show (k :- m), ts))++-- | A @Functor@ instance exploited for great justice in @mergeNodes@.+instance Functor (MNode k) where+	fmap f (Node k m ns) = Node k (f m) (map (fmap f) ns)++instance (Ord k, Monoid m) => Monoid (MNode k m) where+	-- no mempty declaration+	mappend = mergeMNode $! mappend++instance (Ord k, Monoid m) => Monoid (MQueue k m) where+	mempty = MQ Nothing+	MQ n1 `mappend` MQ n2 = MQ (n1 `mappend` n2)+	 -- This is the straightforward implementation:+	 -- mconcat qs = MQ $ fusing [n | MQ (Just n) <- qs]+	 -- This implementation allows optimized mass mconcats rather than just using individual mappends,+	 -- and exploits the flexible monoid structure.+	mconcat qs = mergeNodes [n | MQ (Just n) <- qs]+++mergeMNode :: Ord k => (m -> m -> m) -> MNode k m -> MNode k m -> MNode k m+mergeMNode (><) n1@(Node k1 m1 ns1) n2@(Node k2 m2 ns2) = case compare k1 k2 of+	LT	-> Node k1 m1 (n2:ns1)+	EQ	-> Node k1 (m1 >< m2) (ns1 ++ ns2)+	GT	-> Node k2 m2 (n1:ns2)++{-# INLINE mergeNodes' #-}+-- | Merges a collection of nodes by performing a balanced fuse and performing an mconcat on all blocks of equal-keyed monoid values.+mergeNodes' :: (Ord k) => (k -> k -> Ordering) -> (m -> m -> m) -> MForest k m -> MQueue k m+--mergeNodes ns = MQ (fmap (fmap mconcat) $ fusing (map (fmap $ \ m -> [m]) ns))+mergeNodes' _ (><) = MQ . fusing' (mergeMNode (><))++{-# INLINE mergeNodes #-}+mergeNodes :: (Ord k, Monoid m) => MForest k m -> MQueue k m+mergeNodes = (mergeNodes' $! compare) $! mappend++instance (Ord k, Monoid m) => IQueue (MQueue k m) where+	type QueueKey (MQueue k m) = k :- m+	empty = mempty+	merge = mappend+	mergeAll = mconcat++	singleton (k :- m) = MQ (Just (Node k m []))+	insertAll = merge . fromListMQ+	fromList = fromListMQ+	extract = extractMQ++	null (MQ Nothing) = True+	null _ = False++{-# INLINE single #-}+single :: k :- m -> MNode k m+single (k :- m) = Node k m []++extractMQ :: (Ord k, Monoid m) => MQueue k m -> Maybe (k :- m, MQueue k m)+extractMQ (MQ t) = fmap extract' t where+	extract' (Node k m ns) = (k :- m, mergeNodes ns)++fromListMQ :: (Ord k, Monoid m) => [k :- m] -> MQueue k m+fromListMQ ks = mergeNodes $ map single ks++{-# INLINE extractSingle #-}+extractSingle :: (Ord k, Monoid m) => MQueue k m -> Maybe (k :- m)+extractSingle (MQ (Just (Node k m []))) = Just (k :- m)+extractSingle _ = Nothing++-- UNSAFE.  Do not use unless you know the key you're putting in is less than or equal to the minimum key.+replace :: (Ord k, Monoid m) => (k :- m) -> MQueue k m -> MQueue k m+replace km@(k :- m) (MQ t) = MQ $ Just (maybe (single km) (\ (Node _ _ ns) -> Node k m ns) t)+

@@ -0,0 +1,84 @@+{-# 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"

@@ -0,0 +1,69 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++module Data.Queue.TrieQueue.TrieLabel where++import Data.Sequence (Seq, ViewL(..), viewl, (><), (<|), (|>))+import qualified Data.Sequence as Seq+import qualified Data.Foldable as Fold++type Split e x = Label e	-- ^ common prefix+		-> e -> Label e	-- ^ truncated suffix of xs+		-> e -> Label e	-- ^ truncated suffix of xs+		-> x		-- ^ split trie++type Tail e x = e -> Label e	-- left over suffix+		-> x		-- trie+++{-# INLINE merging #-}+-- | Performs partial matching of two labels and applies an appropriate function upon completing a partial match.+merging :: Eq e => Label e		-- ^ A label, @xs@.+			-> Label e	-- ^ A label, @ys@.+			-> Split e x	-- ^ A function to be applied when the two strings share some (possibly empty) common prefix and mismatchng tails.+			-> Tail e x	-- ^ A function to be applied when @xs@ is a prefix of @ys@.+			-> Tail e x 	-- ^ A function to be applied when @ys@ is a prefix of @xs@.+			-> x		-- ^ A value to be returned when @xs == ys@.+			-> x++cons :: e -> Label e -> Label e++labelToList :: Label e -> [e]++labelFromList :: [e] -> Label e++merging xs0 ys0 split xEnd yEnd xy = merging' 0 xs0 ys0 where+	merging' n xs ys = let pfx = take n xs0 in case (xs, ys) of+		(x:xs, y:ys)	| x == y	-> merging' (n+1) xs ys+				| otherwise	-> split pfx x xs y ys+		(x:xs, [])			-> yEnd x xs+		([], y:ys)			-> xEnd y ys+		([], [])			-> xy+type Label e = [e]++cons = (:)+labelToList = id+labelFromList = id+{-++type Label e = Seq e++merging xs0 ys0 split xEnd yEnd xy = merging' 0 (Fold.toList xs0) (Fold.toList ys0) where+	merging' n xs ys = let n' = n + 1; (pfx, xT0) = Seq.splitAt n xs0; _ :< xT = viewl xT0; yT = Seq.drop n' ys0 in case (xs, ys) of+		(x:xs, y:ys)	| x == y	-> merging' n' xs ys+				| otherwise	-> split pfx x xT y yT+		(x:xs, [])			-> yEnd x xT+		([], y:ys)			-> xEnd y yT+		([], [])			-> xy++cons = (<|)++labelToList = Fold.toList++labelFromList = Seq.fromList+-}++testMerging :: (Eq e, Show e) => Label e -> Label e -> String+testMerging xs0 ys0 = merging xs0 ys0 (\ pfx x xs y ys -> "Split " ++ show pfx ++ " (" ++ show x ++ " -> " ++ show xs ++ ") (" ++ show y ++ " -> " ++ show ys ++ ")")+				(\ y ys -> "Break " ++ show xs0 ++ " = " ++ show y ++ " -> " ++ show ys)+				(\ x xs -> "Break " ++ show ys0 ++ " = " ++ show x ++ " -> " ++ show xs)+				("Equal " ++ show xs0)

@@ -1,7 +1,8 @@ name:		queuelike-version:	1.0.5+version:	1.0.6 synopsis:	A library of queuelike data structures, both functional and stateful. description:	Contains several implementations of data structures implementing a /single-in, single-out/ paradigm.  Intended to be a better, more useful replacement for pqueue-mtl.+		In particular, includes an experimental and possibly genuinely new trie-based priority queue on strings.  Feedback is appreciated. tested-with:	GHC category:	Algorithms stability:	experimental@@ -10,7 +11,7 @@ license-file:	LICENSE author:		Louis Wasserman maintainer:	wasserman.louis@gmail.com-build-Depends:	base, containers, mtl, array, stateful-mtl >= 1.0.7, utility-ht+build-Depends:	base, containers, mtl, array, stateful-mtl >= 1.0.7 build-type:	Simple Exposed-modules: 	Data.Queue@@ -20,9 +21,6 @@ 	Data.Queue.Stack 	Data.Queue.Queue 	Data.Queue.TrieQueue---	Data.Queue.SkewQueue---	Data.Queue.SoftHeap---	Data.Queue.IntQueue 	Data.MQueue.Class 	Data.MQueue.Heap 	Data.MQueue.SyncQueue@@ -30,6 +28,10 @@ 	Data.MQueue other-modules:  	Data.Queue.QueueHelpers+	Data.Queue.TrieQueue.Edge+	Data.Queue.TrieQueue.MonoidQueue+	Data.Queue.TrieQueue.TrieLabel 	Data.MQueue.MonadHelpers---	Data.Queue.Numeric+extra-source-files:+	Data/Queue/TrieQueue/MonoidQueue2.hs ghc-options: