packages feed

pqueue-mtl 1.0.5 → 1.0.6

raw patch · 11 files changed

+209/−114 lines, 11 filesdep +uvectordep ~stateful-mtl

Dependencies added: uvector

Dependency ranges changed: stateful-mtl

Files

Control/Monad/Queue/Class.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, TypeOperators #-} -module Control.Monad.Queue.Class ((:->)(..), MonadQueue(..)) where+module Control.Monad.Queue.Class (MonadQueue(..)) where  import qualified Control.Monad.State.Strict as StrictS import qualified Control.Monad.State.Lazy as LazyS@@ -12,14 +12,6 @@ import qualified Control.Monad.Writer.Lazy as LazyW  import Data.Monoid---- | Type that only orders on the key, ignoring the value completely; frequently useful in priority queues, so made available here.-data e :-> f = e :-> f--instance Eq f => Eq (e :-> f) where-	(_ :-> x) == (_ :-> y) = x == y-instance Ord f => Ord (e :-> f) where-	(_ :-> x) `compare` (_ :-> y)	= compare x y  -- | Typeclass abstraction of a monad with access to a mutable queue.  Minimal implementation: 'queueInsert' or 'queueInsertAll', 'queuePeek', 'queueExtract' or 'queueDelete', 'queueSize'. class Monad m => MonadQueue m where
Control/Monad/Queue/Heap.hs view
@@ -2,14 +2,16 @@  {- | Safe implementation of an array-backed binary heap.  The 'HeapT' transformer requires that the underlying monad provide a 'MonadST' instance, meaning that the bottom-level monad must be 'ST'.  This critical restriction protects referential transparency, disallowing multi-threaded behavior as if the '[]' monad were at the bottom level. (The 'HeapM' monad takes care of the 'ST' bottom level automatically.) -}-module Control.Monad.Queue.Heap (HeapM, HeapT, runHeapM, runHeapMOn, runHeapT, runHeapTOn) where+module Control.Monad.Queue.Heap (HeapM, HeapT, runHeapM, runHeapMOn, runHeapT, runHeapTOn, UHeapT, runUHeapT) where  import Control.Monad.Array.ArrayT+import Control.Monad.Array.Unboxed import Control.Monad.Array.Class  import Control.Monad.ST import Control.Monad.ST.Class +import Data.Array.Vector import Control.Monad.State.Strict import Control.Monad.RWS.Class import Control.Monad.Queue.Class@@ -20,6 +22,7 @@ type HeapM s e = HeapT e (ST s) -- | Monad transformer based on an array implementation of a standard binary heap. newtype HeapT e m a = HeapT {execHeapT :: StateT Int (ArrayT e m) a} deriving (Monad, MonadPlus, MonadFix, MonadReader r, MonadWriter w)+newtype UHeapT e m a = UHeapT {execUHeapT :: StateT Int (UArrayT e m) a} deriving (Monad, MonadFix, MonadReader r, MonadWriter w)  instance MonadTrans (HeapT e) where 	lift = HeapT . lift . lift@@ -38,6 +41,9 @@ runHeapT :: (MonadST m, Monad m) => HeapT e m a -> m a runHeapT m = runArrayT_ 16 (evalStateT (execHeapT m) 0) +runUHeapT :: (MonadST m, Monad m, UA e, Ord e) => UHeapT e m a -> m a+runUHeapT m = evalUArrayT 16 (evalStateT (execUHeapT m) 0)+ -- | Runs an 'HeapM' computation starting with a heap initialized to hold the specified list.  (Since this can be done with linear preprocessing, this is more efficient than inserting the elements one by one.) runHeapTOn :: (MonadST m, Monad m, Ord e) =>  				HeapT e m a -- ^ The transformer operation.@@ -64,10 +70,28 @@ 		unsafeReadAt (size - 1) >>= heapDown (size - 1) 0 >> unsafeWriteAt (size-1) undefined 	queueSize = HeapT get +instance (MonadST m, Monad m, UA e, Ord e) => MonadQueue (UHeapT e m) where+	type QKey (UHeapT e m) = e+	queuePeek = UHeapT $ do	+		size <- get+		if size > 0 then liftM Just (unsafeReadAt 0) else return Nothing+	queueInsert x = UHeapT $ do+		size <- get+		ensureHeap (size+1)+		put (size + 1)+		heapUp size x+	queueDelete = UHeapT $ do+		size <- get+		put (size - 1)+		unsafeReadAt (size - 1) >>= heapDown (size - 1) 0+	queueSize = UHeapT get++{-# INLINE ensureHeap #-} ensureHeap :: MonadArray m => Int -> m () ensureHeap n = do	cap <- askSize-			when (n - 1 >= cap) (resize (2 * n))+			when (n - 1 >= cap) (resize (4 * n)) +{-# INLINE heapUp #-} heapUp :: (MonadArray m, e ~ ArrayElem m, Ord e) => Int -> e -> m () heapUp = let	heapUp' 0 x	= unsafeWriteAt 0 x 		heapUp' i x	= let j = (i - 1) `quot` 2 in do@@ -75,6 +99,7 @@ 			if x >= aj then unsafeWriteAt i x else unsafeWriteAt i aj >> heapUp' j x 		in heapUp' +{-# INLINE heapDown #-} heapDown :: (MonadArray m, e ~ ArrayElem m, Ord e) => Int -> Int -> e -> m () heapDown size = heapDown' 	where	heapDown' i x = let lch = 2 * i + 1; rch = lch + 1 in case compare rch size of
Control/Monad/Queue/QueueT.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}-+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances #-}  -- | A monad transformer allowing a purely functional queue implementation (specifically, implementing the 'Queuelike' abstraction) to be used in a monadic, single-threaded fashion. module Control.Monad.Queue.QueueT where@@ -9,7 +8,7 @@  import Control.Monad.Trans.Operations -import Control.Monad.State.Lazy+import Control.Monad.State.Strict import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.Fix@@ -28,6 +27,8 @@ type FibQueueM e = QueueM (FQueue e) type SkewQueueT e = QueueT (SkewQueue e) type SkewQueueM e = QueueM (SkewQueue e)+type IntQueueT = QueueT IntQueue+type IntQueueM = QueueM IntQueue  -- | Unwraps a queue transformer, initializing it with an empty queue. runQueueT :: (Monad m, Queuelike q) => QueueT q m a -> m a@@ -50,9 +51,11 @@ 	put = lift . put  instance (Monad m, Queuelike q) => MonadQueue (QueueT q m) where-	type QKey (QueueT q m) = QueueKey q 	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (PQueueT e m) #-} 	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (FibQueueT e m) #-}+	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (SkewQueueT e m) #-}+	{-# SPECIALIZE instance (Monad m) => MonadQueue (IntQueueT m) #-}+	type QKey (QueueT q m) = QueueKey q 	queueInsert x = QueueT $ modify (insert x) 	queueInsertAll xs = QueueT $ modify (insertAll xs) 	queueExtract = QueueT $ statefully (\ q -> maybe (Nothing, q) (\ (x, q') -> (Just x, q')) (extract q))@@ -62,9 +65,11 @@ 	queueSize = QueueT $ gets size  instance Queuelike q => MonadQueue (QueueM q) where-	type QKey (QueueM q) = QueueKey q 	{-# SPECIALIZE instance Ord e => MonadQueue (PQueueM e) #-} 	{-# SPECIALIZE instance Ord e => MonadQueue (FibQueueM e) #-}+	{-# SPECIALIZE instance Ord e => MonadQueue (SkewQueueM e) #-}+	{-# SPECIALIZE instance MonadQueue IntQueueM #-}+	type QKey (QueueM q) = QueueKey q 	queueInsert x = QueueM $ modify (insert x) 	queueInsertAll xs = QueueM $ modify (insertAll xs) 	queueExtract = QueueM $ statefully (\ q -> maybe (Nothing, q) (\ (x, q') -> (Just x, q')) (extract q))
Data/Queue/Class.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, TypeFamilies #-}  -- | Abstracts the implementation details of a single-insertion, single-extraction queuelike structure. module Data.Queue.Class where@@ -8,6 +8,14 @@  import Control.Monad.Instances() import Control.Monad++-- | Type that only orders on the key, ignoring the value completely; frequently useful in priority queues, so made available here.+data e :-> f = e :-> f++instance Eq f => Eq (e :-> f) where+	(_ :-> x) == (_ :-> y) = x == y+instance Ord f => Ord (e :-> f) where+	(_ :-> x) `compare` (_ :-> y)	= compare x y  -- | A generic type class encapsulating a generic queuelike structure, that supports single-insertion and single-extraction; this abstraction includes priority queues, stacks, and FIFO queues.  There are many minimal implementations, so each method lists the prerequisites for its default implementation.  Most implementations will implement 'empty', ('singleton' and 'merge') or 'insert', ('peek' and 'delete') or 'extract', and 'size'. class Queuelike q where
Data/Queue/FibQueue.hs view
@@ -9,11 +9,9 @@ module Data.Queue.FibQueue (FQueue) where  import Data.Queue.Class+import Data.Queue.QueueHelpers(order) import Control.Monad.Array -import GHC.Exts--import Data.Bits import Data.Maybe import Data.Monoid import Data.Ord@@ -21,77 +19,79 @@ import Control.Monad  data RkTree e = RkT {treeRk :: {-# UNPACK #-} !Int, treeMin :: e, _subForest :: [RkTree e]}-data FQueue e = FQueue {elts, _maxRank :: {-# UNPACK #-} !Int, heap :: [RkTree e]}+data FForest e = FF {_maxRk :: {-# UNPACK #-} !Int, trees :: [RkTree e]}	+data FQueue e = FQ {elts :: {-# UNPACK #-} !Int, forest :: {-# UNPACK #-} !(FForest e)} +instance Ord e => Monoid (FQueue e) where+	mempty = FQ 0 emptyFF+	FQ n1 f1 `mappend` FQ n2 f2 = FQ (n1 + n2) (f1 `mergeFF` f2)++emptyFF :: FForest e+emptyFF = FF 0 []++singleFF :: RkTree e -> FForest e+singleFF t@RkT{treeRk} = FF treeRk [t]++{-# INLINE mergeFF #-}+mergeFF :: Ord e => FForest e -> FForest e -> FForest e+FF r1 ts1 `mergeFF` FF r2 ts2 = let (f1, f2) = order cmp ts1 ts2 in+		FF (r1 `max` r2) (f1 ++ f2)+	where	(t1:_) `cmp` (t2:_) = comparing treeMin t1 t2+		[] `cmp` _ = LT+		_ `cmp` [] = GT++extractFF :: Ord e => FForest e -> Maybe (e, FForest e)+extractFF f = do	FF rk (RkT _ x ts : tss) <- return f+			return (x, rebuild $ FF rk (ts ++ tss))+ instance Ord e => Queuelike (FQueue e) where 	type QueueKey (FQueue e) = e-	FQueue n1 r1 h1 `merge` FQueue n2 r2 h2 = FQueue (n1 + n2) (max r1 r2) (case (h1, h2) of-		(t1:_, t2:_)	| comparing treeMin t1 t2 == LT	-> h1 ++ h2-				| otherwise			-> h2 ++ h1-		(_, [])	-> h1-		([], _)	-> h2)-	empty = FQueue 0 0 []-	singleton x = FQueue 1 0 [RkT 0 x []]-	toList_ = concatMap flatten . heap+	merge = mappend+	empty = mempty+	singleton x = FQ 1 $ singleFF (RkT 0 x [])+	toList_ FQ{forest} = concatMap flatten (trees forest) 	size = elts-	peek FQueue{heap} = fmap treeMin (listToMaybe heap)-	delete q = do	FQueue (n+1) mR (RkT _ _ ts : tss) <- return q-			return $ uncurry (FQueue n) $ rebuild mR (ts ++ tss)-	fromList ts = let n = length ts in FQueue n (intLog n) (snd $ findMin $ fromListFQ n ts)--instance Ord e => Monoid (FQueue e) where-	mempty = empty-	mappend = merge-	mconcat = mergeAll+	extract (FQ n f) = fmap (fmap (FQ (n-1))) (extractFF f)  {-# INLINE flatten #-} flatten :: RkTree e -> [e]-flatten t = build (\ c n -> flatten' c t n) where-	flatten' c (RkT _ x ts) n = x `c` foldr (flatten' c) n ts+flatten (RkT _ x ts) = [x] ++ concatMap flatten ts  meldTree :: Ord e => RkTree e -> RkTree e -> RkTree e t1@(RkT d x1 ts1) `meldTree` t2@(RkT _ x2 ts2) 	| x1 <= x2	= RkT (d+1) x1 (t2:ts1) 	| otherwise	= RkT (d+1) x2 (t1:ts2)-+  -- The use of the ArrayM monad here considerably increases readability and efficiency. meld :: Ord e => RkTree e -> ArrayM s (Maybe (RkTree e)) () meld t@RkT{treeRk} = 	ensureSize (treeRk+2) >> readAt treeRk >>= maybe (writeAt treeRk (Just t)) (\ t' -> writeAt treeRk Nothing >> meld (t `meldTree` t')) -data MergeAccum e = MA {-# UNPACK #-} !Int [RkTree e]- {-# INLINE findMin #-}-findMin :: Ord e => [RkTree e] -> (Int, [RkTree e])-findMin ts = case foldr (getMin (comparing treeMin)) (MA 0 []) ts of MA d ls -> (d, ls) ; where-	getMin !cmp t1 (MA d ts) = case ts of-		[]	-> MA (treeRk t1) [t1]-		(t:ts)	| cmp t1 t == LT-				-> MA (max d (treeRk t1)) (t1:t:ts)-			| otherwise-				-> MA (max d (treeRk t1)) (t:t1:ts)+findMin :: Ord e => [RkTree e] -> FForest e+findMin = foldr (mergeFF . singleFF) emptyFF  {-# INLINE rebuild #-}-rebuild :: Ord e => Int -> [RkTree e] -> (Int, [RkTree e])-rebuild maxRank ts = runArrayM (maxRank + 1) Nothing $ mapM_ meld ts >> liftM (\ ts' -> findMin (catMaybes ts')) askElems--fromPow2List :: Ord e => Int -> [e] -> RkTree e-fromPow2List n ts = meldList 1 (map (\ x -> RkT 0 x []) ts) where-	fuse2 (t1:t2:ts) = t1 `meldTree` t2 : fuse2 ts-	fuse2 ts = ts-	meldList p ts	| p < n		= meldList (p + p) (fuse2 ts)-			| otherwise	= head ts--fromListFQ :: Ord e => Int -> [e] -> [RkTree e]-fromListFQ 0 _ = []-fromListFQ n ts = let p = bit (intLog n); (ts1, ts2) = splitAt p ts in fromPow2List p ts1 : fromListFQ (n-p) ts2+rebuild :: Ord e => FForest e -> FForest e+rebuild (FF rk ts) = runArrayM (rk + 1) Nothing $ mapM_ meld ts >> liftM (\ ts' -> findMin (catMaybes ts')) askElems -intLog :: Int -> Int-intLog 0 = 0-intLog 1 = 0-intLog (I# x) = {-# SCC "intLog" #-} I# (intLog1 (int2Word# x)) where-	intLog1 x# = let ans# = uncheckedShiftRL# x# 16# in if ans# `eqWord#` 0## then intLog2 x# else 16# +# intLog2 ans#-	intLog2 x# = let ans# = uncheckedShiftRL# x# 8# in if ans# `eqWord#` 0## then intLog3 x# else 8# +# intLog3 ans#-	intLog3 x# = let ans# = uncheckedShiftRL# x# 4# in if ans# `eqWord#` 0## then intLog4 x# else 4# +# intLog4 ans#-	intLog4 x# = let ans# = uncheckedShiftRL# x# 2# in if ans# `eqWord#` 0## then intLog5 x# else 2# +# intLog5 ans#-	intLog5 x# = if x# `leWord#` 1## then 0# else 1#+-- fromPow2List :: Ord e => Int -> [e] -> RkTree e+-- fromPow2List n ts = meldList 1 (map (\ x -> RkT 0 x []) ts) where+-- 	fuse2 (t1:t2:ts) = t1 `meldTree` t2 : fuse2 ts+-- 	fuse2 ts = ts+-- 	meldList p ts	| p < n		= meldList (p + p) (fuse2 ts)+-- 			| otherwise	= head ts+-- +-- fromListFQ :: Ord e => Int -> [e] -> [RkTree e]+-- fromListFQ 0 _ = []+-- fromListFQ n ts = let p = bit (intLog n); (ts1, ts2) = splitAt p ts in fromPow2List p ts1 : fromListFQ (n-p) ts2+-- +-- intLog :: Int -> Int+-- intLog 0 = 0+-- intLog 1 = 0+-- intLog (I# x) = {-# SCC "intLog" #-} I# (intLog1 (int2Word# x)) where+-- 	intLog1 x# = let ans# = uncheckedShiftRL# x# 16# in if ans# `eqWord#` 0## then intLog2 x# else 16# +# intLog2 ans#+-- 	intLog2 x# = let ans# = uncheckedShiftRL# x# 8# in if ans# `eqWord#` 0## then intLog3 x# else 8# +# intLog3 ans#+-- 	intLog3 x# = let ans# = uncheckedShiftRL# x# 4# in if ans# `eqWord#` 0## then intLog4 x# else 4# +# intLog4 ans#+-- 	intLog4 x# = let ans# = uncheckedShiftRL# x# 2# in if ans# `eqWord#` 0## then intLog5 x# else 2# +# intLog5 ans#+-- 	intLog5 x# = if x# `leWord#` 1## then 0# else 1#
Data/Queue/Instances.hs view
@@ -1,4 +1,4 @@-module Data.Queue.Instances (module Data.Queue.ReverseQueue, module Data.Queue.PQueue, module Data.Queue.FibQueue, module Data.Queue.SkewQueue, module Data.Queue.Stack, module Data.Queue.Queue) where+module Data.Queue.Instances (module Data.Queue.ReverseQueue, module Data.Queue.PQueue, module Data.Queue.FibQueue, module Data.Queue.SkewQueue, module Data.Queue.Stack, module Data.Queue.Queue, module Data.Queue.IntQueue) where  import Data.Queue.PQueue import Data.Queue.FibQueue@@ -6,3 +6,4 @@ import Data.Queue.Queue import Data.Queue.ReverseQueue import Data.Queue.SkewQueue+import Data.Queue.IntQueue
+ Data/Queue/IntQueue.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TypeOperators, TypeFamilies #-}++-- | A small collection of specialized 'Int'-indexed priority queues dealing with both untagged 'Int's and association pairs with 'Int' keys.  The implementation is a simple bootstrap from 'IntMap'.  (Note: Duplicate keys /will/ be counted separately.  No guarantees are made on the order in which values associated with equal keys are returned.)+module Data.Queue.IntQueue (IntQueue, IntAssocQueue) where++import Data.Queue.Class+import Data.Maybe+import qualified Data.IntMap as IM++-- | A 'Queuelike' type with @QueueKey IntQueue ~ Int@.+newtype IntQueue = IQ (IM.IntMap Int)++-- | A 'Queuelike' type with @QueueKey (IntAssocQueue e) ~ e :-> Int@.+newtype IntAssocQueue e = IAQ (IM.IntMap [e])++instance Queuelike IntQueue where+	type QueueKey IntQueue = Int+	x `insert` IQ m = IQ (IM.alter (Just . maybe 1 (+1)) x m)+	xs `insertAll` q = q `merge` fromList xs+	extract (IQ m) = fmap (\ ((k, ct), m') -> (k, IQ (if ct > 1 then IM.insert k (ct - 1) m' else m'))) (IM.minViewWithKey m)+	isEmpty (IQ m) = IM.null m+	empty = IQ IM.empty+	singleton x = IQ (IM.singleton x 1)+	fromList xs = IQ (IM.fromListWith (+) [(x, 1) | x <- xs])+	IQ q1 `merge` IQ q2 = IQ (IM.unionWith (+) q1 q2)+	mergeAll qs = IQ (IM.unionsWith (+) [m | IQ m <- qs])++instance Queuelike (IntAssocQueue e) where+	type QueueKey (IntAssocQueue e) = e :-> Int+	(v :-> k) `insert` IAQ m = IAQ (IM.alter (Just . maybe [v] (v:)) k m)+	xs `insertAll` q = q `merge` fromList xs+	extract (IAQ m) = fmap (\ ((k, v:vs), m') -> (v :-> k, IAQ (if null vs then m' else IM.insert k vs m'))) (IM.minViewWithKey m)+	isEmpty (IAQ m) = IM.null m+	empty = IAQ IM.empty+	singleton (v :-> k) = IAQ (IM.singleton k [v])+	fromList xs = IAQ (IM.fromListWith (++) [(k, [v]) | (v :-> k) <- xs])+	IAQ q1 `merge` IAQ q2 = IAQ (IM.unionWith (++) q1 q2)+	mergeAll qs = IAQ (IM.unionsWith (++) [m | IAQ m <- qs])
Data/Queue/PQueue.hs view
@@ -5,7 +5,7 @@ The implementation of 'PQueue' is based on a /pairing heap/, a simple and efficient implementation of a general-purpose priority queue.  'PQueue' supports 'insert', 'merge', and 'peek' in constant time, and 'extract' and 'delete' in logarithmic time. -} -module Data.Queue.PQueue (PQueue) where+module Data.Queue.PQueue(PQueue) where  import Data.Queue.Class import Data.Queue.QueueHelpers@@ -18,7 +18,7 @@ -- Like with SkewQueue, the real meat of the pairing heap is very succinctly presented: it's all in the Monoid instance, and in the extract method, where the fusing method from QueueHelpers (already used for QueueHelpers' generic merging implementation) provides all the magic.  Everything else is deliciously succinct boilerplate, largely derived from HeapQ's Monoid instance.  data Tree e = T e [Tree e]-newtype PQueue e = PQ (HeapQ (Tree e)) deriving (Monoid, Queuelike)+newtype PQueue e = PQ (HeapQ (Tree e)) deriving (Monoid)  instance Ord e => Monoid (Tree e) where 	-- no actual mzero instance, but induces a correct Monoid instance for Heap e@@ -26,26 +26,25 @@ 		| x1 <= x2	= T x1 (t2:ts1) 		| otherwise	= T x2 (t1:ts2) -instance Ord e => Queuelike (HeapQ (Tree e)) where-	{-# INLINE fromList #-}+instance Ord e => Queuelike (PQueue e) where 	{-# INLINE toList_ #-} 	{-# INLINE mergeAll #-} 	{-# INLINE insertAll #-} -	type QueueKey (HeapQ (Tree e)) = e+	type QueueKey (PQueue e) = e -	empty = mempty-	singleton = single-	fromList ts = mconcat (map single ts)+	empty = PQ mempty+	singleton = PQ . single+	fromList xs = PQ $ fuseMerge $ map single xs -	x `insert` q = q `mappend` single x+	x `insert` q = q `mappend` PQ (single x) 	xs `insertAll` q = q `mappend` fromList xs 	merge = mappend 	mergeAll = mconcat-	-	extract (HQ n t) = fmap (\ (T x ts) ->  (x, HQ (n-1) (fusing ts))) t-	toList_ = maybe [] flatten . heap-	size = elts++	extract (PQ (HQ n t)) = fmap (\ (T x ts) ->  (x, PQ (HQ (n-1) (fusing ts)))) t+	toList_ (PQ (HQ _ t)) = maybe [] flatten t+	size (PQ (HQ n _)) = n  single :: e -> HeapQ (Tree e) single x = HQ 1 $ Just (T x [])
Data/Queue/QueueHelpers.hs view
@@ -19,7 +19,7 @@  -------------------} -module Data.Queue.QueueHelpers (HeapQ(..), endoMaybe, order, fusing) where+module Data.Queue.QueueHelpers (HeapQ(..), endoMaybe, order, fusing, fuseMerge) where  import Data.Monoid @@ -29,9 +29,9 @@ 	{-# INLINE mappend #-} 	{-# INLINE mconcat #-} -	mempty = HQ 0 mempty+	mempty = HQ 0 Nothing 	HQ n1 h1 `mappend` HQ n2 h2 = HQ (n1 + n2) (h1 `mappend` h2)-	mconcat qs = uncurry HQ $ fuseMerge [(n, h) | HQ n h <- qs]+	mconcat = fuseMerge  {-# INLINE endoMaybe #-} endoMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a@@ -41,11 +41,23 @@  {-# 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 mappend ts) where-	fuse !f (t1:t2:ts) = (t1 `f` t2):fuse f ts-	fuse _ ts = ts+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)@@ -55,8 +67,12 @@ data IntAcc e = IA {-# UNPACK #-} !Int e  {-# INLINE fuseMerge #-}-fuseMerge :: Monoid m => [(Int, Maybe m)] -> (Int, Maybe m)-fuseMerge qs = let IA n ts = foldr merger (IA 0 []) qs in (n, fusing ts) where-	merger (m, mt) (IA n ts) = case mt of-		Nothing	-> IA n ts-		Just t	-> IA (n+m) (t:ts)+fuseMerge :: Monoid m => [HeapQ m] -> HeapQ m+fuseMerge 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;+	#-}
Data/Queue/SkewQueue.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns, FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies #-} {-# OPTIONS -fno-warn-missing-methods -fno-warn-name-shadowing #-}  {- | A standard, compact implementation of a skew queue, which offers merging, insertion, and deletion in amortized logarithmic time and size and peek-min in constant time.  @@ -16,28 +16,27 @@ -- Confession: This is as much a toy implementation as anything else, due to the sheer sexy compactness with which skew queues can be implemented in Haskell, especially with the automatically provided monoid structure from QueueHelpers.  The meat of the skew queue implementation is entirely contained in the Monoid instance; everything else is deliciously brief boilerplate.  data BTree e = Tr {treeMin :: e, _left, _right :: Maybe (BTree e)}-newtype SkewQueue e = SQ (HeapQ (BTree e)) deriving (Monoid, Queuelike)+newtype SkewQueue e = SQ (HeapQ (BTree e)) deriving (Monoid)  instance Ord e => Monoid (BTree e) where 	mappend = let t1 `meld` t2 = case order (comparing treeMin) t1 t2 of-			(Tr x l r, t') -> Tr x (endoMaybe meld r (Just t')) l +			(Tr x l r, t') -> Tr x (endoMaybe meld r (Just t')) l 		in meld --instance Ord e => Queuelike (HeapQ (BTree e)) where+instance Ord e => Queuelike (SkewQueue e) where 	{-# INLINE mergeAll #-}-	type QueueKey (HeapQ (BTree e)) = e+	type QueueKey (SkewQueue e) = e  	empty = mempty-	singleton = single-	fromList xs = mconcat (map single xs)+	singleton = SQ . single+	fromList xs = SQ $ fuseMerge (map single xs)  	merge = mappend 	mergeAll = mconcat-	-	extract (HQ n t) = fmap (\ (Tr x l r) -> (x, HQ n (l `mappend` r))) t-	size = elts-	toList_ = flatten . heap++	extract (SQ (HQ n t)) = fmap (\ (Tr x l r) -> (x, SQ (HQ n (l `mappend` r)))) t+	size (SQ HQ{elts}) = elts+	toList_ (SQ HQ{heap}) = flatten heap  single :: e -> HeapQ (BTree e) single x =  HQ 1 $ Just (Tr x Nothing Nothing)
pqueue-mtl.cabal view
@@ -1,16 +1,28 @@  name:		pqueue-mtl-version:	1.0.5+version:	1.0.6 synopsis:	Fully encapsulated monad transformers with queuelike functionality.-description:	Contains several implementations of data structures implementing a /single-in, single-out/ paradigm, and implements monad transformers for their safe use.  The monad transformer part of the library includes tools to fully encapsulate single-threaded use of a priority queue in a monad, including an array-based heap implementation.+description:	Contains several implementations of data structures implementing a /single-in, single-out/ paradigm, +		and implements monad transformers for their safe use.  The monad transformer part of the library +		includes tools to fully encapsulate single-threaded use of a priority queue in a monad, including an +		array-based heap implementation.++		In general, the purely functional queue types can be ordered in increasing order of speed on generic insertion/deletion operations+		 as follows: 'Stack', 'Queue', 'PQueue', 'IntQueue', 'SkewQueue', 'FQueue', 'Heap'.+		('PQueue', 'IntQueue', and 'SkewQueue' are all very nearly the same speed.) ++		Work is in progress on a van Emde Boas+		or y-fast priority queue implementation, which provides sublogarithmic functionality for all operations. tested-with:	GHC category:	Monads, Algorithms+stability:	experimental+bug-reports:	mailto:wasserman.louis@gmail.com license:	BSD3 license-file:	LICENSE author:		Louis Wasserman maintainer:	wasserman.louis@gmail.com-build-Depends:	base, ghc-prim, mtl, containers, stateful-mtl == 1.0.4 , MaybeT+build-Depends:	base, ghc-prim, mtl, containers, stateful-mtl == 1.0.5 , MaybeT, uvector build-type:	Simple-Exposed-modules:Control.Monad.Queue, Control.Monad.Queue.Instances, Control.Monad.Queue.Class, Control.Monad.Queue.Heap, Control.Monad.Queue.QueueT, Data.Queue, Data.Queue.PQueue, Data.Queue.FibQueue, Data.Queue.Class, Data.Queue.Instances, Data.Queue.Stack, Data.Queue.Queue, Data.Queue.ReverseQueue, Data.Queue.SkewQueue+Exposed-modules:Control.Monad.Queue.Instances, Control.Monad.Queue.Class, Control.Monad.Queue.Heap, Control.Monad.Queue.QueueT, Data.Queue, Data.Queue.PQueue, Data.Queue.FibQueue, Data.Queue.Class, Data.Queue.Instances, Data.Queue.Stack, Data.Queue.Queue, Data.Queue.ReverseQueue, Data.Queue.SkewQueue, Data.Queue.IntQueue, Control.Monad.Queue other-modules: Data.Queue.QueueHelpers ghc-options: