packages feed

queuelike (empty) → 1.0.0

raw patch · 20 files changed

+869/−0 lines, 20 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, mtl, stateful-mtl, utility-ht

Files

+ Data/MQueue.hs view
@@ -0,0 +1,5 @@+module Data.MQueue (module Data.MQueue.Class, module Data.MQueue.Heap, module Data.MQueue.SyncQueue) where++import Data.MQueue.Class+import Data.MQueue.Heap+import Data.MQueue.SyncQueue
+ Data/MQueue/ChanQ.hs view
@@ -0,0 +1,47 @@+{-# 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
@@ -0,0 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}++module Data.MQueue.Class where++import Data.MQueue.MonadHelpers++-- import Control.Monad.Maybe+import Control.Monad.Trans++import Control.Monad+import Data.Maybe++class Monad m => MQueue q m where+	type MQueueKey q :: *+	newQueue :: m q+	push :: q -> MQueueKey q -> m ()+	pushAll :: q -> [MQueueKey q] -> m ()+	pop :: q -> m (Maybe (MQueueKey q))+	pop_ :: q -> m ()+	peek :: q -> m (Maybe (MQueueKey q))+	isEmpty :: q -> m Bool+-- 	getSize :: q -> m Int+	-- combine :: q -> q -> m ()++	{-# INLINE pushAll #-}+	pushAll = mapM_ . push++	pop q = peek q >>= maybe (return Nothing) (\ key -> pop_ q >> return (Just key))+	pop_ q = pop q >> return ()+	+	isEmpty = liftM isNothing . peek
+ Data/MQueue/Heap.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, BangPatterns, NamedFieldPuns, RecordWildCards #-}++-- | Array-based implementation of an entirely traditional binary heap.+module Data.MQueue.Heap (Heap, getSize) where++import Data.MQueue.Class+import Data.MQueue.MonadHelpers++import Control.Monad.ST.Class+import Data.Tuple.HT++import Data.Array.Base++import Data.Array.ST+import Data.STRef+import Control.Monad.ST+import Control.Monad+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)}++instance (Monad m, MonadST m, StateThread m ~ s, Ord e) => MQueue (Heap s e) m where+	{-# SPECIALIZE instance Ord e => MQueue (Heap s e) (ST s) #-}+	{-# SPECIALIZE instance Ord e => MQueue (Heap RealWorld e) IO #-}+	{-# INLINE pushAll #-}+	type MQueueKey (Heap s e) = e+	newQueue = liftST newHeap+	push h = liftST . pushHeap h+	pushAll h = liftST . pushAllHeap h+	pop_  = liftST . popHeap_+	peek = liftST . peekHeap++{-# SPECIALIZE getSize :: Heap s e -> ST s Int #-}+getSize :: (Monad m, MonadST m, StateThread m ~ s) => Heap s e -> m Int+getSize = liftST . getHeapSize++----------------------------------------------------------------------++{-# INLINE pushAllHeap #-}+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))+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)++----------------------------------------------------------------------++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 (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 a) -> ST s ()+modSTRef_ ref f = readSTRef ref >>= f >>= writeSTRef ref++ensureSize :: Int -> STHeap s e -> ST s (STHeap s e)+ensureSize n h@STH{..} = do	cap <- getNumElements arr+				if cap < n then do	arr' <- newArray_ (0, 5 * n `quot` 4 - 1)+							mapM_ (liftM2 (>>=) (unsafeRead arr) (unsafeWrite arr')) [0..size-1]+							return h{arr = arr'}+					else return h++heapUp :: Ord e => STArray s Int e -> Int -> e -> ST s ()+heapUp !arr i ai = heapUp' i where+	heapUp' 0 = unsafeWrite arr 0 ai+	heapUp' i = let !j = (i - 1) `quot` 2 in do+		aj <- unsafeRead arr j+		if aj < ai then unsafeWrite arr i ai else unsafeWrite arr i aj >> heapUp' j++unsafePusher :: Ord e => e -> STHeap s e -> ST s (STHeap s e)+unsafePusher k h@STH{..} = do	heapUp arr size k+				return h{size = size + 1}++pusher :: Ord e => e -> STHeap s e -> ST s (STHeap s e)+pusher k h@STH{size} = ensureSize (size+1) h >>= unsafePusher k++heapDown :: Ord e => Int -> STArray s Int e -> Int -> e -> ST s ()+heapDown n !arr i ai = lt `seq` heapDown' i where+	lt = (<) -- hack to minimize polymorphism overhead+	heapDown' i = let rchild = 2 * i + 2; lchild = rchild - 1 in case compare rchild n of+		LT	-> do	al <- unsafeRead arr lchild+				ar <- unsafeRead arr rchild+				let (ach, ch) = if al < ar then (al, lchild) else (ar, rchild)+				if ach `lt` ai then unsafeWrite arr i ach >> heapDown' ch+					else unsafeWrite arr i ai+		EQ	-> do	al <- unsafeRead arr lchild+				if al `lt` ai then unsafeWrite arr i al >> unsafeWrite arr lchild ai+					else unsafeWrite arr i ai+		GT	-> unsafeWrite arr i ai++popper :: Ord e => STHeap s e -> ST s (STHeap s e)+popper h@STH{..} = let s' = size - 1 in do+	ai <- unsafeRead arr s'+	unsafeWrite arr s' undefined+	heapDown s' arr 0 ai+	return h{size = s'}
+ Data/MQueue/MonadHelpers.hs view
@@ -0,0 +1,15 @@+module Data.MQueue.MonadHelpers where++import Data.Function++with :: Monad m => m a -> (a -> m b) -> m a+with m f = do	ans <- m+		f ans+		return ans++when_ :: Monad m => Bool -> m a -> m ()+when_ True act = act >> return ()+when_ False _ = return ()++whileM :: Monad m => m Bool -> m a -> m ()+whileM cond act = fix (\ action -> cond >>= flip when_ (act >> action))
+ Data/MQueue/SyncQueue.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}++-- | 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 qualified Data.Queue.Class as Q+import Data.MQueue.Class++import Data.Tuple.HT+import Control.Arrow++import Control.Concurrent.MVar+import Control.Monad.Trans++import Control.Monad+import Data.Maybe++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 #-}+	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+	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 f (SyncQ var) = liftIO $ withMVar var (return . f)++instance (MonadIO m, MQueue q IO) =>  MQueue (SyncMQ q) m where+	{-# SPECIALIZE instance MQueue q IO => MQueue (SyncMQ q) IO #-}+	type MQueueKey (SyncMQ q) = MQueueKey q+	newQueue = liftIO $ liftM SyncMQ $ newQueue >>= newMVar+	q `push` k = onSyncMQ (`push` k) q+	q `pushAll` ks = onSyncMQ (`pushAll` ks) q+	peek = onSyncMQ peek+	pop = onSyncMQ pop+	pop_ = onSyncMQ pop_+-- 	getSize = onSyncMQ getSize+	isEmpty = onSyncMQ isEmpty++{-# INLINE onSyncMQ #-}+onSyncMQ :: (MonadIO m, MQueue q IO) => (q -> IO a) -> SyncMQ q -> m a+onSyncMQ f (SyncMQ var) = liftIO $ withMVar var f++-- let ext = extract q in return (maybe q snd ext, fmap snd ext)
+ Data/Queue.hs view
@@ -0,0 +1,4 @@+module Data.Queue (module Data.Queue.Instances, module Data.Queue.Class) where++import Data.Queue.Instances+import Data.Queue.Class
+ Data/Queue/Class.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, TypeFamilies #-}++-- | Abstracts the implementation details of a single-insertion, single-extraction queuelike structure.+module Data.Queue.Class where++import Data.List(unfoldr)+import Data.Maybe++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+	type QueueKey q+	-- | Inserts a single element into the queue.  The default implementation uses 'merge' and 'singleton'.+	insert :: QueueKey q -> q -> q+	insert x q = q `merge` singleton x+	-- | Inserts several elements into the queue.  The default implementation uses 'insert'.  (In some cases, it may be advantageous to override this implementation with @xs \``insertAll`\` q = q \``merge`\` `fromList` xs@.)+	{-# INLINE insertAll #-}+	insertAll :: [QueueKey q] -> q -> q+	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+	-- | 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+	-- | Deletes an element from the queue, if the queue is nonempty.  The default implementation uses 'extract'.+	delete :: q -> Maybe q+	delete = liftM snd . extract+	-- | Constructs an empty queue.  The default implementation uses 'fromList'.+	empty :: q+	empty = fromList []+	-- | Constructs a queue with a single element.  The default implementation uses 'insert' and 'empty'.+	singleton :: QueueKey q -> q+	singleton x = insert x empty+	-- | Constructs a queue with all of the elements in the list.  The default implementation uses 'insertAll' and 'empty'.+	{-# INLINE fromList #-}+	fromList :: [QueueKey q] -> q+	fromList xs = insertAll xs empty+	-- | Gets the size of the queue.  The default implementation uses 'toList_'.+	size :: q -> Int+	size = length . toList_+	-- | Checks if the queue is empty.  The default implementation uses 'peek'.+	null :: q -> Bool+	null = isNothing . peek+	-- | Extracts every element from the queue.  The default implementation uses 'extract'.+	toList :: q -> [QueueKey q]+	toList = unfoldr extract+	-- | Extracts every element from the queue, with no guarantees upon order.  The default implementation uses 'toList'.+	toList_ :: q -> [QueueKey q]+	toList_ = toList+	-- | Merges two queues so that the contents of the second queue are inserted into the first queue in extraction order.  The default implementation uses 'toList' and 'insertAll'.+	{-# INLINE merge #-}+	merge :: q -> q -> q+	q1 `merge` q2 = insertAll (toList q2) q1+	mergeAll :: [q] -> q+	mergeAll = foldr merge empty
+ Data/Queue/Instances.hs view
@@ -0,0 +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++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.IntQueue+import Data.Queue.SoftHeap
+ Data/Queue/IntQueue.hs view
@@ -0,0 +1,40 @@+{-# 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 view
@@ -0,0 +1,19 @@+{-# 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
@@ -0,0 +1,53 @@+{-# LANGUAGE NamedFieldPuns, TypeSynonymInstances, FlexibleInstances, 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++import Data.Queue.Class+import Data.Queue.QueueHelpers++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.++data Tree e = T e [Tree e]+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+	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+	{-# INLINE toList_ #-}+	{-# INLINE mergeAll #-}+	{-# INLINE insertAll #-}++	type QueueKey (PQueue e) = e++	empty = PQ mempty+	singleton = PQ . single+	fromList xs = PQ $ fuseMerge $ map single xs++	x `insert` q = q `mappend` PQ (single x)+	xs `insertAll` q = q `mappend` fromList xs+	merge = mappend+	mergeAll = mconcat++	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 [])++flatten :: Tree e -> [e]+flatten (T x ts) = [x] ++ concatMap flatten ts
+ Data/Queue/Queue.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++-- | A basic first-in, first-out queue implementation implementing the 'Queuelike' abstraction.+module Data.Queue.Queue (Queue) where++import Data.Maybe+import Data.Queue.Class+import Data.Monoid+import Prelude hiding (null)++data Queue e = Queue {-# UNPACK #-} !Int [e] [e] [e]++instance Queuelike (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)++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'++instance Monoid (Queue e) where+	mempty = empty+	mappend = merge
+ Data/Queue/QueueHelpers.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts, BangPatterns #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++{------------------++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+	...++-------------------}++module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, endoMaybe, order, fusing, fuseMerge) where++import Data.Monoid+import Data.Maybe++data MonoidQ m = HQ {elts :: {-# UNPACK #-} !Int, heap :: m}+type HeapQ m = MonoidQ (Maybe 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 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++{-# 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 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)+order cmp x y	| cmp x y == GT	= (y, x)+		| otherwise	= (x, y)++data IntAcc e = IA {-# UNPACK #-} !Int e++{-# INLINE 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))++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)++{-# RULES+	"[] ++" forall l . [] ++ l = l;+	"++ []" forall l . l ++ [] = l;+	"fuseMerge/HeapQ" forall (qs :: Monoid m => [HeapQ m]) . fuseMerge qs = fuseMergeM qs;+	#-}
+ Data/Queue/SkewQueue.hs view
@@ -0,0 +1,46 @@+{-# 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 view
@@ -0,0 +1,167 @@+{-# 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
@@ -0,0 +1,28 @@+{-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving, TypeFamilies #-}++-- | 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)++instance Queuelike (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)))++	singleton x = S (HQ 1 (Stk [x]))+	extract (S (HQ (n+1) (Stk (x:xs)))) = Just (x, S (HQ n (Stk xs)))+	extract _ = Nothing+	size (S HQ{elts}) = elts+	toList (S HQ{heap = Stk xs}) = xs
+ LICENSE view
@@ -0,0 +1,16 @@+Copyright (c) 2008, Louis Wasserman+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution.+    * The name of Louis Wasserman may not be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY +OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ queuelike.cabal view
@@ -0,0 +1,35 @@++name:		queuelike+version:	1.0.0+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+category:	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, containers, mtl, array, stateful-mtl >= 1.0.7, utility-ht+build-type:	Simple+Exposed-modules:+	Data.Queue+	Data.Queue.PQueue+	Data.Queue.Class+	Data.Queue.Instances+	Data.Queue.Stack+	Data.Queue.Queue+	Data.Queue.SkewQueue+	Data.Queue.SoftHeap+	Data.Queue.IntQueue+	Data.MQueue.Class+	Data.MQueue.Heap+	Data.MQueue.SyncQueue+	Data.MQueue.ChanQ+	Data.MQueue+other-modules: +	Data.Queue.QueueHelpers+	Data.MQueue.MonadHelpers+	Data.Queue.Numeric+ghc-options: