queuelike 1.0.1 → 1.0.2

raw patch · 4 files changed

+123/−6 lines, 4 files

Files

Data/Queue/Instances.hs +2/−1
Data/Queue/QueueHelpers.hs +4/−4
Data/Queue/TrieQueue.hs +116/−0
queuelike.cabal +1/−1

Data/Queue/Instances.hs view

@@ -4,7 +4,8 @@ -- import Data.Queue.FibQueue import Data.Queue.Stack import Data.Queue.Queue+import Data.Queue.TrieQueue -- import Data.Queue.ReverseQueue -- import Data.Queue.SkewQueue-import Data.Queue.IntQueue+--import Data.Queue.IntQueue -- import Data.Queue.SoftHeap

Data/Queue/QueueHelpers.hs view

@@ -20,12 +20,12 @@ In particular, this almost immediately yields a correct pairing heap implementation (cf. PQueue) -------------------} -module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, endoMaybe, order, fusing, fuseMerge, fuseMergeM, on) where+module Data.Queue.QueueHelpers (MonoidQ (..), HeapQ, endoMaybe, order, fusing, fuseMerge, fuseMergeM) where  import Data.Monoid import Data.Maybe -data MonoidQ m = HQ {elts :: {-# UNPACK #-} !Int, heap :: m}+data MonoidQ m = HQ {elts :: {-# UNPACK #-} !Int, heap :: m} deriving (Eq, Ord, Show) type HeapQ m = MonoidQ (Maybe m)  instance Monoid m => Monoid (MonoidQ m) where@@ -36,8 +36,8 @@ 	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 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)

+ Data/Queue/TrieQueue.hs view

@@ -0,0 +1,116 @@+{-# LANGUAGE PatternGuards, TypeFamilies, GeneralizedNewtypeDeriving #-}++-- | An experimental trie-based priority queue for lists.+module Data.Queue.TrieQueue (TrieQueue) where++import GHC.Exts+import Data.Queue.Class+import Control.Arrow(first)+import Control.Monad(liftM2)+import Data.Function+import Data.Maybe+import Data.List (sortBy, groupBy)+import Data.Word+import Data.Monoid+import Data.Ord+import Data.Sequence (Seq, viewl, ViewL(..), (><), (|>), (<|))+import qualified Data.Sequence as Seq+import Data.Map (Map, findMin)+import qualified Data.Map as Map+import qualified Data.Foldable as Fold (toList)+import Data.Queue.QueueHelpers++type Label e = Seq e+data Trie e = Empty | Leaf (Label e) {-# UNPACK #-} !Int | Edge (Label e) {-# UNPACK #-} !Int (Map e (Trie e)) deriving (Eq)+newtype TrieQueue e = TQ (MonoidQ (Trie e)) deriving (Eq, Show, Monoid)++instance Ord e => Monoid (Trie e) where+	mempty = Empty+	mappend = merger++instance Ord e => IQueue (TrieQueue e) where+	type QueueKey (TrieQueue e) = [e]+	empty = mempty+	merge = mappend+	mergeAll = mconcat++	singleton xs = TQ (HQ 1 (Leaf (Seq.fromList xs) 1))+	fromList = TQ . liftM2 HQ length trieFromList+	+	extract (TQ (HQ n t)) = fmap (\ (x, t) -> (Fold.toList x, TQ (HQ (n-1) t))) (extractMin' t)+	size (TQ (HQ n _)) = n++instance Show e => Show (Trie e) where+	show Empty = "Empty"+	show (Leaf xs xn) = "(" ++ show xn ++ "x" ++ show xs ++ ")"+	show (Edge xs xn m) = "==" ++ show xn ++ "x" ++ show (Fold.toList xs) ++ "==>" ++ show m++catTrie :: Ord e => Label e -> Trie e -> Trie e+catTrie _ Empty = Empty+catTrie xs (Leaf ys n) = Leaf (xs `mappend` ys) n+catTrie xs (Edge ys n m) = compactTrie (Edge (xs `mappend` ys) n m)++compactTrie :: Ord e => Trie e -> Trie e+compactTrie (Edge xs n m)+	| Map.null m		= compactTrie (Leaf xs n)+	| Map.size m == 1, (y, yT) <- findMin m+		= catTrie (xs |> y) yT+compactTrie (Leaf _ 0) = Empty+compactTrie t = t++extractMin' :: Ord e => Trie e -> Maybe (Label e, Trie e)+extractMin' (Leaf xs (n+1)) = Just (xs, compactTrie (Leaf xs n))+extractMin' (Edge xs (n+1) m) = Just (xs, compactTrie (Edge xs n m))+extractMin' (Edge xs 0 m) +	| Just ((y, yT), m') <- Map.minViewWithKey m,+		Just (ys, yT') <- extractMin' yT+	= Just (xs >< (y <| ys), case yT' of+		Empty	-> compactTrie (Edge xs 0 m')+		_		-> Edge xs 0 (Map.insert y yT' m'))+extractMin' _ = Nothing++--extractMin :: Ord e => Trie e -> Maybe ([e], Trie e)+--extractMin = fmap (first toList) . extractMin'++type TailMaker e = Label e -> Trie e++{-# INLINE merge' #-}+merge' :: Ord e => Label e -> Label e -> TailMaker e -> TailMaker e -> (e -> TailMaker e) -> (e -> TailMaker e) -> Trie e -> Trie e+merge' xs0 ys0 xTail yTail xCons yCons xy =+	let merge'' n xs ys = case (viewl xs, viewl ys) of+		(x :< xs1, y :< ys1) -> let xT = xTail xs1; yT = yTail ys1; in case x `compare` y of+			LT	-> Edge (Seq.take n xs0) 0 $ Map.fromDistinctAscList [(x, xT), (y, yT)]+			EQ	-> merge'' (n+1) xs1 ys1+			GT	-> Edge (Seq.take n xs0) 0 $ Map.fromDistinctAscList [(y, yT), (x, xT)]+		(EmptyL, y :< ys1)+			-> xCons y ys1+		(x :< xs1, EmptyL)+			-> yCons x xs1+		(EmptyL, EmptyL)+			-> xy+		in merge'' 0 xs0 ys0+	+merger :: Ord e => Trie e -> Trie e -> Trie e	+Leaf xs0 xn `merger` Leaf ys0 yn =+	inline merge' xs0 ys0 (flip Leaf xn) (flip Leaf yn) (edger xs0 xn yn) (edger ys0 yn xn) (Leaf xs0 (xn + yn))+	where	edger xs xn yn y ys = Edge xs xn $ Map.singleton y (Leaf ys yn)+Leaf xs0 xn `merger` Edge ys0 yn yM =+	inline merge' xs0 ys0 (flip Leaf xn) (\ ys -> Edge ys yn yM) (\ y ys -> Edge xs0 xn $ Map.singleton y (Edge ys yn yM))+		(\ x xs -> Edge ys0 yn $ Map.insertWith merger x (Leaf xs xn) yM) (Edge xs0 (xn + yn) yM)+x@Edge{} `merger` y@Leaf{} = merger y x+Edge xs0 xn xM `merger` Edge ys0 yn yM+	= inline merge' xs0 ys0 (edger xn xM) (edger yn yM) (cons xs0 xn yn yM) (cons ys0 yn xn xM)+			(Edge xs0 (xn + yn) $ Map.unionWith merger xM yM)+	where	edger n m l = Edge l n m+		cons xs xn yn yM y = Edge xs xn . Map.singleton y . edger yn yM+Empty `merger` trie = trie+trie `merger` Empty = trie++trieFromList :: Ord e => [[e]] -> Trie e+trieFromList = extractCommon mempty+	where	extractCommon pfx xs = case groupBy ((==) `on` listToMaybe) (sortBy (comparing listToMaybe) xs) of+			[]			-> Empty+			(empties@([]:_):xs')	-> Edge pfx (fromIntegral $ length empties) (fromGroups xs')+			[(y:ys):yss]		-> extractCommon (pfx |> y) (ys:map tail yss)+			xs'			-> Edge pfx 0 (fromGroups xs')+		fromGroups xss = Map.fromDistinctAscList [(y, trieFromList $ ys : map tail yss) | ((y:ys):yss) <- xss]

queuelike.cabal view

@@ -1,5 +1,5 @@ name:		queuelike-version:	1.0.1+version:	1.0.2 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