queuelike 1.0.3 → 1.0.4

raw patch · 2 files changed

+79/−60 lines, 2 files

Files

• Data/Queue/TrieQueue.hs +78/−59
• queuelike.cabal +1/−1

@@ -1,31 +1,51 @@ {-# LANGUAGE PatternGuards, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# OPTIONS -fno-warn-missing-methods #-}  -- | An experimental trie-based priority queue for lists.-module Data.Queue.TrieQueue (TrieQueue) where+module Data.Queue.TrieQueue where+-- Data.Sequence-labelled trie implementation, bootstrapping monoid structure to achieve maximum great justice. -import GHC.Exts import Data.Queue.Class-import Control.Arrow(first)+import Data.Queue.QueueHelpers++import Control.Arrow((***)) 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 Data.Map (Map, findMin, minViewWithKey, fromDistinctAscList) import qualified Data.Map as Map import qualified Data.Foldable as Fold (toList)-import Data.Queue.QueueHelpers +import GHC.Exts+ 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) +-- Type of a nonempty trie.+data Trie e = 	Leaf (Label e) {-# UNPACK #-} !Int 	-- Leaf xs n represents n occurrences of the string xs.  n is always strictly positive.+	      | Edge (Label e) {-# UNPACK #-} !Int (Map e (Trie e)) -- Edge xs n m represents n occurrences of xs, and xs prepended to each element of the map.+		deriving (Eq)+type MTrie e = Maybe (Trie e)+newtype TrieQueue e = TQ (HeapQ (Trie e)) deriving (Eq, Show, Monoid)++{-# INLINE mkTQ #-}+mkTQ :: Int -> Trie e -> TrieQueue e+mkTQ n t = TQ (HQ n (Just t))++mkLab :: [e] -> Label e+mkLab = Seq.fromList++instance Show e => Show (Trie e) where+	show (Leaf xs xn) = "(" ++ show xn ++ "x" ++ show (Fold.toList xs) ++ ")"+	show (Edge xs xn m) = "==" ++ show xn ++ "x" ++ show (Fold.toList xs) ++ "==>" ++ show m+ instance Ord e => Monoid (Trie e) where-	mempty = Empty+	-- not a true monoid instance; only a semigroup 	mappend = merger  instance Ord e => IQueue (TrieQueue e) where@@ -34,41 +54,40 @@ 	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+	singleton xs = mkTQ 1 $ Leaf (mkLab xs) 1+--	fromList = TQ . liftM2 HQ length trieFromList -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+	extract (TQ (HQ n t)) = fmap ((Fold.toList *** (TQ . HQ (n-1))) . extractMin') t+	size (TQ (HQ n _)) = n  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)+catTrie xs (Leaf ys n) = Leaf (xs >< ys) n+catTrie xs (Edge ys n m) = compactTrie (Edge (xs >< ys) n m)  compactTrie :: Ord e => Trie e -> Trie e-compactTrie (Edge xs n m)-	| Map.null m		= compactTrie (Leaf xs n)+compactTrie = fromJust . compactTrie'++compactTrie' :: Ord e => Trie e -> MTrie e+compactTrie' t@(Edge xs 0 m)+	| Map.null m	= Nothing 	| Map.size m == 1, (y, yT) <- findMin m-		= catTrie (xs |> y) yT-compactTrie (Leaf _ 0) = Empty-compactTrie t = t+			= Just $ catTrie (xs |> y) yT+	| otherwise	= Just t+compactTrie' (Edge xs n m)+	| Map.null m	= Just $ Leaf xs n+compactTrie' (Leaf _ 0) = Nothing+compactTrie' t = Just 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 -> (Label e, MTrie e)+extractMin' (Leaf xs n) = (xs, compactTrie' (Leaf xs (n-1)))+extractMin' (Edge xs (n+1) m) = (xs, compactTrie' (Edge xs n m))+extractMin' (Edge xs 0 m)+	| Just ((y, yT), m') <- minViewWithKey m,+		(ys, yT') <- extractMin' yT+	= (xs >< (y <| ys), maybe (compactTrie' (Edge xs 0 m')) (\ yT' -> Just $ Edge xs 0 $ Map.insert y yT' m') yT')+extractMin' _ = error "Internal failure to note empty queue"+ --extractMin :: Ord e => Trie e -> Maybe ([e], Trie e) --extractMin = fmap (first toList) . extractMin' @@ -76,41 +95,41 @@  {-# 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)]+merge' xs0 ys0 xTail yTail xCons yCons xy = merge'' 0 xs0 ys0 where+	merge'' n xs ys = case (viewl xs, viewl ys) of+		(x :< xs1, y :< ys1) -> let pfx = Seq.take n xs0; xT = xTail xs1; yT = yTail ys1; in case x `compare` y of+			LT	-> Edge pfx 0 $ 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+			GT	-> Edge pfx 0 $ fromDistinctAscList [(y, yT), (x, xT)]+		(x :< xs1, EmptyL)	-> yCons x xs1+		(EmptyL, y :< ys1)	-> xCons y ys1+		(EmptyL, EmptyL)	-> xy 	 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))+	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))+	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)+	= 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 :: Ord e => [[e]] -> MTrie 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')+	where	groupHeads = groupBy ((==) `on` listToMaybe) . sortBy (comparing listToMaybe)+		extractCommon pfx xs = case groupHeads xs of+			[]			-> Nothing+			[empties@([]:_)]	-> Just $ Leaf pfx (length empties)+			(empties@([]:_):xss)	-> Just $ Edge pfx (length empties) (fromGroups xss)+				-- even if there's only one other group, we end the edge here+				-- a more optimized implementation might specialize for this case 			[(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]+				-- if there's but a single group with a shared first character, snoc it onto the accumulated prefix+				-- and recurse+			xss			-> Just $ Edge pfx 0 (fromGroups xss)+		fromGroups xss = fromDistinctAscList [(y, fromJust $ trieFromList $ ys : map tail yss) | ((y:ys):yss) <- xss]

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