packages feed

pqueue-mtl 1.0.2 → 1.0.3

raw patch · 4 files changed

+68/−58 lines, 4 filesdep ~stateful-mtl

Dependency ranges changed: stateful-mtl

Files

Control/Monad/Queue/Heap.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-} -module Control.Monad.Queue.Heap (HeapM, HeapT, runHeapM, runHeapMIO, runHeapT) where+module Control.Monad.Queue.Heap (HeapM, HeapT, runHeapM, runHeapMOn, runHeapT, runHeapTOn) where  import Control.Monad.ST import Control.Monad.ST.Class@@ -14,14 +14,14 @@ import Control.Monad  -- | Monad based on an array implementation of a standard binary heap.-type HeapM s e = HeapT s e (ST s)+type HeapM s e = HeapT e (ST s) -- | Monad transformer based on an array implementation of a standard binary heap.-newtype HeapT s e m a = HeapT {execHeapT :: StateT Int (ArrayT s e m) a} deriving (Monad, MonadST s, MonadFix, MonadReader r, MonadWriter w)+newtype HeapT e m a = HeapT {execHeapT :: StateT Int (ArrayT e m) a} deriving (Monad, MonadPlus, MonadFix, MonadReader r, MonadWriter w) -instance MonadTrans (HeapT s e) where+instance MonadTrans (HeapT e) where 	lift = HeapT . lift . lift -instance (MonadST s m, MonadState t m) => MonadState t (HeapT s e m) where+instance MonadState s m => MonadState s (HeapT e m) where 	get = lift get 	put = lift . put @@ -29,20 +29,27 @@ runHeapM :: Ord e => (forall s . HeapM s e a) -> a runHeapM m = runST $ runHeapT m -runHeapMIO :: Ord e => HeapM RealWorld e a -> IO a-runHeapMIO m = stToIO $ runHeapT m+runHeapMOn :: Ord e => (forall s . HeapM s e a) -> Int -> [e] -> a+runHeapMOn m n l = runST $ runHeapTOn m n l -runHeapT :: (MonadST s m, Monad m) => HeapT s e m a -> m a+-- runHeapMIO :: Ord e => HeapM RealWorld e a -> IO a+-- runHeapMIO m = stToIO $ runHeapT m+-- +-- runHeapMOnIO :: Ord e => HeapM RealWorld e a -> Int -> [e] -> IO a+-- runHeapMOnIO m n l = stToIO $ runHeapTOn m n l++runHeapT :: (MonadST m, Monad m) => HeapT e m a -> m a runHeapT m = runArrayT_ 16 (evalStateT (execHeapT 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 :: (Ord e) => (forall s . HeapM s e a) -- ^ The transformer operation.--- 				-> Int -- ^ The starting size of the heap (must be equal to the length of the list)--- 				-> [e] -- ^ The initial contents of the heap--- 				-> a--- runHeapTOn m n l = runArrayM_ 16 $ flip evalStateT n $ do	mapM_ (uncurry unsafeWriteAt) (zip [0..] l)--- 								mapM_ (\ i -> unsafeReadAt i >>= heapDown n i) [0..n-1]--- 								execHeapM m+runHeapTOn :: (MonadST m, Monad m, Ord e) => +				HeapT e m a -- ^ The transformer operation.+ 				-> Int -- ^ The starting size of the heap (must be equal to the length of the list)+ 				-> [e] -- ^ The initial contents of the heap+ 				-> m a+runHeapTOn m n l = runArrayT_ n $ flip evalStateT n $ do	mapM_ (uncurry unsafeWriteAt) (zip [0..n-1] l)+								mapM_ (\ i -> unsafeReadAt i >>= heapDown n i) [0..n-1]+								execHeapT m  ensureHeap :: MonadArray e m => Int -> m () ensureHeap n = do	cap <- getSize@@ -66,7 +73,7 @@ 					if al < x then unsafeWriteAt i al >> unsafeWriteAt lch x else unsafeWriteAt i x 			GT	-> unsafeWriteAt i x -instance (MonadST s m, Monad m, Ord e) => MonadQueue e (HeapT s e m) where+instance (MonadST m, Monad m, Ord e) => MonadQueue e (HeapT e m) where 	queuePeek = HeapT $ do	 		size <- get 		if size > 0 then liftM Just (unsafeReadAt 0) else return Nothing
Control/Monad/Queue/QueueT.hs view
@@ -16,7 +16,7 @@ import Data.Maybe  -- | A monad transformer granting the underlying monad @m@ access to single-threaded actions on a queue.-newtype QueueT q m a = QueueT {runQT :: StateT q m a} deriving (MonadReader r, MonadWriter w, MonadIO, MonadST s, MonadFix, Monad, MonadTrans)+newtype QueueT q m a = QueueT {runQT :: StateT q m a} deriving (MonadReader r, MonadWriter w, MonadIO, MonadFix, Monad, MonadTrans) -- | A monad controlling single-threaded access to a queue. newtype QueueM q a = QueueM {runQM :: State q a} deriving (MonadFix, Monad) type PQueueT e = QueueT (PQueue e)@@ -48,6 +48,7 @@ 	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue e (PQueueT e m) #-} 	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue e (FibQueueT e m) #-} 	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)) 	queueEmpty = QueueT $ gets isEmpty 	queueDelete  = QueueT $ modify (\ q -> fromMaybe empty (delete q))@@ -58,6 +59,7 @@ 	{-# SPECIALIZE instance Ord e => MonadQueue e (PQueueM e) #-} 	{-# SPECIALIZE instance Ord e => MonadQueue e (FibQueueM e) #-} 	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)) 	queueEmpty = QueueM $ gets isEmpty 	queueDelete  = QueueM $ modify (\ q -> fromMaybe empty (delete q))
Data/Queue/PQueue.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}-{-# OPTIONS -fno-warn-missing-methods #-}+{-# LANGUAGE BangPatterns, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} {- | 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.@@ -14,49 +13,52 @@ import Data.Queue.Class import GHC.Exts -data PHeap e = PH {elts :: {-# UNPACK #-} !Int, heap :: {-# UNPACK #-} !(Tree e)} deriving (Read, Show)-newtype PQueue e = PQ {getQ :: Maybe (PHeap e)} deriving (Monoid, Read, Show)--instance Ord e => Monoid (PHeap e) where -- elegant hack to automatically derive the Monoid instance for PQueue (via Maybe)-	PH n1 h1 `mappend` PH n2 h2 = PH (n1 + n2) (h1 `meld` h2)+newtype Heap e = H (Maybe (Tree e)) deriving (Read, Show)+-- data Rk e = Rk {-# UNPACK #-} !Int e deriving (Read, Show)+-- type RkTree e = Tree (Rk e)+data PQueue e = PQ {-# UNPACK #-} !Int {-# UNPACK #-} !(Heap e) deriving (Read, Show) -instance Ord e => Queuelike (PQueue e) e where-	singleton x = mkQ 1 (single x)-	peek (PQ h) = fmap (rootLabel . heap) h-	delete (PQ h) = fmap (\ (PH (n+1) (Node _ ts)) -> mkQ n (fuser ts)) h-	isEmpty = isNothing . getQ-	size = maybe 0 elts . getQ-	fromList xs = case foldr (\ x (n, ys) -> (n+1, single x : ys)) (0, []) xs of-				(0, _)	-> PQ Nothing-				(n, ys) -> mkQ n (fuser ys)-	{-# INLINE toList_ #-}-	toList_ (PQ h) = maybe [] (flatten . heap) h-	merge = mappend-	empty = PQ Nothing-	xs `insertAll` q = q `merge` fromList xs+instance Ord e => Monoid (Heap e) where+	mempty = H Nothing+	H (Just t1) `mappend` H (Just t2) = H (Just (t1 `meld` t2))+	h1 `mappend` H Nothing = h1+	H Nothing `mappend` h2 = h2+	mconcat hs = fuse [t | H (Just t) <- hs] -{-# INLINE mkQ #-}-mkQ :: Int -> Tree e -> PQueue e-mkQ n t = PQ (Just (PH n t))+instance Ord e => Monoid (PQueue e) where+	mempty = PQ 0 mempty+	PQ n1 h1 `mappend` PQ n2 h2 = PQ (n1 + n2) (h1 `mappend` h2)+	mconcat qs = let (n, ts) = fuser 0 [] qs in PQ n (fuse ts) where+		fuser !n ts qs = case qs of+			[]	-> (n, ts)+			(PQ m (H h):qs)	-> case h of	Nothing	-> fuser n ts qs+							Just t	-> fuser (n+m) (t:ts) qs +{-# INLINE meld #-} meld :: Ord e => Tree e -> Tree e -> Tree e-t1@(Node x1 ts1) `meld` t2@(Node x2 ts2) =+t1@(Node x1 ts1) `meld` t2@(Node x2 ts2) =  	if x1 > x2 then Node x2 (t1:ts2) else Node x1 (t2:ts1) -fuser :: Ord e => Forest e -> Tree e-fuser [t] = t-fuser l = fuser (fuser' l) where-	fuser' (t1:t2:ts) = t1 `meld` t2 : fuser' ts-	fuser' [t1] = [t1]-	fuser' [] = []--{-# INLINE single #-}-single :: e -> Tree e-single x = Node x []+fuse :: Ord e => [Tree e] -> Heap e+fuse [] = H Nothing+fuse [t] = H (Just t)+fuse ts = fuse (fuser ts) where+	fuser (x1:x2:xs) = (x1 `meld` x2) : fuser xs+	fuser xs = xs -mergeAllPH :: Ord e => [PQueue e] -> PQueue e-mergeAllPH qs = let (n, ts) = foldr (\ (PH n t) (m, ts) -> (n+m, t:ts)) (0, []) [ph | PQ (Just ph) <- qs] in-	if n == 0 then PQ Nothing else mkQ n (fuser ts)+instance Ord e => Queuelike (PQueue e) e where+	singleton x = PQ 1 (H (Just (Node x [])))+	extract (PQ n (H h)) = fmap (\ (Node x ts) -> (x, PQ (n-1) $ fuse ts)) h+	isEmpty (PQ _ (H h)) = isNothing h+	size (PQ n _) = n+	{-# INLINE fromList #-}+	fromList xs = mconcat (map singleton xs)+	{-# INLINE toList_ #-}+	toList_ (PQ _ (H h)) = maybe [] flatten h+	merge = mappend+	empty = mempty+	{-# INLINE insertAll #-}+	xs `insertAll` q = q `merge` fromList xs  {-# NOINLINE [0] flattenFB #-} flattenFB :: Tree a -> (a -> b -> b) -> b -> b
pqueue-mtl.cabal view
@@ -1,6 +1,6 @@  name:		pqueue-mtl-version:	1.0.2+version:	1.0.3 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. tested-with:	GHC@@ -9,8 +9,7 @@ license-file:	LICENSE author:		Louis Wasserman maintainer:	wasserman.louis@gmail.com-build-Depends:	base, ghc-prim, mtl, containers, stateful-mtl >= 1.0.2 , MaybeT+build-Depends:	base, ghc-prim, mtl, containers, stateful-mtl == 1.0.3 , MaybeT 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 ghc-options:-