packages feed

queuelike 1.0.0 → 1.0.1

raw patch · 17 files changed

+136/−414 lines, 17 files

Files

Data/MQueue.hs view
@@ -1,5 +1,6 @@-module Data.MQueue (module Data.MQueue.Class, module Data.MQueue.Heap, module Data.MQueue.SyncQueue) where+module Data.MQueue (module Data.MQueue.Class, module Data.MQueue.Chan, module Data.MQueue.Heap, module Data.MQueue.SyncQueue) where  import Data.MQueue.Class import Data.MQueue.Heap import Data.MQueue.SyncQueue+import Data.MQueue.Chan
+ Data/MQueue/Chan.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}++-- | Defines a Chan-like structure and makes it an MQueue instance.+module Data.MQueue.Chan where++import Data.MQueue.Class++import Control.Concurrent.Chan+import Control.Monad.Trans++import Control.Monad+import Data.Maybe++instance MonadIO m => MQueue (Chan a) m where+	{-# SPECIALIZE instance MQueue (Chan a) IO #-}+	type MQueueKey (Chan a) = a++	newQueue = liftIO newChan+	push ch = liftIO . writeChan ch+	pop ch = liftIO $ isEmptyChan ch >>= \ ans -> if ans then return Nothing else liftM Just (readChan ch)+	peek ch = liftIO $ isEmptyChan ch >>= \ ans -> if ans then return Nothing else do+		top <- readChan ch+		unGetChan ch top+		return (Just top)+	isEmpty = liftIO . isEmptyChan++blockingPop :: Chan a -> IO a+blockingPop = readChan
− Data/MQueue/ChanQ.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}---- | Defines a Chan-like structure and makes it an MQueue instance.-module Data.MQueue.ChanQ (ChanQ, dupChanQ, pipeChanQ) where--import Data.MQueue.Class--import Control.Concurrent.MVar-import Control.Monad.Trans--import Control.Monad-import Data.Maybe--data ChanQ a = ChanQ {-# UNPACK #-} !(MVar (Stream a)) {-# UNPACK #-} !(MVar (Stream a))--type Stream a = MVar (ChItem a)--data ChItem a = ChItem a (Stream a)--instance MonadIO m => MQueue (ChanQ a) m where-	{-# SPECIALIZE instance MQueue (ChanQ a) IO #-}-	type MQueueKey (ChanQ a) = a--	newQueue = liftIO $ do	hole <- newEmptyMVar-				liftM2 ChanQ (newMVar hole) (newMVar hole)-	push (ChanQ _ writeVar) x = liftIO $ do-		new_hole <- newEmptyMVar-		modifyMVar_ writeVar (\ old_hole -> putMVar old_hole (ChItem x new_hole) >> return new_hole)-	pop (ChanQ readVar _) = liftIO $ modifyMVar readVar $ \ read_end -> tryTakeMVar read_end >>= maybe (return (read_end, Nothing))-		(\ end@(ChItem x new_read_end) -> putMVar read_end end >> return (new_read_end, Just x))-	peek (ChanQ readVar _) = liftIO $ withMVar readVar $ \ read_end -> tryTakeMVar read_end >>= maybe (return Nothing)-		(\ end@(ChItem x new_read_end) -> putMVar read_end end >> return (Just x))-	isEmpty (ChanQ readVar writeVar) = liftIO $ withMVar readVar $ \ r -> withMVar writeVar $ \ w -> return $! r == w--dupChanQ :: ChanQ a -> IO (ChanQ a)-dupChanQ (ChanQ _ writeVar) = do-	hole <- readMVar writeVar-	newReadVar <- newMVar hole-	return (ChanQ newReadVar writeVar)---- pipeChanQ chan1 chan2 places the contents of chan1 at the end of chan2, and any insertions in chan1 will be duplicated in chan2.-pipeChanQ :: ChanQ a -> ChanQ a -> IO ()-pipeChanQ (ChanQ readVar1 writeVar1) (ChanQ _ writeVar2) = do-	old_write_var <- takeMVar writeVar2-	old_read_var <- readMVar readVar1-	modifyMVar_ old_write_var (\ (ChItem x _) -> return (ChItem x old_read_var))-	readMVar writeVar1 >>= putMVar writeVar2
Data/MQueue/Class.hs view
@@ -2,7 +2,7 @@  module Data.MQueue.Class where -import Data.MQueue.MonadHelpers+-- import Data.MQueue.MonadHelpers  -- import Control.Monad.Maybe import Control.Monad.Trans
Data/MQueue/Heap.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, BangPatterns, NamedFieldPuns, RecordWildCards #-}+{-# OPTIONS -fno-warn-name-shadowing #-}  -- | Array-based implementation of an entirely traditional binary heap. module Data.MQueue.Heap (Heap, getSize) where@@ -15,7 +16,7 @@ import Data.STRef import Control.Monad.ST import Control.Monad-import Control.Arrow ((***))+-- import Control.Arrow ((***))  data STHeap s e = STH {size :: {-# UNPACK #-} !Int, arr :: {-# UNPACK #-} !(STArray s Int e)} newtype Heap s e = H {unHeap :: STRef s (STHeap s e)}@@ -51,16 +52,16 @@ queryHeap :: Heap s e -> (STHeap s e -> ST s a) -> ST s a queryHeap = (>>=) . readSTRef . unHeap -onHeap :: Heap s e -> (STHeap s e -> ST s (a, STHeap s e)) -> ST s a-onHeap = modSTRef . unHeap+-- onHeap :: Heap s e -> (STHeap s e -> ST s (a, STHeap s e)) -> ST s a+-- onHeap = modSTRef . unHeap  onHeap_ :: Heap s e -> (STHeap s e -> ST s (STHeap s e)) -> ST s () onHeap_ = modSTRef_ . unHeap -modSTRef :: STRef s a -> (a -> ST s (b, a)) -> ST s b-modSTRef ref f = do	(ans, x') <- f =<< readSTRef ref-			writeSTRef ref x'-			return ans+-- modSTRef :: STRef s a -> (a -> ST s (b, a)) -> ST s b+-- modSTRef ref f = do	(ans, x') <- f =<< readSTRef ref+-- 			writeSTRef ref x'+-- 			return ans  modSTRef_ :: STRef s a -> (a -> ST s a) -> ST s () modSTRef_ ref f = readSTRef ref >>= f >>= writeSTRef ref
Data/MQueue/SyncQueue.hs view
@@ -3,11 +3,11 @@ -- | In the IO monad, provides thread-safe 'MVar'-based wrappers for 'Queuelike' and 'MQueue' instances. module Data.MQueue.SyncQueue (SyncQ, SyncMQ) where -import Data.Queue.Class hiding (peek)+import Data.Queue.Class  import qualified Data.Queue.Class as Q import Data.MQueue.Class -import Data.Tuple.HT+-- import Data.Tuple.HT import Control.Arrow  import Control.Concurrent.MVar@@ -19,19 +19,19 @@ newtype SyncQ q = SyncQ (MVar q) newtype SyncMQ q = SyncMQ (MVar q) -instance (MonadIO m, Queuelike q) => MQueue (SyncQ q) m where-	{-# SPECIALIZE instance Queuelike q => MQueue (SyncQ q) IO #-}+instance (MonadIO m, IQueue q) => MQueue (SyncQ q) m where+	{-# SPECIALIZE instance IQueue q => MQueue (SyncQ q) IO #-} 	type MQueueKey (SyncQ q) = QueueKey q 	newQueue = liftIO $ liftM SyncQ $ newMVar empty 	push (SyncQ var) k = liftIO $ modifyMVar_ var (return . insert k)-	peek = withSyncQ Q.peek+	peek = withSyncQ Q.top 	pop (SyncQ var) = liftIO $ modifyMVar var (\ q -> return ((maybe q snd &&& fmap fst) (extract q))) 	pop_ (SyncQ var) = liftIO $ modifyMVar_ var (return . (fromMaybe `ap` delete)) -- 	getSize = withSyncQ Q.size 	isEmpty = withSyncQ Q.null  {-# INLINE withSyncQ #-}-withSyncQ :: (MonadIO m, Queuelike q) => (q -> a) -> SyncQ q -> m a+withSyncQ :: (MonadIO m, IQueue q) => (q -> a) -> SyncQ q -> m a withSyncQ f (SyncQ var) = liftIO $ withMVar var (return . f)  instance (MonadIO m, MQueue q IO) =>  MQueue (SyncMQ q) m where
Data/Queue/Class.hs view
@@ -17,8 +17,8 @@ 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+-- | 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'.  (The absolute minimal implementation is 'empty', 'insert', 'extract', and 'size'.)+class IQueue q where 	type QueueKey q 	-- | Inserts a single element into the queue.  The default implementation uses 'merge' and 'singleton'. 	insert :: QueueKey q -> q -> q@@ -29,10 +29,10 @@ 	insertAll = flip (foldr insert) 	-- | Attempts to extract an element from the queue; if the queue is empty, returns Nothing.  The default implementation uses 'peek' and 'delete'. 	extract :: q -> Maybe (QueueKey q, q)-	extract = liftM2 (liftM2 (,)) peek delete+	extract = liftM2 (liftM2 (,)) top delete 	-- | Gets the element that will next be extracted from the queue, if there is an element available.  The default implementation uses 'extract'.-	peek ::  q -> Maybe (QueueKey q)-	peek = liftM fst . extract+	top ::  q -> Maybe (QueueKey q)+	top = liftM fst . extract 	-- | Deletes an element from the queue, if the queue is nonempty.  The default implementation uses 'extract'. 	delete :: q -> Maybe q 	delete = liftM snd . extract@@ -51,7 +51,7 @@ 	size = length . toList_ 	-- | Checks if the queue is empty.  The default implementation uses 'peek'. 	null :: q -> Bool-	null = isNothing . peek+	null = isNothing . top 	-- | Extracts every element from the queue.  The default implementation uses 'extract'. 	toList :: q -> [QueueKey q] 	toList = unfoldr extract
Data/Queue/Instances.hs view
@@ -1,10 +1,10 @@-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, module Data.Queue.SoftHeap) 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{-, module Data.Queue.SoftHeap-}) where  import Data.Queue.PQueue -- import Data.Queue.FibQueue import Data.Queue.Stack import Data.Queue.Queue -- import Data.Queue.ReverseQueue-import Data.Queue.SkewQueue+-- import Data.Queue.SkewQueue import Data.Queue.IntQueue-import Data.Queue.SoftHeap+-- import Data.Queue.SoftHeap
− Data/Queue/IntQueue.hs 
@@ -1,40 +0,0 @@-{-# 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-import Prelude hiding (null)-import qualified Data.List as L---- | 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)-	null (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 L.null vs then m' else IM.insert k vs m'))) (IM.minViewWithKey m)-	null (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/Numeric.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE MagicHash #-}--module Data.Queue.Numeric where--import GHC.Exts--intLog :: Int -> Int-intLog 0 = 0-intLog 1 = 0-intLog (I# x) = I# (word2Int# (intLog1 (int2Word# x))) where-	zeroq x = x `eqWord#` int2Word# 0#-	intLog1 x = let ans = uncheckedShiftRL# x 16# in if zeroq ans then intLog2 x else int2Word# 16# `or#` intLog2 ans-	intLog2 x = let ans = uncheckedShiftRL# x 8# in if zeroq ans then intLog3 x else int2Word# 8# `or#` intLog3 ans-	intLog3 x = let ans = uncheckedShiftRL# x 4# in if zeroq ans then intLog4 x else int2Word# 4# `or#` intLog4 ans-	intLog4 x = let ans = uncheckedShiftRL# x 2# in if zeroq ans then intLog5 x else int2Word# 2# `or#` intLog5 ans-	intLog5 x = if x `leWord#` int2Word# 1# then int2Word# 0# else int2Word# 1#--ceilLog :: Int -> Int-ceilLog x = intLog (2 * x - 1)
Data/Queue/PQueue.hs view
@@ -1,53 +1,60 @@-{-# LANGUAGE NamedFieldPuns, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} {-# OPTIONS -fno-warn-missing-methods -fno-warn-name-shadowing #-} {- | An efficient implementation of a priority queue.  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, drawQueue) where --, IQueue(..), QueueKey(..)) where  import Data.Queue.Class import Data.Queue.QueueHelpers +import qualified Data.Tree as T+	 import Data.Maybe import Data.Monoid  import Control.Monad --- 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.+-- The real meat of the pairing heap is the merge operation, and in the "balanced" merging of subtrees.  This balancing idea is sufficiently general that it's implemented in QueueHelpers, to be automatically inferred from a monoid instance, and a perfectly correct implementation falls out almost immediately.  data Tree e = T e [Tree e] newtype PQueue e = PQ (HeapQ (Tree e)) deriving (Monoid) +drawQueue :: Show e => PQueue e -> String+drawQueue (PQ (HQ _ t)) = maybe "" (T.drawTree . fmap show . T.unfoldTree (\ (T x ts) -> (x, ts))) t+ instance Ord e => Monoid (Tree e) where 	-- no actual mzero instance, but induces a correct Monoid instance for Heap e-	t1@(T x1 ts1) `mappend` t2@(T x2 ts2) +	t1@(T x1 ts1) `mappend` t2@(T x2 ts2) 		| x1 <= x2	= T x1 (t2:ts1) 		| otherwise	= T x2 (t1:ts2) -instance Ord e => Queuelike (PQueue e) where+instance Ord e => IQueue (PQueue e) where 	{-# INLINE toList_ #-} 	{-# INLINE mergeAll #-} 	{-# INLINE insertAll #-}  	type QueueKey (PQueue e) = e -	empty = PQ mempty+	empty = mempty 	singleton = PQ . single-	fromList xs = PQ $ fuseMerge $ map single xs+	fromList xs = PQ $ fuseMergeM [single x | x <- xs] -	x `insert` q = q `mappend` PQ (single x) 	xs `insertAll` q = q `mappend` fromList xs 	merge = mappend-	mergeAll = mconcat+	mergeAll qs = PQ (fuseMergeM [h | PQ h <- qs]) -	extract (PQ (HQ n t)) = fmap (\ (T x ts) ->  (x, PQ (HQ (n-1) (fusing ts)))) t+	extract (PQ (HQ n t)) = fmap (fmap (PQ . HQ (n-1)) . extract') t+		where	extract' (T x ts) = (x, fusing ts) 	toList_ (PQ (HQ _ t)) = maybe [] flatten t+		where	flatten (T x ts) = x:concatMap flatten ts 	size (PQ (HQ n _)) = n  single :: e -> HeapQ (Tree e) single x = HQ 1 $ Just (T x []) -flatten :: Tree e -> [e]-flatten (T x ts) = [x] ++ concatMap flatten ts+{-# RULES+-- 	"singleton/PQueue" forall (x :: Ord e => e) . singleton x = PQ (single x);+	#-}
Data/Queue/Queue.hs view
@@ -1,36 +1,33 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} {-# OPTIONS -fno-warn-name-shadowing #-} --- | A basic first-in, first-out queue implementation implementing the 'Queuelike' abstraction.+-- | A basic first-in, first-out queue implementation implementing the 'Queuelike' abstraction.  Bootstrapped from "Data.Sequence". module Data.Queue.Queue (Queue) where -import Data.Maybe-import Data.Queue.Class import Data.Monoid+import Data.Queue.Class+import Data.Sequence (Seq, ViewL (..), viewl, (|>))+import qualified Data.Sequence as Seq+import qualified Data.Foldable as Fold import Prelude hiding (null) -data Queue e = Queue {-# UNPACK #-} !Int [e] [e] [e]+newtype Queue e = Queue (Seq e) deriving (Monoid, Fold.Foldable, Functor) -instance Queuelike (Queue e) where+instance IQueue (Queue e) where 	type QueueKey (Queue e) = e-	singleton x = Queue 1 [x] [] [x]-	empty = Queue 0 [] [] []-	null = (==0) . size-	size (Queue n _ _ _) = n-	x `insert` Queue n l r a = mkQ (Queue (n+1) l (x:r) a)-	peek (Queue _ l _ _) = listToMaybe l-	delete (Queue (n+1) (_:l) r a) = Just (mkQ (Queue n l r a))-	delete _ = Nothing-	q `merge` Queue n l r a = insertAll r (insertAll (reverse r) q)+	empty = mempty+	singleton = Queue . Seq.singleton+	fromList = Queue . Seq.fromList+	+	null (Queue q) = Seq.null q+	size (Queue q) = Seq.length q -mkQ :: Queue e -> Queue e-mkQ (Queue n l r (_:as)) = Queue n l r as-mkQ (Queue n ll rr []) = let	rot ls ~(r:rs) a = case ls of-					[]	-> r:a-					(l:ls)	-> l:rot ls rs (r:a)-				l' = rot ll rr [] in Queue n l' [] l'+	x `insert` Queue q = Queue (q |> x)+	extract (Queue q) = case viewl q of+		EmptyL	-> Nothing+		x :< q'	-> Just (x, Queue q') -instance Monoid (Queue e) where-	mempty = empty-	mappend = merge+	merge = mappend+	mergeAll = mconcat++	toList = Fold.toList
Data/Queue/QueueHelpers.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -fno-warn-name-shadowing #-}  {------------------@@ -17,9 +17,10 @@ 	mergeAll = mconcat 	... +In particular, this almost immediately yields a correct pairing heap implementation (cf. PQueue) -------------------} -module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, endoMaybe, order, fusing, fuseMerge) where+module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, endoMaybe, order, fusing, fuseMerge, fuseMergeM, on) where  import Data.Monoid import Data.Maybe@@ -35,21 +36,34 @@ 	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 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+endoMaybe _ ma mb		= maybe mb Just ma  {-# 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+		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]+		fuser' ts		= ts 	in meld `seq` fuser  {-@@ -68,12 +82,13 @@  data IntAcc e = IA {-# UNPACK #-} !Int e -{-# INLINE fuseMerge #-}+{-# INLINE [2] 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)) +{-# 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@@ -83,5 +98,5 @@ {-# RULES 	"[] ++" forall l . [] ++ l = l; 	"++ []" forall l . l ++ [] = l;-	"fuseMerge/HeapQ" forall (qs :: Monoid m => [HeapQ m]) . fuseMerge qs = fuseMergeM qs;+	"fuseMerge/HeapQ" forall (qs :: Monoid m => [MonoidQ (Maybe m)]) . fuseMerge qs = fuseMergeM qs; 	#-}
− Data/Queue/SkewQueue.hs 
@@ -1,46 +0,0 @@-{-# 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.  Moderately less lazy than "Data.Queue.PQueue".--}-module Data.Queue.SkewQueue (SkewQueue) where--import Data.Queue.Class-import Data.Queue.QueueHelpers--import GHC.Exts--import Data.Monoid-import Data.Ord---- 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)--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-		in meld--instance Ord e => Queuelike (SkewQueue e) where-	{-# INLINE mergeAll #-}-	type QueueKey (SkewQueue e) = e--	empty = mempty-	singleton = SQ . single-	fromList xs = SQ $ fuseMerge (map single xs)--	merge = mappend-	mergeAll = mconcat--	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)--flatten :: Maybe (BTree e) -> [e]-flatten h = build (flattenFB h) where-	flattenFB h c n = maybe n (\ (Tr x l r) -> x `c` flattenFB l c (flattenFB r c n)) h
− Data/Queue/SoftHeap.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE PatternGuards, TypeFamilies, NamedFieldPuns, ViewPatterns, RecordWildCards #-}-{-# OPTIONS -fno-warn-overlapping-patterns #-}---- | A soft heap is a comparison-based priority queue that provides amortized constant-time performance for every one of its operations by /corrupting/ at most a fixed percentage (by default, 1/128) of keys, possibly increasing them.  At this time, that means that not every element put in will come out again -- instead, a duplicate of a greater key might be returned.  This is a highly experimental implementation.------ * The author believes that every element that goes in can be returned, just possibly not in the correct order (but this will happen for at most an epsilon proportion)------ * The author believes that a truly functional implementation with the same time performance isn't possible; part of this implementation uses "Data.Sequence".  As a result, every operation takes @O(log log n)@ amortized time in this implementation, with a very low constant factor.------ * This implementation is based on the one described in /H. Kaplan, U. Zwick: A simpler implementation and analysis of Chazelle's soft heaps. In Proceedings of the Nineteenth Annual ACM -SIAM Symposium on Discrete Algorithms, 2009, 477-485/.------ * An IO-backed implementation supporting true amortized constant-time operations is in progress.-module Data.Queue.SoftHeap (SoftHeap, empty', singleton', fromList') where---- import Debug.Trace--import Data.Queue.Class-import Data.Queue.Numeric--import Data.Sequence (Seq, viewl, (<|), ViewL(..), ViewR(..))-import qualified Data.Sequence as Seq-import qualified Data.Foldable as Fold--- import Data.Queue.QueueHelpers--import Data.Ord-import Data.Ratio-import Data.Maybe-import Control.Monad-import Control.Arrow(second)--import Control.Monad.Instances-import Data.Tree hiding (subForest)--data SNode e = SN {ckey :: e, rk, targetSize :: {-# UNPACK #-} !Int, list :: [e], left, right :: Maybe (SNode e)} deriving (Show)-data SHead e = SHead {sHeap :: {-# UNPACK #-} !(SNode e), myIx, sufMin :: {-# UNPACK #-} !Int} deriving (Show) -- TODO: rearrange sufMin for the functional context-type SHeapList e = Seq (SHead e)-data SoftHeap e = SQ {elts, rank, rConst :: {-# UNPACK #-} !Int, heads :: SHeapList e}--- TODO: list will always be nonempty; exploit this.  (Also, use a Seq so that length runs faster.)--- TODO: Bootstrap via QueueHelpers.  Necessary modifications minimal.  Srsly.--toTree :: SNode e -> Tree (e, Int, [e])-toTree SN{..} = Node (ckey, rk, list) [toTree n | Just n <- [left, right]]--toForest :: SoftHeap e -> Forest (e, Int, [e])-toForest = map (toTree . sHeap) . Fold.toList . heads--drawHeap :: Show e => SoftHeap e -> String-drawHeap = drawForest . map (fmap show) . toForest--defaultRank :: Int-defaultRank = 12--fromEpsilon :: RealFrac b => b -> Int-fromEpsilon x-	= let (a, b) = asFraction (toPrecision x) in ceilLog (fromIntegral b) - intLog (fromIntegral a) + 5-	where	precision = fromRational (1 % 100000)-		toPrecision x = x `approxRational` (precision `min` (x / 2))-		asFraction = liftM2 (,) numerator denominator--empty' :: (Ord e, RealFrac b) => b -> SoftHeap e-empty' epsilon = SQ 0 0 (fromEpsilon epsilon) Seq.empty--singleton' :: (Ord e, RealFrac b) => b -> e -> SoftHeap e-singleton' epsilon x = SQ 1 0 (fromEpsilon epsilon) (Seq.singleton (SHead (single x) 0 0))--fromList' :: (Ord e, RealFrac b) => b -> [e] -> SoftHeap e-fromList' epsilon xs = insertAll xs (empty' epsilon)--instance (Ord e) => Queuelike (SoftHeap e) where-	type QueueKey (SoftHeap e) = e-	empty = SQ 0 0 defaultRank Seq.empty-	singleton x = SQ 1 0 defaultRank (Seq.singleton (SHead (single x) 0 0))-	-	merge = meld-	extract = deleteMin-	size = elts--minWith :: Ord b => (a -> b) -> a -> a -> a-minWith f x y	| f x <= f y	= x-		| otherwise	= y--orderPairWith :: Ord b => (a -> b) -> (a, a) -> (a, a)-orderPairWith f (x, y)	| f x <= f y	= (x, y)-			| otherwise	= (y, x)--isLeaf :: SNode e -> Bool-isLeaf SN{..} = not (isJust left || isJust right)--sift :: Ord e => SNode e -> SNode e-sift x@SN{left, right, targetSize}-	| length (list x) >= targetSize || isLeaf x-		= x-	| (l', r') <- swapKids left right-		= let ckey' = case list x of-			[]	-> ckey l'-			_	-> ckey x `max` ckey l'-			in ckey' `seq` sift x{ckey = ckey', list = list x ++ list l', -				left = if isLeaf l' then Nothing else Just (sift l'{list = []}), right = r'}-	where	swapKids (Just l) (Just r) = let (l', r') = orderPairWith ckey (l, r) in (l', Just r')-		swapKids (Just l) r = (l, r)-		swapKids _ (Just r) = (r, Nothing)--combine :: Ord e => Int -> SNode e -> SNode e -> SNode e-combine r x@SN{rk,targetSize} y = sift $ SN undefined (rk + 1) (if rk < r then 1 else (3 * targetSize + 1) `quot` 2) [] (Just x) (Just y)--consHead :: Ord e => SNode e -> SHeapList e -> SHeapList e-consHead x hs = case viewl hs of-	EmptyL	-> SHead x 0 0 <| hs-	(SHead{sufMin} :< _) | n <- Seq.length hs, SHead{sHeap = sMin} <- Seq.index hs (n - 1 - sufMin)-		-> SHead x n (if ckey x <= ckey sMin then n else sufMin) <| hs--single :: Ord e => e -> SNode e-single x = SN x 0 1 [x] Nothing Nothing--rkHead :: SHead e -> Int-rkHead = rk . sHeap--meld :: (Ord e) => SoftHeap e -> SoftHeap e -> SoftHeap e-SQ n1 rk1 r1 p `meld` SQ n2 rk2 r2 q = case viewl (p `mergeRanks` q) of-	EmptyL	-> SQ 0 0 r Seq.empty-	(SHead h _ _ :< hs) | (rk, heads) <- compare (ckey h) (ckey h) `seq` rebuild h hs-		-> SQ (n1 + n2) (rk `max` rk1 `max` rk2) r heads-	where	r = r1 `max` r2-		rkMin = rk1 `min` rk2-		ps `mergeRanks` qs = case (viewl ps, viewl qs) of-			(p :< ps', q :< qs')-				| rkHead p <= rkHead q	-> p <| mergeRanks ps' qs-				| otherwise		-> q <| mergeRanks ps qs'-			(EmptyL, _)	-> qs-			(_, EmptyL)	-> ps--- 		rebuild q qs | traceShow (q, qs) False = undefined-		rebuild q@SN{rk = rk0} qs@(viewl -> SHead{sHeap = q1} :< qs1)-			| rk0 == rk q1-				= case viewl qs1 of-						(SHead{sHeap = q2} :< qs2)-							| rk0 == rk q2	-> fmap (q `consHead`) $ rebuild (combine r q1 q2) qs2-						_			-> rebuild (combine r q q1) qs1--- 			| rk0 > rkMin--- 				= (rk0, q `consHead` qs)-			| otherwise-				= fmap (q `consHead`) $ rebuild q1 qs1-		rebuild q qs-			= (rk q, q `consHead` Seq.empty)--headKey :: SHead e -> e-headKey = ckey . sHeap--fixSufMins :: Ord e => Int -> SHeapList e -> SHeapList e-fixSufMins i sequ@(Seq.splitAt i -> (seqL, seqR))-	= Fold.foldr (consHead . sHeap) seqR seqL--deleteMin :: Ord e => SoftHeap e -> Maybe (e, SoftHeap e)-deleteMin q@SQ{elts, rConst = r, heads = heads@(viewl -> SHead{sufMin} :< _)} -	| n <- Seq.length heads, t@(headKey -> minKey) <- Seq.index heads (n - 1 - sufMin)-		= Just (minKey, q{elts = elts - 1, heads = deleteMin' (n - 1 - sufMin) t heads})-	where	deleteMin' :: Ord e => Int -> SHead e -> SHeapList e -> SHeapList e-		deleteMin' sufMin t@SHead{sHeap = h@SN{ckey, targetSize, list = _:l'}} heads-			| 2 * length l' <= targetSize, not (isLeaf h), h' <- sift h{list = l'}-				= case list h' of-					[]	-> let (lHeads, viewl -> _ :< rHeads) = Seq.splitAt sufMin heads in-							Fold.foldr (consHead . sHeap) rHeads lHeads-					_	-> Seq.update sufMin t{sHeap = h'} heads-			| [] <- l', (lHeads, viewl -> _ :< rHeads) <- Seq.splitAt sufMin heads-				= Fold.foldr (consHead . sHeap) rHeads lHeads-			| otherwise-				= Seq.update sufMin t{sHeap = h{list = l'}} heads-deleteMin _ = Nothing
Data/Queue/Stack.hs view
@@ -3,26 +3,19 @@ -- | A basic implementation of a stack implementing the 'Queue' abstraction. module Data.Queue.Stack (Stack) where -import Data.Monoid import Data.Queue.Class-import Data.Queue.QueueHelpers import Data.Maybe -newtype Stk e = Stk [e]-newtype Stack e = S (MonoidQ (Stk e)) deriving (Monoid)--instance Monoid (Stk e) where-	mempty = Stk []-	Stk s1 `mappend` Stk s2 = Stk (reverse s2 ++ s1)+data Stack e = S {elts :: {-# UNPACK #-} !Int, stk :: [e]} -instance Queuelike (Stack e) where+instance IQueue (Stack e) where 	type QueueKey (Stack e) = e-	empty = mempty-	merge = mappend-	insert x (S (HQ n (Stk xs))) = S (HQ (n+1) (Stk (x:xs)))+	empty = S 0 []+	insert x (S n stk) = S (n+1) (x:stk) -	singleton x = S (HQ 1 (Stk [x]))-	extract (S (HQ (n+1) (Stk (x:xs)))) = Just (x, S (HQ n (Stk xs)))+	S n1 s1 `merge` S n2 s2 = S (n1 + n2) (reverse s2 ++ s1)++	extract (S (n+1) (x:xs)) = Just (x, S n xs) 	extract _ = Nothing-	size (S HQ{elts}) = elts-	toList (S HQ{heap = Stk xs}) = xs+	size = elts+	toList = stk
queuelike.cabal view
@@ -1,6 +1,5 @@- name:		queuelike-version:	1.0.0+version:	1.0.1 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. tested-with:	GHC@@ -20,16 +19,16 @@ 	Data.Queue.Instances 	Data.Queue.Stack 	Data.Queue.Queue-	Data.Queue.SkewQueue-	Data.Queue.SoftHeap-	Data.Queue.IntQueue+--	Data.Queue.SkewQueue+--	Data.Queue.SoftHeap+--	Data.Queue.IntQueue 	Data.MQueue.Class 	Data.MQueue.Heap 	Data.MQueue.SyncQueue-	Data.MQueue.ChanQ+	Data.MQueue.Chan 	Data.MQueue other-modules:  	Data.Queue.QueueHelpers 	Data.MQueue.MonadHelpers-	Data.Queue.Numeric+--	Data.Queue.Numeric ghc-options: