diff --git a/Data/ListTrie/Base.hs b/Data/ListTrie/Base.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Base.hs @@ -0,0 +1,841 @@ +-- File created: 2008-11-13 21:13:55 + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies + , FlexibleContexts #-} + +module Data.ListTrie.Base + ( Trie(..) + , null, size, size', member, notMember, lookup, lookupWithDefault + , isSubmapOfBy, isProperSubmapOfBy + , empty, singleton + , insert, insert', insertWith, insertWith' + , delete, adjust, adjust', updateLookup, alter, alter' + , unionWith, unionWithKey, unionWith', unionWithKey' + , unionsWith, unionsWithKey, unionsWith', unionsWithKey' + , differenceWith, differenceWithKey + , intersectionWith, intersectionWithKey + , intersectionWith', intersectionWithKey' + , filterWithKey, partitionWithKey + , split, splitLookup + , mapKeysWith, mapInKeysWith, mapInKeysWith' + , foldrWithKey, foldrAscWithKey, foldrDescWithKey + , foldlWithKey, foldlAscWithKey, foldlDescWithKey + , foldlWithKey', foldlAscWithKey', foldlDescWithKey' + , toList, toAscList, toDescList + , fromList, fromListWith, fromListWith', fromListWithKey, fromListWithKey' + , findMin, findMax, deleteMin, deleteMax, minView, maxView + , findPredecessor, findSuccessor + , addPrefix, splitPrefix, deletePrefix, children + , showTrieWith + ) where + +import Control.Applicative (Applicative(..), (<$>)) +import Control.Arrow ((***), first) +import qualified Data.DList as DL +import Data.DList (DList) +import Data.Foldable (foldr, foldl') +import Data.List (partition) +import Data.Maybe (fromJust) +import Prelude hiding (lookup, filter, foldr, null) +import qualified Prelude + +import qualified Data.ListTrie.Base.Map.Internal as Map +import Data.ListTrie.Base.Classes + ( Boolable(..) + , Unwrappable(..) + , Unionable(..), Differentiable(..), Intersectable(..) + , Alt(..) + , fmap', (<$!>) + ) +import Data.ListTrie.Base.Map (Map, OrdMap) +import Data.ListTrie.Util ((.:), both) + +class (Map map k, Functor st, Unwrappable st) + => Trie trie st map k | trie -> st where + + mkTrie :: st a -> CMap trie map k a -> trie map k a + tParts :: trie map k a -> (st a, CMap trie map k a) + +type CMap trie map k v = map k (trie map k v) + +hasValue, noValue :: Boolable b => b -> Bool +hasValue = toBool +noValue = not . hasValue + +tVal :: Trie trie st map k => trie map k a -> st a +tVal = fst . tParts + +tMap :: Trie trie st map k => trie map k a -> CMap trie map k a +tMap = snd . tParts + +mapVal :: Trie trie st map k => trie map k a + -> (st a -> st a) + -> trie map k a +mapVal tr f = mkTrie (f . tVal $ tr) (tMap tr) + +mapMap :: (Trie trie st map k1, Trie trie st map k2) + => trie map k1 a + -> (CMap trie map k1 a -> CMap trie map k2 a) + -> trie map k2 a +mapMap tr f = mkTrie (tVal tr) (f . tMap $ tr) + +onVals :: Trie trie st map k => (st a -> st b -> st c) + -> trie map k a + -> trie map k b + -> st c +onVals f a b = f (tVal a) (tVal b) + +onMaps :: Trie trie st map k => ( CMap trie map k a + -> CMap trie map k b + -> CMap trie map k c + ) + -> trie map k a + -> trie map k b + -> CMap trie map k c +onMaps f a b = f (tMap a) (tMap b) + +----------------------- + +-- * Construction + +-- O(1) +empty :: (Alt st a, Trie trie st map k) => trie map k a +empty = mkTrie altEmpty Map.empty + +-- O(s) +singleton :: (Alt st a, Trie trie st map k) => [k] -> a -> trie map k a +singleton xs v = addPrefix xs $ mkTrie (pure v) Map.empty + +-- O(min(m,s)) +insert :: (Alt st a, Trie trie st map k) + => [k] -> a -> trie map k a -> trie map k a +insert = insertWith const + +-- O(min(m,s)) +insert' :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> a -> trie map k a -> trie map k a +insert' = insertWith' const + +-- O(min(m,s)) +insertWith :: (Alt st a, Trie trie st map k) + => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a +insertWith = genericInsertWith (<$>) + +-- O(min(m,s)) +insertWith' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a +insertWith' = (seq <*>) .: genericInsertWith (<$!>) + +genericInsertWith :: (Alt st a, Trie trie st map k) + => ((a -> a) -> st a -> st a) + -> (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a +genericInsertWith (<$$>) f [] new tr = + mapVal tr $ \old -> (f new <$$> old) <|> pure new + +genericInsertWith (<$$>) f (x:xs) val tr = mapMap tr $ \m -> + Map.insertWith (\_ old -> genericInsertWith (<$$>) f xs val old) + x (singleton xs val) m + +-- O(min(m,s)) +delete :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> trie map k a +delete = alter (const altEmpty) + +-- O(min(m,s)) +adjust :: Trie trie st map k + => (a -> a) -> [k] -> trie map k a -> trie map k a +adjust = genericAdjust fmap + +-- O(min(m,s)) +adjust' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a) -> [k] -> trie map k a -> trie map k a +adjust' = genericAdjust fmap' + +genericAdjust :: Trie trie st map k + => ((a -> a) -> st a -> st a) + -> (a -> a) -> [k] -> trie map k a -> trie map k a +genericAdjust myFmap f [] tr = mapVal tr (myFmap f) +genericAdjust myFmap f (x:xs) tr = + mapMap tr $ \m -> Map.adjust (genericAdjust myFmap f xs) x m + +-- O(min(m,s)) +updateLookup :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> st a) -> [k] -> trie map k a -> (st a, trie map k a) +updateLookup f [] tr = + let (v,m) = tParts tr + v' = if hasValue v then f (unwrap v) else v + in (v, mkTrie v' m) + +updateLookup f (x:xs) orig = + let m = tMap orig + in case Map.lookup x m of + Nothing -> (altEmpty, orig) + Just tr -> + let (ret, upd) = updateLookup f xs tr + in ( ret + , mkTrie (tVal orig) $ if null upd + then Map.delete x m + else Map.adjust (const upd) x m + ) + +-- O(min(m,s)) +-- +-- Lazy in exactly one case: the key is the prefix of another key in the trie. +-- Otherwise we have to test whether the function removed a key or not, lest +-- the trie fall into an invalid state. +alter :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> st a) -> [k] -> trie map k a -> trie map k a +alter = genericAlter (flip const) + +-- O(min(m,s)) +alter' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> st a) -> [k] -> trie map k a -> trie map k a +alter' = genericAlter seq + +genericAlter :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> trie map k a -> trie map k a) + -> (st a -> st a) -> [k] -> trie map k a -> trie map k a +genericAlter seeq f [] tr = + let (v,m) = tParts tr + v' = f v + in v' `seeq` mkTrie v' m + +genericAlter seeq f (x:xs) tr = mapMap tr $ \m -> + Map.alter (\mold -> case mold of + Nothing -> + let v = f altEmpty + in if hasValue v + then Just (singleton xs (unwrap v)) + else Nothing + Just old -> + let new = genericAlter seeq f xs old + in if null new then Nothing else Just new) + x m + +-- * Querying + +-- O(1) +-- +-- Test the strict field last for maximal laziness +null :: (Boolable (st a), Trie trie st map k) => trie map k a -> Bool +null tr = Map.null (tMap tr) && (noValue.tVal $ tr) + +-- O(n m) +size :: (Boolable (st a), Trie trie st map k, Num n) => trie map k a -> n +size tr = foldr ((+) . size) (if hasValue (tVal tr) then 1 else 0) (tMap tr) + +-- O(n m) +size' :: (Boolable (st a), Trie trie st map k, Num n) => trie map k a -> n +size' tr = foldl' (flip $ (+) . size') + (if hasValue (tVal tr) then 1 else 0) + (tMap tr) + +-- O(min(m,s)) +member :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> Bool +member = hasValue .: lookup + +-- O(min(m,s)) +notMember :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> Bool +notMember = not .: member + +-- O(min(m,s)) +lookup :: (Alt st a, Trie trie st map k) => [k] -> trie map k a -> st a +lookup [] tr = tVal tr +lookup (x:xs) tr = maybe altEmpty (lookup xs) (Map.lookup x (tMap tr)) + +-- O(min(m,s)) +lookupWithDefault :: (Alt st a, Trie trie st map k) + => a -> [k] -> trie map k a -> a +lookupWithDefault def k tr = unwrap $ lookup k tr <|> pure def + +-- O(min(n1 m1,n2 m2)) +isSubmapOfBy :: (Boolable (st a), Boolable (st b), Trie trie st map k) + => (a -> b -> Bool) + -> trie map k a + -> trie map k b + -> Bool +isSubmapOfBy f tr1 tr2 = + let (v1,m1) = tParts tr1 + (v2,m2) = tParts tr2 + hv1 = hasValue v1 + hv2 = hasValue v2 + in and [ not (hv1 && not hv2) + , (not hv1 && not hv2) || f (unwrap v1) (unwrap v2) + , Map.isSubmapOfBy (isSubmapOfBy f) m1 m2 + ] + +-- O(min(n1 m1,n2 m2)) +isProperSubmapOfBy :: (Boolable (st a), Boolable (st b), Trie trie st map k) + => (a -> b -> Bool) + -> trie map k a + -> trie map k b + -> Bool +isProperSubmapOfBy = go False + where + go proper f tr1 tr2 = + let (v1,m1) = tParts tr1 + (v2,m2) = tParts tr2 + hv1 = hasValue v1 + hv2 = hasValue v2 + -- This seems suboptimal but I can't think of anything better + proper' = or [ proper + , noValue v1 && hasValue v2 + , not (Map.null $ Map.difference m2 m1) + ] + in and [ not (hv1 && not hv2) + , (not hv1 && not hv2) || f (unwrap v1) (unwrap v2) + , if Map.null m1 + then proper' + else Map.isSubmapOfBy (go proper' f) m1 m2 + ] + + +-- * Combination + +-- O(min(n1 m1,n2 m2)) +unionWith :: (Unionable st a, Trie trie st map k) + => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a +unionWith f = genericUnionWith (unionVals f) (flip const) + +-- O(min(n1 m1,n2 m2)) +unionWith' :: (Unionable st a, Trie trie st map k) + => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a +unionWith' f = genericUnionWith (unionVals' f) seq + +genericUnionWith :: Trie trie st map k + => (st a -> st a -> st a) + -> (st a -> trie map k a -> trie map k a) + -> trie map k a + -> trie map k a + -> trie map k a +genericUnionWith valUnion seeq tr1 tr2 = + let v = onVals valUnion tr1 tr2 + in v `seeq` ( + mkTrie v $ + onMaps (Map.unionWith (genericUnionWith valUnion seeq)) + tr1 tr2) + +-- O(min(n1 m1,n2 m2)) +unionWithKey :: (Unionable st a, Trie trie st map k) => ([k] -> a -> a -> a) + -> trie map k a + -> trie map k a + -> trie map k a +unionWithKey = genericUnionWithKey unionVals (flip const) + +-- O(min(n1 m1,n2 m2)) +unionWithKey' :: (Unionable st a, Trie trie st map k) => ([k] -> a -> a -> a) + -> trie map k a + -> trie map k a + -> trie map k a +unionWithKey' = genericUnionWithKey unionVals' seq + +genericUnionWithKey :: Trie trie st map k + => ((a -> a -> a) -> st a -> st a -> st a) + -> (st a -> trie map k a -> trie map k a) + -> ([k] -> a -> a -> a) + -> trie map k a + -> trie map k a + -> trie map k a +genericUnionWithKey = go DL.empty + where + go k valUnion seeq f tr1 tr2 = + let v = onVals (valUnion (f $ DL.toList k)) tr1 tr2 + in v `seeq` ( + mkTrie v $ + onMaps (Map.unionWithKey $ + \x -> go (k `DL.snoc` x) valUnion seeq f) + tr1 tr2) + +-- O(sum(n)) +unionsWith :: (Alt st a, Unionable st a, Trie trie st map k) + => (a -> a -> a) -> [trie map k a] -> trie map k a +unionsWith f = foldl' (unionWith f) empty + +-- O(sum(n)) +unionsWith' :: (Alt st a, Unionable st a, Trie trie st map k) + => (a -> a -> a) -> [trie map k a] -> trie map k a +unionsWith' f = foldl' (unionWith' f) empty + +-- O(sum(n)) +unionsWithKey :: (Alt st a, Unionable st a, Trie trie st map k) + => ([k] -> a -> a -> a) -> [trie map k a] -> trie map k a +unionsWithKey j = foldl' (unionWithKey j) empty + +-- O(sum(n)) +unionsWithKey' :: (Alt st a, Unionable st a, Trie trie st map k) + => ([k] -> a -> a -> a) -> [trie map k a] -> trie map k a +unionsWithKey' j = foldl' (unionWithKey' j) empty + +-- O(min(n1 m1,n2 m2)) +differenceWith :: (Boolable (st a), Differentiable st a b, Trie trie st map k) + => (a -> b -> Maybe a) + -> trie map k a + -> trie map k b + -> trie map k a +differenceWith f tr1 tr2 = + let v = onVals (differenceVals f) tr1 tr2 + + -- This would be lazy only in the case where the differing keys were at + -- []. (And even then most operations on the trie would force the + -- value.) For consistency with other keys and Patricia, just seq it for + -- that case as well. + in v `seq` mkTrie v $ onMaps (Map.differenceWith (g f)) tr1 tr2 + where + g f' t1 t2 = let t' = differenceWith f' t1 t2 + in if null t' then Nothing else Just t' + +-- O(min(n1 m1,n2 m2)) +differenceWithKey :: ( Boolable (st a), Differentiable st a b + , Trie trie st map k + ) + => ([k] -> a -> b -> Maybe a) + -> trie map k a + -> trie map k b + -> trie map k a +differenceWithKey = go DL.empty + where + go k f tr1 tr2 = + let v = onVals (differenceVals (f $ DL.toList k)) tr1 tr2 + + -- see comment in differenceWith for seq explanation + in v `seq` mkTrie v $ onMaps (Map.differenceWithKey (g k f)) tr1 tr2 + + g k f x t1 t2 = let t' = go (k `DL.snoc` x) f t1 t2 + in if null t' then Nothing else Just t' + +-- O(min(n1 m1,n2 m2)) +intersectionWith :: ( Boolable (st c), Intersectable st a b c + , Trie trie st map k + ) + => (a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWith f = genericIntersectionWith (intersectionVals f) (flip const) + +-- O(min(n1 m1,n2 m2)) +intersectionWith' :: ( Boolable (st c), Intersectable st a b c + , Trie trie st map k + ) + => (a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWith' f = genericIntersectionWith (intersectionVals' f) seq + +genericIntersectionWith :: (Boolable (st c), Trie trie st map k) + => (st a -> st b -> st c) + -> (st c -> trie map k c -> trie map k c) + -> trie map k a + -> trie map k b + -> trie map k c +genericIntersectionWith valIntersection seeq tr1 tr2 = + tr seeq + (onVals valIntersection tr1 tr2) + (onMaps (Map.filter (not.null) .: + Map.intersectionWith + (genericIntersectionWith valIntersection seeq)) + tr1 tr2) + where + tr seeq' v m = + v `seeq'` (mkTrie v $ + case Map.singletonView m of + Just (_, child) | null child -> tMap child + _ -> m) + +-- O(min(n1 m1,n2 m2)) +intersectionWithKey :: ( Boolable (st c), Intersectable st a b c + , Trie trie st map k + ) + => ([k] -> a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWithKey = genericIntersectionWithKey intersectionVals (flip const) + +-- O(min(n1 m1,n2 m2)) +intersectionWithKey' :: ( Boolable (st c), Intersectable st a b c + , Trie trie st map k + ) + => ([k] -> a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWithKey' = genericIntersectionWithKey intersectionVals' seq + +genericIntersectionWithKey :: (Boolable (st c), Trie trie st map k) + => ((a -> b -> c) -> st a -> st b -> st c) + -> (st c -> trie map k c -> trie map k c) + -> ([k] -> a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +genericIntersectionWithKey = go DL.empty + where + go k valIntersection seeq f tr1 tr2 = + tr seeq + (onVals (valIntersection (f $ DL.toList k)) tr1 tr2) + (onMaps (Map.filter (not.null) .: + Map.intersectionWithKey + (\x -> go (k `DL.snoc` x) valIntersection seeq f)) + tr1 tr2) + + tr seeq v m = + v `seeq` (mkTrie v $ + case Map.singletonView m of + Just (_, child) | null child -> tMap child + _ -> m) + +-- * Filtering + +-- O(n m) +filterWithKey :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> Bool) -> trie map k a -> trie map k a +filterWithKey p = fromList . Prelude.filter (uncurry p) . toList + +-- O(n m) +partitionWithKey :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> Bool) + -> trie map k a + -> (trie map k a, trie map k a) +partitionWithKey p = both fromList . partition (uncurry p) . toList + +-- * Mapping + +-- O(n m) +mapKeysWith :: (Boolable (st a), Trie trie st map k1, Trie trie st map k2) + => ([([k2],a)] -> trie map k2 a) + -> ([k1] -> [k2]) + -> trie map k1 a + -> trie map k2 a +mapKeysWith fromlist f = fromlist . map (first f) . toList + +-- O(n m) +mapInKeysWith :: (Unionable st a, Trie trie st map k1, Trie trie st map k2) + => (a -> a -> a) + -> (k1 -> k2) + -> trie map k1 a + -> trie map k2 a +mapInKeysWith = genericMapInKeysWith unionWith + +-- O(n m) +mapInKeysWith' :: (Unionable st a, Trie trie st map k1, Trie trie st map k2) + => (a -> a -> a) + -> (k1 -> k2) + -> trie map k1 a + -> trie map k2 a +mapInKeysWith' = genericMapInKeysWith unionWith' + +genericMapInKeysWith :: ( Unionable st a + , Trie trie st map k1, Trie trie st map k2 + ) + => (f -> trie map k2 a -> trie map k2 a -> trie map k2 a) + -> f + -> (k1 -> k2) + -> trie map k1 a + -> trie map k2 a +genericMapInKeysWith unionW j f tr = + mapMap tr $ + Map.fromListWith (unionW j) . + map (f *** genericMapInKeysWith unionW j f) . + Map.toList + +-- * Folding + +-- O(n m) +foldrWithKey :: (Boolable (st a), Trie trie st map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldrWithKey f x = foldr (uncurry f) x . toList + +-- O(n m) +foldrAscWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldrAscWithKey f x = foldr (uncurry f) x . toAscList + +-- O(n m) +foldrDescWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldrDescWithKey f x = foldr (uncurry f) x . toDescList + +-- O(n m) +foldlWithKey :: (Boolable (st a), Trie trie st map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlWithKey f x = foldl (flip $ uncurry f) x . toList + +-- O(n m) +foldlAscWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlAscWithKey f x = foldl (flip $ uncurry f) x . toAscList + +-- O(n m) +foldlDescWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlDescWithKey f x = foldl (flip $ uncurry f) x . toDescList + +-- O(n m) +foldlWithKey' :: (Boolable (st a), Trie trie st map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlWithKey' f x = foldl' (flip $ uncurry f) x . toList + +-- O(n m) +foldlAscWithKey' :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlAscWithKey' f x = foldl' (flip $ uncurry f) x . toAscList + +-- O(n m) +foldlDescWithKey' :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlDescWithKey' f x = foldl' (flip $ uncurry f) x . toDescList + +-- * Conversion between lists + +-- O(n m) +toList :: (Boolable (st a), Trie trie st map k) => trie map k a -> [([k],a)] +toList = genericToList Map.toList DL.cons + +-- O(n m) +toAscList :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> [([k],a)] +toAscList = genericToList Map.toAscList DL.cons + +-- O(n m) +toDescList :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> [([k],a)] +toDescList = genericToList (reverse . Map.toAscList) (flip DL.snoc) + +genericToList :: (Boolable (st a), Trie trie st map k) + => (CMap trie map k a -> [(k, trie map k a)]) + -> (([k],a) -> DList ([k],a) -> DList ([k],a)) + -> trie map k a + -> [([k],a)] +genericToList f_ g_ = DL.toList . go DL.empty f_ g_ + where + go xs tolist add tr = + let (v,m) = tParts tr + xs' = + DL.concat . + map (\(x,t) -> go (xs `DL.snoc` x) tolist add t) . + tolist $ m + in if hasValue v + then add (DL.toList xs, unwrap v) xs' + else xs' + +-- O(n m) +fromList :: (Alt st a, Trie trie st map k) => [([k],a)] -> trie map k a +fromList = fromListWith const + +-- O(n m) +fromListWith :: (Alt st a, Trie trie st map k) + => (a -> a -> a) -> [([k],a)] -> trie map k a +fromListWith f = foldl' (flip . uncurry $ insertWith f) empty + +-- O(n m) +fromListWith' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a -> a) -> [([k],a)] -> trie map k a +fromListWith' f = foldl' (flip . uncurry $ insertWith' f) empty + +-- O(n m) +fromListWithKey :: (Alt st a, Trie trie st map k) + => ([k] -> a -> a -> a) -> [([k],a)] -> trie map k a +fromListWithKey f = foldl' (\tr (k,v) -> insertWith (f k) k v tr) empty + +-- O(n m) +fromListWithKey' :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> a -> a) -> [([k],a)] -> trie map k a +fromListWithKey' f = foldl' (\tr (k,v) -> insertWith' (f k) k v tr) empty + +-- * Min/max + +-- O(m) +minView :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> (Maybe ([k], a), trie map k a) +minView = minMaxView (hasValue . tVal) (fst . Map.minViewWithKey) + +-- O(m) +maxView :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> (Maybe ([k], a), trie map k a) +maxView = minMaxView (Map.null . tMap) (fst . Map.maxViewWithKey) + +minMaxView :: (Alt st a, Boolable (st a), Trie trie st map k) + => (trie map k a -> Bool) + -> (CMap trie map k a -> Maybe (k, trie map k a)) + -> trie map k a + -> (Maybe ([k], a), trie map k a) +minMaxView _ _ tr_ | null tr_ = (Nothing, tr_) +minMaxView f g tr_ = first Just (go f g tr_) + where + go isWanted mapView tr = + let (v,m) = tParts tr + in if isWanted tr + then (([], unwrap v), mkTrie altEmpty m) + else let (k, tr') = fromJust (mapView m) + (minMax, tr'') = go isWanted mapView tr' + in ( first (k:) minMax + , mkTrie v $ if null tr'' + then Map.delete k m + else Map.adjust (const tr'') k m + ) + +-- O(m) +findMin :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> Maybe ([k], a) +findMin = findMinMax (hasValue . tVal) (fst . Map.minViewWithKey) + +-- O(m) +findMax :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> Maybe ([k], a) +findMax = findMinMax (Map.null . tMap) (fst . Map.maxViewWithKey) + +findMinMax :: (Boolable (st a), Trie trie st map k) + => (trie map k a -> Bool) + -> (CMap trie map k a -> Maybe (k, trie map k a)) + -> trie map k a + -> Maybe ([k], a) +findMinMax _ _ tr_ | null tr_ = Nothing +findMinMax f g tr_ = Just (go f g DL.empty tr_) + where + go isWanted mapView xs tr = + if isWanted tr + then (DL.toList xs, unwrap (tVal tr)) + else let (k, tr') = fromJust . mapView . tMap $ tr + in go isWanted mapView (xs `DL.snoc` k) tr' + +-- O(m) +deleteMin :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> trie map k a +deleteMin = snd . minView + +-- O(m) +deleteMax :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> trie map k a +deleteMax = snd . maxView + +-- O(min(m,s)) +split :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] -> trie map k a -> (trie map k a, trie map k a) +split xs tr = let (l,_,g) = splitLookup xs tr in (l,g) + +-- O(min(m,s)) +splitLookup :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] + -> trie map k a + -> (trie map k a, st a, trie map k a) +splitLookup [] tr = (empty, tVal tr, mkTrie altEmpty (tMap tr)) +splitLookup (x:xs) tr = + let (v,m) = tParts tr + (ml, subTr, mg) = Map.splitLookup x m + in case subTr of + Nothing -> (mkTrie v ml, altEmpty, mkTrie altEmpty mg) + Just tr' -> + let (tl, v', tg) = splitLookup xs tr' + ml' = if null tl then ml else Map.insert x tl ml + mg' = if null tg then mg else Map.insert x tg mg + in (mkTrie v ml', v', mkTrie altEmpty mg') + +-- O(m) +findPredecessor :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] -> trie map k a -> Maybe ([k], a) +findPredecessor _ tr | null tr = Nothing +findPredecessor xs_ tr_ = go xs_ tr_ + where + go [] _ = Nothing + + -- We need to try the trie at x and then the trie at the predecessor of x: + -- e.g. if looking for "foo", we need to try any 'f' branch to see if it has + -- "fob" first, before grabbing the next-best option of the maximum of the + -- 'b' branch, say "bar". + -- + -- If there's no branch less than 'f' we try the current position as a last + -- resort. + go (x:xs) tr = + let (v,m) = tParts tr + predecessor = Map.findPredecessor x m + in fmap (first (x:)) (Map.lookup x m >>= go xs) + <|> + case predecessor of + Nothing -> + if hasValue v + then Just ([], unwrap v) + else Nothing + Just (best,btr) -> fmap (first (best:)) (findMax btr) + +-- O(m) +findSuccessor :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] -> trie map k a -> Maybe ([k], a) +findSuccessor _ tr | null tr = Nothing +findSuccessor xs_ tr_ = go xs_ tr_ + where + go [] tr = do (k,t) <- fst . Map.minViewWithKey . tMap $ tr + fmap (first (k:)) (findMin t) + + go (x:xs) tr = + let m = tMap tr + successor = Map.findSuccessor x m + in fmap (first (x:)) (Map.lookup x m >>= go xs) + <|> + (successor >>= \(best,btr) -> fmap (first (best:)) (findMin btr)) + +-- * Trie-only operations + +-- O(s) +addPrefix :: (Alt st a, Trie trie st map k) + => [k] -> trie map k a -> trie map k a +addPrefix [] = id +addPrefix (x:xs) = mkTrie altEmpty . Map.singleton x . addPrefix xs + +-- O(m) +deletePrefix :: (Alt st a, Trie trie st map k) + => [k] -> trie map k a -> trie map k a +deletePrefix [] tr = tr +deletePrefix (x:xs) tr = + case Map.lookup x (tMap tr) of + Nothing -> empty + Just tr' -> deletePrefix xs tr' + +-- O(m) +splitPrefix :: (Alt st a, Trie trie st map k) + => trie map k a -> ([k], st a, trie map k a) +splitPrefix = go DL.empty + where + go xs tr = + case Map.singletonView (tMap tr) of + Just (x,tr') -> go (xs `DL.snoc` x) tr' + Nothing -> let (v,m) = tParts tr + in (DL.toList xs, v, mkTrie altEmpty m) + +-- O(m) +children :: (Boolable (st a), Trie trie st map k) + => trie map k a -> [(k, trie map k a)] +children tr = let (v,m) = tParts tr + in if hasValue v + then Map.toList m + else case Map.singletonView m of + Just (_, tr') -> children tr' + Nothing -> Map.toList m + +-- * Visualization + +-- O(n m) +showTrieWith :: (Show k, Trie trie st map k) + => (st a -> ShowS) -> trie map k a -> ShowS +showTrieWith = go 0 + where + go indent f tr = + let (v,m) = tParts tr + sv = f v + lv = length (sv []) + in sv . showChar ' ' + . (foldr (.) id . zipWith (flip ($)) (False : repeat True) $ + map (\(k,t) -> \b -> let sk = shows k + lk = length (sk []) + i = indent + lv + 1 + in (if b + then showChar '\n' + . showString (replicate i ' ') + else id) + . showString "-> " + . sk . showChar ' ' + . go (i + lk + 4) f t) + (Map.toList m)) diff --git a/Data/ListTrie/Base/Classes.hs b/Data/ListTrie/Base/Classes.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Base/Classes.hs @@ -0,0 +1,100 @@ +-- File created: 2008-12-27 20:53:49 + +-- Various type classes to make both (Maybe a) and (Identity Bool) work +-- wherever we need them. + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies + , FlexibleInstances #-} + +module Data.ListTrie.Base.Classes where + +import qualified Control.Applicative as A +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM2) +import Data.Maybe (fromJust, isJust) + +-- Funky instances for this type are marked with **FUNKY** +newtype Identity a = Id a + +class Unwrappable w where unwrap :: w a -> a +class Boolable b where toBool :: b -> Bool + +instance Unwrappable Maybe where unwrap = fromJust +instance Boolable (Maybe a) where toBool = isJust + +instance Unwrappable Identity where unwrap (Id a) = a +instance Boolable (Identity Bool) where toBool = unwrap + +class Unionable v a where + unionVals :: (a -> a -> a) -> v a -> v a -> v a + unionVals' :: (a -> a -> a) -> v a -> v a -> v a +class Differentiable v a b where + differenceVals :: (a -> b -> Maybe a) -> v a -> v b -> v a +class Intersectable v a b c where + intersectionVals :: (a -> b -> c) -> v a -> v b -> v c + intersectionVals' :: (a -> b -> c) -> v a -> v b -> v c + +instance Unionable Maybe a where + unionVals f (Just a) (Just b) = Just (f a b) + unionVals _ Nothing mb = mb + unionVals _ ma _ = ma + + unionVals' f (Just a) (Just b) = Just $! f a b + unionVals' _ Nothing mb = mb + unionVals' _ ma _ = ma + +instance Differentiable Maybe a b where + differenceVals f (Just a) (Just b) = f a b + differenceVals _ ma _ = ma + +instance Intersectable Maybe a b c where + intersectionVals = liftM2 + + intersectionVals' f (Just a) (Just b) = Just $! f a b + intersectionVals' _ _ _ = Nothing + +-- The other option with the following three would have been to just call f +-- (and, in the case of Differentiable, fromJust) and trust that it's correct. +-- I think this way is safer. Bottoms are passed to Base.unionWith etc. + +-- **FUNKY** +instance Unionable Identity Bool where + unionVals _ (Id a) (Id b) = Id$ a || b + unionVals' = error "Data.ListTrie.Base.Classes.unionVals' :: internal error" + +-- **FUNKY** +instance Differentiable Identity Bool Bool where + differenceVals _ (Id a) (Id b) = Id$ a && not b + +-- **FUNKY** +instance Intersectable Identity Bool Bool Bool where + intersectionVals _ (Id a) (Id b) = Id$ a && b + intersectionVals' = + error "Data.ListTrie.Base.Classes.intersectionVals' :: internal error" + +class Applicative a => Alt a x where + altEmpty :: a x + (<|>) :: a x -> a x -> a x + +instance Functor Identity where + fmap f (Id a) = Id (f a) + +instance Applicative Identity where + pure = Id + Id f <*> Id a = Id (f a) + +instance Alt Maybe a where + altEmpty = A.empty + (<|>) = (A.<|>) + +instance Alt Identity Bool where + altEmpty = Id False + Id a <|> Id b = Id (a || b) + +fmap', (<$!>) :: (Boolable (f a), Unwrappable f, Alt f b) + => (a -> b) -> f a -> f b +fmap' f ax = if toBool ax + then pure $! f (unwrap ax) + else altEmpty + +(<$!>) = fmap' diff --git a/Data/ListTrie/Base/Map.hs b/Data/ListTrie/Base/Map.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Base/Map.hs @@ -0,0 +1,522 @@ +-- File created: 2008-11-07 17:30:16 + +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances #-} + +module Data.ListTrie.Base.Map + ( Map(..), OrdMap(..) + , AList, WrappedIntMap + ) where + +import Control.Applicative (pure, (<*>)) +import Control.Arrow ((***), first, second) +import Control.Monad (liftM, liftM2) +import Data.Foldable (Foldable(..)) +import Data.Function (on) +import Data.List ( foldl1' + , mapAccumL, nubBy, partition + , sort, sortBy + ) +import Data.Ord (comparing) +import Data.Traversable (Traversable(..), mapAccumR) +import qualified Data.IntMap as IM +import qualified Data.Map as M + +import Prelude hiding ( foldl,foldl1,foldr,foldr1 + , mapM,sequence + , null,lookup,filter -- for Haddock + ) +import qualified Prelude + +import Data.ListTrie.Util (both, (.:)) + +#ifdef MIN_VERSION_containers -- from Cabal +# if !(MIN_VERSION_containers(0,3,0)) +# define TOO_OLD_CONTAINERS +# endif +#else +#define TOO_OLD_CONTAINERS +#endif + +-- | Minimal complete implementation: +-- +-- * 'eqCmp' +-- +-- * 'null' +-- +-- * 'lookup' +-- +-- * 'alter' +-- +-- * 'unionWithKey', 'differenceWithKey', 'intersectionWithKey' +-- +-- * 'toList' +-- +-- * 'empty' or 'fromList' or 'fromListWith' +-- +-- * 'isSubmapOfBy' +-- +-- For decent performance, supplying at least 'mapAccumWithKey' and 'filter' as +-- well is probably a good idea. +class Foldable (m k) => Map m k where + -- | Like an 'Eq' instance over k, but should compare on the same type as + -- @m@ does. In most cases this can be defined just as @const (==)@. + eqCmp :: m k a -> k -> k -> Bool + + empty :: m k a + singleton :: k -> a -> m k a + -- | Precondition: the two keys differ + doubleton :: k -> a -> k -> a -> m k a + + null :: m k a -> Bool + lookup :: k -> m k a -> Maybe a + + -- | Strictness can be whatever is more optimal for the map type, shouldn't + -- matter + insertWith :: (a -> a -> a) -> k -> a -> m k a -> m k a + insert :: k -> a -> m k a -> m k a + + update :: (a -> Maybe a) -> k -> m k a -> m k a + adjust :: (a -> a) -> k -> m k a -> m k a + delete :: k -> m k a -> m k a + + alter :: (Maybe a -> Maybe a) -> k -> m k a -> m k a + + unionWith :: (a -> a -> a) -> m k a -> m k a -> m k a + differenceWith :: (a -> b -> Maybe a) -> m k a -> m k b -> m k a + intersectionWith :: (a -> b -> c) -> m k a -> m k b -> m k c + unionWithKey :: (k -> a -> a -> a) -> m k a -> m k a -> m k a + differenceWithKey :: (k -> a -> b -> Maybe a) -> m k a -> m k b -> m k a + intersectionWithKey :: (k -> a -> b -> c) -> m k a -> m k b -> m k c + + map :: (a -> b) -> m k a -> m k b + mapWithKey :: (k -> a -> b) -> m k a -> m k b + mapAccum :: (a -> b -> (a,c)) -> a -> m k b -> (a, m k c) + mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> m k b -> (a, m k c) + + filter :: (a -> Bool) -> m k a -> m k a + + toList :: m k a -> [(k,a)] + fromList :: [(k,a)] -> m k a + fromListWith :: (a -> a -> a) -> [(k,a)] -> m k a + + isSubmapOfBy :: (a -> b -> Bool) -> m k a -> m k b -> Bool + + singletonView :: m k a -> Maybe (k,a) + + empty = fromList [] + singleton k v = insert k v empty + doubleton k v = insert k v .: singleton + + insert = insertWith const + insertWith f k v = alter (\mold -> Just $ case mold of + Nothing -> v + Just old -> f v old) + k + + adjust f = update (Just . f) + delete = update (const Nothing) + update f = alter (f =<<) + + unionWith = unionWithKey . const + differenceWith = differenceWithKey . const + intersectionWith = intersectionWithKey . const + + map = mapWithKey . const + mapWithKey f = snd . mapAccumWithKey (\_ k v -> ((), f k v)) () + mapAccum f = mapAccumWithKey (const . f) + mapAccumWithKey f z = + second fromList . + mapAccumL (\a (k,v) -> fmap ((,) k) (f a k v)) z . + toList + + filter p = fromList . Prelude.filter (p . snd) . toList + + -- | Should be strict in the keys + fromList = fromListWith const + fromListWith f = foldr (uncurry $ insertWith f) empty + + singletonView m = + case toList m of + [x] -> Just x + _ -> Nothing + +-- | Minimal complete definition: +-- +-- * 'ordCmp' +-- +-- * 'toAscList' or 'toDescList' +-- +-- * 'splitLookup' +-- +-- For decent performance, supplying at least the following is probably a good +-- idea: +-- +-- * 'minViewWithKey', 'maxViewWithKey' +-- +-- * 'mapAccumAscWithKey', 'mapAccumDescWithKey' +class Map m k => OrdMap m k where + -- | Like an Ord instance over k, but should compare on the same type as @m@ + -- does. In most cases this can be defined just as @const compare@. + ordCmp :: m k a -> k -> k -> Ordering + + toAscList :: m k a -> [(k,a)] + toDescList :: m k a -> [(k,a)] + + splitLookup :: k -> m k a -> (m k a, Maybe a, m k a) + split :: k -> m k a -> (m k a, m k a) + + minViewWithKey :: m k a -> (Maybe (k,a), m k a) + maxViewWithKey :: m k a -> (Maybe (k,a), m k a) + + findPredecessor :: k -> m k a -> Maybe (k,a) + findSuccessor :: k -> m k a -> Maybe (k,a) + + mapAccumAsc :: (a -> b -> (a,c)) -> a -> m k b -> (a, m k c) + mapAccumAscWithKey :: (a -> k -> b -> (a,c)) -> a -> m k b -> (a, m k c) + mapAccumDesc :: (a -> b -> (a,c)) -> a -> m k b -> (a, m k c) + mapAccumDescWithKey :: (a -> k -> b -> (a,c)) -> a -> m k b -> (a, m k c) + + toAscList = reverse . toDescList + toDescList = reverse . toAscList + + split m k = let (a,_,b) = splitLookup m k in (a,b) + + minViewWithKey m = + case toAscList m of + [] -> (Nothing, m) + (x:xs) -> (Just x, fromList xs) + + maxViewWithKey m = + case toDescList m of + [] -> (Nothing, m) + (x:xs) -> (Just x, fromList xs) + + findPredecessor m = fst . maxViewWithKey . fst . split m + findSuccessor m = fst . minViewWithKey . snd . split m + + mapAccumAsc f = mapAccumAscWithKey (const . f) + mapAccumDesc f = mapAccumDescWithKey (const . f) + mapAccumAscWithKey f z = + second fromList . + mapAccumL (\a (k,v) -> fmap ((,) k) (f a k v)) z . + toAscList + mapAccumDescWithKey f z = + second fromList . + mapAccumL (\a (k,v) -> fmap ((,) k) (f a k v)) z . + toDescList + +------------- Instances + +newtype AList k v = AL [(k,v)] + +-- AList has to be ordering-ignorant +instance (Eq k, Eq v) => Eq (AList k v) where + AL [] == AL ys = Prelude.null ys + AL (x:xs) == AL ys = + let (my,ys') = deleteAndGetBy (==x) ys + in case my of + Nothing -> False + Just _ -> AL xs == AL ys' + +instance (Ord k, Ord v) => Ord (AList k v) where + compare (AL xs) (AL ys) = compare (sort xs) (sort ys) + +instance Functor (AList k) where fmap f (AL xs) = AL (fmap (second f) xs) +instance Foldable (AList k) where + fold (AL xs) = fold (Prelude.map snd xs) + foldMap f (AL xs) = foldMap f (Prelude.map snd xs) + foldl f z (AL xs) = foldl f z (Prelude.map snd xs) + foldl1 f (AL xs) = foldl1 f (Prelude.map snd xs) + foldr f z (AL xs) = foldr f z (Prelude.map snd xs) + foldr1 f (AL xs) = foldr1 f (Prelude.map snd xs) + +instance Traversable (AList k) where + traverse f (AL xs) = + fmap AL . traverse (liftM2 fmap ((,).fst) snd . second f) $ xs + +instance Eq k => Map AList k where + eqCmp = const (==) + + empty = AL [] + singleton k v = AL [(k,v)] + doubleton a b p q = AL [(a,b),(p,q)] + + null (AL xs) = Prelude.null xs + lookup x (AL xs) = Prelude.lookup x xs + + alter f k (AL xs) = + let (old, ys) = deleteAndGetBy ((== k).fst) xs + in case f (fmap snd old) of + Nothing -> AL ys + Just v -> AL $ (k,v) : ys + + delete k (AL xs) = AL$ deleteBy (\a (b,_) -> a == b) k xs + + unionWithKey f (AL xs) (AL ys) = + AL . uncurry (++) $ updateFirstsBy (\(k,x) (_,y) -> Just (k, f k x y)) + ((==) `on` fst) + xs ys + + differenceWithKey f (AL xs) (AL ys) = + AL . fst $ updateFirstsBy (\(k,x) (_,y) -> fmap ((,) k) (f k x y)) + (\x y -> fst x == fst y) + xs ys + + intersectionWithKey f_ (AL xs_) (AL ys_) = AL$ go f_ xs_ ys_ + where + go _ [] _ = [] + go f ((k,x):xs) ys = + let (my,ys') = deleteAndGetBy ((== k).fst) ys + in case my of + Just (_,y) -> (k, f k x y) : go f xs ys' + Nothing -> go f xs ys + + mapWithKey f (AL xs) = AL $ Prelude.map (\(k,v) -> (k, f k v)) xs + + mapAccumWithKey f z (AL xs) = + second AL $ mapAccumL (\a (k,v) -> let (a',v') = f a k v + in (a', (k, v'))) + z xs + + toList (AL xs) = xs + fromList = AL . nubBy ((==) `on` fst) + fromListWith = AL .: go + where + go _ [] = [] + go f (x:xs) = + -- We add some extra strictness here to match the other map types + -- (strict in key even for singletons) and because we don't need the + -- laziness (strict in value) + let (as,bs) = partition (((==) `on` fst) x) xs + v = foldl1' f . Prelude.map snd $ x:as + in fst x `seq` v `seq` ((fst x, v) : go f bs) + + isSubmapOfBy f_ (AL xs_) (AL ys_) = go f_ xs_ ys_ + where + go _ [] _ = True + go f ((k,x):xs) ys = + let (my,ys') = deleteAndGetBy ((== k).fst) ys + in case my of + Just (_,y) -> f x y && go f xs ys' + Nothing -> False + +instance Ord k => OrdMap AList k where + ordCmp = const compare + + toAscList = sortBy ( comparing fst) . toList + toDescList = sortBy (flip $ comparing fst) . toList + + splitLookup k (AL xs) = + let (ls,gs) = partition ((< k).fst) xs + (mx,gs') = deleteAndGetBy ((== k).fst) gs + in (AL ls, fmap snd mx, AL gs') + +deleteAndGetBy :: (a -> Bool) -> [a] -> (Maybe a, [a]) +deleteAndGetBy = go [] + where + go ys _ [] = (Nothing, ys) + go ys p (x:xs) = + if p x + then (Just x, xs ++ ys) + else go (x:ys) p xs + +-- This is from Data.List, just with a more general type signature... +deleteBy :: (a -> b -> Bool) -> a -> [b] -> [b] +deleteBy _ _ [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +updateFirstsBy :: (a -> b -> Maybe a) + -> (a -> b -> Bool) + -> [a] + -> [b] + -> ([a],[b]) +updateFirstsBy _ _ [] ys = ([],ys) +updateFirstsBy f eq (x:xs) ys = + let (my,ys') = deleteAndGetBy (eq x) ys + in case my of + Nothing -> first (x:) $ updateFirstsBy f eq xs ys + Just y -> + case f x y of + Just z -> first (z:) $ updateFirstsBy f eq xs ys' + Nothing -> updateFirstsBy f eq xs ys' + +instance Ord k => Map M.Map k where + eqCmp = const (==) + + empty = M.empty + singleton = M.singleton + + null = M.null + lookup = M.lookup + + insertWith = M.insertWith' + + update = M.update + adjust = M.adjust + delete = M.delete + + alter = M.alter + + unionWith = M.unionWith + differenceWith = M.differenceWith + intersectionWith = M.intersectionWith + unionWithKey = M.unionWithKey + differenceWithKey = M.differenceWithKey + intersectionWithKey = M.intersectionWithKey + + map = M.map + mapWithKey = M.mapWithKey + mapAccum = M.mapAccum + mapAccumWithKey = M.mapAccumWithKey + + filter = M.filter + + toList = M.toList + fromList = M.fromList + fromListWith = M.fromListWith + + isSubmapOfBy = M.isSubmapOfBy + + singletonView m = + case M.minViewWithKey m of + Just (a,others) | M.null others -> Just a + _ -> Nothing + +instance Ord k => OrdMap M.Map k where + ordCmp = const compare + + toAscList = M.toAscList + + splitLookup = M.splitLookup + split = M.split + + minViewWithKey m = maybe (Nothing, m) (first Just) (M.minViewWithKey m) + maxViewWithKey m = maybe (Nothing, m) (first Just) (M.maxViewWithKey m) + + mapAccumAsc = M.mapAccum + mapAccumAscWithKey = M.mapAccumWithKey + mapAccumDesc = mapAccumR +#ifdef TOO_OLD_CONTAINERS + mapAccumDescWithKey f z = + second M.fromList . mapAccumR (\a (k,v) -> second ((,) k) $ f a k v) z + . M.toAscList +#else + mapAccumDescWithKey = M.mapAccumRWithKey +#endif + +newtype WrappedIntMap k v = IMap (IM.IntMap v) deriving (Eq,Ord) + +instance Functor (WrappedIntMap k) where fmap f (IMap m) = IMap (fmap f m) +instance Foldable (WrappedIntMap k) where + fold (IMap m) = fold m + foldMap f (IMap m) = foldMap f m + foldl f z (IMap m) = foldl f z m + foldl1 f (IMap m) = foldl1 f m + foldr f z (IMap m) = foldr f z m + foldr1 f (IMap m) = foldr1 f m + +instance Traversable (WrappedIntMap k) where +#ifdef TOO_OLD_CONTAINERS + traverse = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap" + sequenceA = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap" + mapM = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap" + sequence = error "Data.ListTrie.Base.Map :: too old containers, no Traversable IntMap" +#else + traverse f (IMap m) = pure IMap <*> traverse f m + sequenceA (IMap m) = pure IMap <*> sequenceA m + mapM f (IMap m) = liftM IMap (mapM f m) + sequence (IMap m) = liftM IMap (sequence m) +#endif + +instance Enum k => Map WrappedIntMap k where + eqCmp = const ((==) `on` fromEnum) + + empty = IMap IM.empty + singleton k = IMap . IM.singleton (fromEnum k) + + null (IMap m) = IM.null m + lookup k (IMap m) = IM.lookup (fromEnum k) m + + insertWith f k v (IMap m) = IMap$ IM.insertWith f (fromEnum k) v m + + update f k (IMap m) = IMap$ IM.update f (fromEnum k) m + adjust f k (IMap m) = IMap$ IM.adjust f (fromEnum k) m + delete k (IMap m) = IMap$ IM.delete (fromEnum k) m + + alter f k (IMap m) = IMap$ IM.alter f (fromEnum k) m + + unionWith f (IMap x) (IMap y) = IMap$ IM.unionWith f x y + differenceWith f (IMap x) (IMap y) = IMap$ IM.differenceWith f x y + +#ifdef TOO_OLD_CONTAINERS + intersectionWith = + error "Data.ListTrie.Base.Map :: too old containers, Data.IntMap.intersectionWith has restricted type" +#else + intersectionWith f (IMap x) (IMap y) = IMap$ IM.intersectionWith f x y +#endif + + unionWithKey f (IMap x) (IMap y) = + IMap$ IM.unionWithKey (f . toEnum) x y + differenceWithKey f (IMap x) (IMap y) = + IMap$ IM.differenceWithKey (f . toEnum) x y + +#ifdef TOO_OLD_CONTAINERS + intersectionWithKey = + error "Data.ListTrie.Base.Map :: too old containers, Data.IntMap.intersectionWithKey has restricted type" +#else + intersectionWithKey f (IMap x) (IMap y) = + IMap$ IM.intersectionWithKey (f . toEnum) x y +#endif + + map f (IMap x) = IMap$ IM.map f x + mapWithKey f (IMap x) = IMap$ IM.mapWithKey (f . toEnum) x + mapAccum f z (IMap x) = second IMap$ IM.mapAccum f z x + mapAccumWithKey f z (IMap x) = + second IMap$ IM.mapAccumWithKey (\a -> f a . toEnum) z x + + filter p (IMap x) = IMap $ IM.filter p x + + toList (IMap m) = Prelude.map (first toEnum) . IM.toList $ m + fromList = IMap . IM.fromList . Prelude.map (first fromEnum) + fromListWith f = IMap . IM.fromListWith f . Prelude.map (first fromEnum) + + isSubmapOfBy f (IMap x) (IMap y) = IM.isSubmapOfBy f x y + + singletonView (IMap m) = + case IM.minViewWithKey m of + Just (a,others) | IM.null others -> Just (first toEnum a) + _ -> Nothing + +instance Enum k => OrdMap WrappedIntMap k where + ordCmp = const (compare `on` fromEnum) + + toAscList (IMap m) = Prelude.map (first toEnum) . IM.toAscList $ m + + splitLookup k (IMap m) = + (\(a,b,c) -> (IMap a, b, IMap c)) . IM.splitLookup (fromEnum k) $ m + + split k (IMap m) = both IMap . IM.split (fromEnum k) $ m + + minViewWithKey o@(IMap m) = + maybe (Nothing, o) (Just . first toEnum *** IMap) (IM.minViewWithKey m) + maxViewWithKey o@(IMap m) = + maybe (Nothing, o) (Just . first toEnum *** IMap) (IM.maxViewWithKey m) + + mapAccumAsc f z (IMap m) = second IMap $ IM.mapAccum f z m + mapAccumAscWithKey f z (IMap m) = + second IMap $ IM.mapAccumWithKey (\a k -> f a (toEnum k)) z m + +#ifdef TOO_OLD_CONTAINERS + mapAccumDesc f z (IMap m) = + second (IMap . IM.fromList) + . mapAccumR (\a (k,v) -> second ((,) k) $ f a v) z + . IM.toAscList $ m + mapAccumDescWithKey f z (IMap m) = + second (IMap . IM.fromList) + . mapAccumR (\a (k,v) -> second ((,) k) $ f a (toEnum k) v) z + . IM.toAscList $ m +#else + mapAccumDesc f z (IMap m) = second IMap $ mapAccumR f z m + mapAccumDescWithKey f z (IMap m) = + second IMap $ IM.mapAccumRWithKey (\a k -> f a (toEnum k)) z m +#endif diff --git a/Data/ListTrie/Base/Map/Internal.hs b/Data/ListTrie/Base/Map/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Base/Map/Internal.hs @@ -0,0 +1,12 @@ +-- File created: 2009-03-06 12:40:42 + +-- Base.Map plus stuff we don't want to export +module Data.ListTrie.Base.Map.Internal + (module Data.ListTrie.Base.Map, difference) where + +import Data.ListTrie.Base.Map + +-- Moved this outside Map because it's an odd one out: union and intersection +-- aren't needed +difference :: Map m k => m k a -> m k b -> m k a +difference = differenceWith (\_ _ -> Nothing) diff --git a/Data/ListTrie/Map.hs b/Data/ListTrie/Map.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Map.hs @@ -0,0 +1,1033 @@ +-- File created: 2008-11-11 11:24:30 + +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances + , FlexibleContexts, UndecidableInstances #-} + +#include "exports.h" + +-- | The base implementation of a trie representing a map with list keys, +-- generalized over any type of map from element values to tries. +-- +-- Worst-case complexities are given in terms of @n@, @m@, and @k@. @n@ refers +-- to the number of keys in the map and @m@ to their maximum length. @k@ refers +-- to the length of a key given to the function, not any property of the map. +-- +-- In addition, the trie's branching factor plays a part in almost every +-- operation, but the complexity depends on the underlying 'Map'. Thus, for +-- instance, 'member' is actually @O(m f(b))@ where @f(b)@ is the complexity of +-- a lookup operation on the 'Map' used. This complexity depends on the +-- underlying operation, which is not part of the specification of the visible +-- function. Thus it could change whilst affecting the complexity only for +-- certain Map types: hence this \"b factor\" is not shown explicitly. +-- +-- Disclaimer: the complexities have not been proven. +-- +-- Strict versions of functions are provided for those who want to be certain +-- that their 'TrieMap' doesn't contain values consisting of unevaluated +-- thunks. Note, however, that they do not evaluate the whole trie strictly, +-- only the values. And only to one level of depth: for instance, 'alter'' does +-- not 'seq' the value within the 'Maybe', only the 'Maybe' itself. The user +-- should add the strictness in such cases himself, if he so wishes. +-- +-- Many functions come in both ordinary and @WithKey@ forms, where the former +-- takes a function of type @a -> b@ and the latter of type @[k] -> a -> b@, +-- where @[k]@ is the key associated with the value @a@. For most of these +-- functions, there is additional overhead involved in keeping track of the +-- key: don't use the latter form of the function unless you need it. +module Data.ListTrie.Map (MAP_EXPORTS) where + +import Control.Applicative ((<*>),(<$>)) +import Control.Arrow ((***), second) +import qualified Data.DList as DL +import Data.Either (partitionEithers) +import Data.Function (on) +import qualified Data.Foldable as F +import qualified Data.Maybe as Maybe +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (filter, foldl, foldr, lookup, map, null) +import qualified Prelude + +#if __GLASGOW_HASKELL__ +import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) +#endif + +import qualified Data.ListTrie.Base as Base +import qualified Data.ListTrie.Base.Map as Map +import Data.ListTrie.Base.Classes (fmap') +import Data.ListTrie.Base.Map (Map, OrdMap) + +#include "docs.h" + +-- Invariant: any (Tr Nothing _) has a Just descendant. +-- +-- | The data structure itself: a map from keys of type @[k]@ to values of type +-- @v@ implemented as a trie, using @map@ to map keys of type @k@ to sub-tries. +-- +-- Regarding the instances: +-- +-- - The @Trie@ class is internal, ignore it. +-- +-- - The 'Eq' constraint for the 'Ord' instance is misleading: it is needed +-- only because 'Eq' is a superclass of 'Ord'. +-- +-- - The 'Foldable' and 'Traversable' instances allow folding over and +-- traversing only the values, not the keys. +-- +-- - The 'Monoid' instance defines 'mappend' as 'union' and 'mempty' as +-- 'empty'. +data TrieMap map k v = Tr (Maybe v) !(CMap map k v) + +type CMap map k v = map k (TrieMap map k v) + +instance Map map k => Base.Trie TrieMap Maybe map k where + mkTrie = Tr + tParts (Tr v m) = (v,m) + +-- Don't use CMap in these instances since Haddock won't expand it +instance (Eq (map k (TrieMap map k a)), Eq a) => Eq (TrieMap map k a) where + Tr v1 m1 == Tr v2 m2 = v1 == v2 && m1 == m2 + +-- Eq constraint only needed because of superclassness... sigh +instance (Eq (map k (TrieMap map k a)), OrdMap map k, Ord k, Ord a) + => Ord (TrieMap map k a) + where + compare = compare `on` toAscList + +instance Map map k => Monoid (TrieMap map k a) where + mempty = empty + mappend = union + mconcat = unions + +instance Map map k => Functor (TrieMap map k) where + fmap = map + +instance Map map k => F.Foldable (TrieMap map k) where + foldl = foldl . flip + foldr = foldr + +instance (Map map k, Traversable (map k)) => Traversable (TrieMap map k) where + traverse f (Tr v m) = Tr <$> traverse f v <*> traverse (traverse f) m + +instance (Map map k, Show k, Show a) => Show (TrieMap map k a) where + showsPrec p s = showParen (p > 10) $ + showString "fromList " . shows (toList s) + +instance (Map map k, Read k, Read a) => Read (TrieMap map k a) where +#if __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + fmap fromList readPrec +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList", list) <- lex r + (xs, rest) <- readsPrec (p+1) list + [(fromList xs, rest)] +#endif + +-- * Construction + +-- | @O(1)@. The empty map. +empty :: Map map k => TrieMap map k a +empty = Base.empty + +-- | @O(s)@. The singleton map containing only the given key-value pair. +singleton :: Map map k => [k] -> a -> TrieMap map k a +singleton = Base.singleton + +-- * Modification + +-- | @O(min(m,s))@. Inserts the key-value pair into the map. If the key is +-- already a member of the map, the given value replaces the old one. +insert :: Map map k => [k] -> a -> TrieMap map k a -> TrieMap map k a +insert = Base.insert + +-- | @O(min(m,s))@. Inserts the key-value pair into the map. If the key is +-- already a member of the map, the given value replaces the old one. +insert' :: Map map k => [k] -> a -> TrieMap map k a -> TrieMap map k a +insert' = Base.insert' + +-- | @O(min(m,s))@. Inserts the key-value pair into the map. If the key is +-- already a member of the map, the old value is replaced by @f givenValue +-- oldValue@ where @f@ is the given function. +insertWith :: Map map k + => (a -> a -> a) -> [k] -> a -> TrieMap map k a -> TrieMap map k a +insertWith = Base.insertWith + +-- | @O(min(m,s))@. Like 'insertWith', but the new value is reduced to weak +-- head normal form before being placed into the map, whether it is the given +-- value or a result of the combining function. +insertWith' :: Map map k + => (a -> a -> a) -> [k] -> a -> TrieMap map k a -> TrieMap map k a +insertWith' = Base.insertWith' + +-- | @O(min(m,s))@. Removes the key from the map along with its associated +-- value. If the key is not a member of the map, the map is unchanged. +delete :: Map map k => [k] -> TrieMap map k a -> TrieMap map k a +delete = Base.delete + +-- | @O(min(m,s))@. Adjusts the value at the given key by calling the given +-- function on it. If the key is not a member of the map, the map is unchanged. +adjust :: Map map k => (a -> a) -> [k] -> TrieMap map k a -> TrieMap map k a +adjust = Base.adjust + +-- | @O(min(m,s))@. Like 'adjust', but the function is applied strictly. +adjust' :: Map map k => (a -> a) -> [k] -> TrieMap map k a -> TrieMap map k a +adjust' = Base.adjust' + +-- | @O(min(m,s))@. Updates the value at the given key: if the given +-- function returns 'Nothing', the value and its associated key are removed; if +-- 'Just'@ a@is returned, the old value is replaced with @a@. If the key is +-- not a member of the map, the map is unchanged. +update :: Map map k + => (a -> Maybe a) -> [k] -> TrieMap map k a -> TrieMap map k a +update f k = snd . updateLookup f k + +-- | @O(min(m,s))@. Like 'update', but also returns 'Just' the original value, +-- or 'Nothing' if the key is not a member of the map. +updateLookup :: Map map k => (a -> Maybe a) + -> [k] + -> TrieMap map k a + -> (Maybe a, TrieMap map k a) +updateLookup = Base.updateLookup + +-- | @O(min(m,s))@. The most general modification function, allowing you to +-- modify the value at the given key, whether or not it is a member of the map. +-- In short: the given function is passed 'Just' the value at the key if it is +-- present, or 'Nothing' otherwise; if the function returns 'Just' a value, the +-- new value is inserted into the map, otherwise the old value is removed. More +-- precisely, for @alter f k m@: +-- +-- If @k@ is a member of @m@, @f (@'Just'@ oldValue)@ is called. Now: +-- +-- - If @f@ returned 'Just'@ newValue@, @oldValue@ is replaced with @newValue@. +-- +-- - If @f@ returned 'Nothing', @k@ and @oldValue@ are removed from the map. +-- +-- If, instead, @k@ is not a member of @m@, @f @'Nothing' is called, and: +-- +-- - If @f@ returned 'Just'@ value@, @value@ is inserted into the map, at @k@. +-- +-- - If @f@ returned 'Nothing', the map is unchanged. +-- +-- The function is applied lazily only if the given key is a prefix of another +-- key in the map. +alter :: Map map k + => (Maybe a -> Maybe a) -> [k] -> TrieMap map k a -> TrieMap map k a +alter = Base.alter + +-- | @O(min(m,s))@. Like 'alter', but the function is always applied strictly. +alter' :: Map map k + => (Maybe a -> Maybe a) -> [k] -> TrieMap map k a -> TrieMap map k a +alter' = Base.alter' + +-- * Querying + +-- | @O(1)@. 'True' iff the map is empty. +null :: Map map k => TrieMap map k a -> Bool +null = Base.null + +-- | @O(n m)@. The number of elements in the map. The value is built up lazily, +-- allowing for delivery of partial results without traversing the whole map. +size :: (Map map k, Num n) => TrieMap map k a -> n +size = Base.size + +-- | @O(n m)@. The number of elements in the map. The value is built strictly: +-- no value is returned until the map has been fully traversed. +size' :: (Map map k, Num n) => TrieMap map k a -> n +size' = Base.size' + +-- | @O(min(m,s))@. 'True' iff the given key is associated with a value in the +-- map. +member :: Map map k => [k] -> TrieMap map k a -> Bool +member = Base.member + +-- | @O(min(m,s))@. 'False' iff the given key is associated with a value in the +-- map. +notMember :: Map map k => [k] -> TrieMap map k a -> Bool +notMember = Base.notMember + +-- | @O(min(m,s))@. 'Just' the value in the map associated with the given key, +-- or 'Nothing' if the key is not a member of the map. +lookup :: Map map k => [k] -> TrieMap map k a -> Maybe a +lookup = Base.lookup + +-- | @O(min(m,s))@. Like 'lookup', but returns the given value when the key is +-- not a member of the map. +lookupWithDefault :: Map map k => a -> [k] -> TrieMap map k a -> a +lookupWithDefault = Base.lookupWithDefault + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first map is a submap of the second, +-- i.e. all keys that are members of the first map are also members of the +-- second map, and their associated values are the same. +-- +-- > isSubmapOf = isSubmapOfBy (==) +isSubmapOf :: (Map map k, Eq a) => TrieMap map k a -> TrieMap map k a -> Bool +isSubmapOf = isSubmapOfBy (==) + +-- | @O(min(n1 m1,n2 m2))@. Like 'isSubmapOf', but one can specify the equality +-- relation applied to the values. +-- +-- 'True' iff all keys that are members of the first map are also members of +-- the second map, and the given function @f@ returns 'True' for all @f +-- firstMapValue secondMapValue@ where @firstMapValue@ and @secondMapValue@ are +-- associated with the same key. +isSubmapOfBy :: Map map k + => (a -> b -> Bool) -> TrieMap map k a -> TrieMap map k b -> Bool +isSubmapOfBy = Base.isSubmapOfBy + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first map is a proper submap of the +-- second, i.e. all keys that are members of the first map are also members of +-- the second map, and their associated values are the same, but the maps are +-- not equal. That is, at least one key was a member of the second map but not +-- the first. +-- +-- > isProperSubmapOf = isProperSubmapOfBy (==) +isProperSubmapOf :: (Map map k, Eq a) + => TrieMap map k a -> TrieMap map k a -> Bool +isProperSubmapOf = isProperSubmapOfBy (==) + +-- | @O(min(n1 m1,n2 m2))@. Like 'isProperSubmapOf', but one can specify the +-- equality relation applied to the values. +-- +-- 'True' iff all keys that are members of the first map are also members of +-- the second map, and the given function @f@ returns 'True' for all @f +-- firstMapValue secondMapValue@ where @firstMapValue@ and @secondMapValue@ are +-- associated with the same key, and at least one key in the second map is not +-- a member of the first. +isProperSubmapOfBy :: Map map k => (a -> b -> Bool) + -> TrieMap map k a + -> TrieMap map k b + -> Bool +isProperSubmapOfBy = Base.isProperSubmapOfBy + +-- * Combination + +defaultUnion :: a -> a -> a +defaultUnion = const + +-- | @O(min(n1 m1,n2 m2))@. The union of the two maps: the map which contains +-- all keys that are members of either map. This union is left-biased: if a key +-- is a member of both maps, the value from the first map is chosen. +-- +-- The worst-case performance occurs when the two maps are identical. +-- +-- > union = unionWith const +union :: Map map k => TrieMap map k a -> TrieMap map k a -> TrieMap map k a +union = unionWith defaultUnion + +-- | @O(min(n1 m1,n2 m2))@. Like 'union', but the combining function ('const') is +-- applied strictly. +-- +-- > union' = unionWith' const +union' :: Map map k => TrieMap map k a -> TrieMap map k a -> TrieMap map k a +union' = unionWith' defaultUnion + +-- | @O(min(n1 m1,n2 m2))@. Like 'union', but the given function is used to +-- determine the new value if a key is a member of both given maps. For a +-- function @f@, the new value is @f firstMapValue secondMapValue@. +unionWith :: Map map k => (a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWith = Base.unionWith + +-- | @O(min(n1 m1,n2 m2))@. Like 'unionWith', but the combining function is +-- applied strictly. +unionWith' :: Map map k => (a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWith' = Base.unionWith' + +-- | @O(min(n1 m1,n2 m2))@. Like 'unionWith', but in addition to the two +-- values, the key is passed to the combining function. +unionWithKey :: Map map k => ([k] -> a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWithKey = Base.unionWithKey + +-- | @O(min(n1 m1,n2 m2))@. Like 'unionWithKey', but the combining function is +-- applied strictly. +unionWithKey' :: Map map k => ([k] -> a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWithKey' = Base.unionWithKey' + +-- | @O(sum(n))@. The union of all the maps: the map which contains all keys +-- that are members of any of the maps. If a key is a member of multiple maps, +-- the value that occurs in the earliest of the maps (according to the order of +-- the given list) is chosen. +-- +-- The worst-case performance occurs when all the maps are identical. +-- +-- > unions = unionsWith const +unions :: Map map k => [TrieMap map k a] -> TrieMap map k a +unions = unionsWith defaultUnion + +-- | @O(sum(n))@. Like 'unions', but the combining function ('const') is +-- applied strictly. +-- +-- > unions' = unionsWith' const +unions' :: Map map k => [TrieMap map k a] -> TrieMap map k a +unions' = unionsWith' defaultUnion + +-- | @O(sum(n))@. Like 'unions', but the given function determines the final +-- value if a key is a member of more than one map. The function is applied as +-- a left fold over the values in the given list's order. For example: +-- +-- > unionsWith (-) [fromList [("a",1)],fromList [("a",2)],fromList [("a",3)]] +-- > == fromList [("a",(1-2)-3)] +-- > == fromList [("a",-4)] +unionsWith :: Map map k + => (a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWith = Base.unionsWith + +-- | @O(sum(n))@. Like 'unionsWith', but the combining function is applied +-- strictly. +unionsWith' :: Map map k + => (a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWith' = Base.unionsWith' + +-- | @O(sum(n))@. Like 'unionsWith', but in addition to the two values under +-- consideration, the key is passed to the combining function. +unionsWithKey :: Map map k + => ([k] -> a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWithKey = Base.unionsWithKey + +-- | @O(sum(n))@. Like 'unionsWithKey', but the combining function is applied +-- strictly. +unionsWithKey' :: Map map k + => ([k] -> a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWithKey' = Base.unionsWithKey' + +-- | @O(min(n1 m1,n2 m2))@. The difference of the two maps: the map which +-- contains all keys that are members of the first map and not of the second. +-- +-- The worst-case performance occurs when the two maps are identical. +-- +-- > difference = differenceWith (\_ _ -> Nothing) +difference :: Map map k + => TrieMap map k a -> TrieMap map k b -> TrieMap map k a +difference = differenceWith (\_ _ -> Nothing) + +-- | @O(min(n1 m1,n2 m2))@. Like 'difference', but the given function +-- determines what to do when a key is a member of both maps. If the function +-- returns 'Nothing', the key is removed; if it returns 'Just' a new value, +-- that value replaces the old one in the first map. +differenceWith :: Map map k => (a -> b -> Maybe a) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k a +differenceWith = Base.differenceWith + +-- | @O(min(n1 m1,n2 m2))@. Like 'differenceWith', but in addition to the two +-- values, the key they are associated with is passed to the combining +-- function. +differenceWithKey :: Map map k => ([k] -> a -> b -> Maybe a) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k a +differenceWithKey = Base.differenceWithKey + +-- | @O(min(n1 m1,n2 m2))@. The intersection of the two maps: the map which +-- contains all keys that are members of both maps. +-- +-- The worst-case performance occurs when the two maps are identical. +-- +-- > intersection = intersectionWith const +intersection :: Map map k + => TrieMap map k a -> TrieMap map k b -> TrieMap map k a +intersection = intersectionWith const + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersection', but the combining function is +-- applied strictly. +-- +-- > intersection' = intersectionWith' const +intersection' :: Map map k + => TrieMap map k a -> TrieMap map k b -> TrieMap map k a +intersection' = intersectionWith' const + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersection', but the given function +-- determines the new values. +intersectionWith :: Map map k => (a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWith = Base.intersectionWith + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersectionWith', but the combining function +-- is applied strictly. +intersectionWith' :: Map map k => (a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWith' = Base.intersectionWith' + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersectionWith', but in addition to the two +-- values, the key they are associated with is passed to the combining +-- function. +intersectionWithKey :: Map map k => ([k] -> a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWithKey = Base.intersectionWithKey + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersectionWithKey', but the combining +-- function is applied strictly. +intersectionWithKey' :: Map map k => ([k] -> a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWithKey' = Base.intersectionWithKey' + +-- * Filtering + +-- | @O(n m)@. Apply the given function to the elements in the map, discarding +-- those for which the function returns 'False'. +filter :: Map map k => (a -> Bool) -> TrieMap map k a -> TrieMap map k a +filter = filterWithKey . const + +-- | @O(n m)@. Like 'filter', but the key associated with the element is also +-- passed to the given predicate. +filterWithKey :: Map map k + => ([k] -> a -> Bool) -> TrieMap map k a -> TrieMap map k a +filterWithKey = Base.filterWithKey + +-- | @O(n m)@. A pair of maps: the first element contains those values for +-- which the given predicate returns 'True', and the second contains those for +-- which it was 'False'. +partition :: Map map k => (a -> Bool) + -> TrieMap map k a + -> (TrieMap map k a, TrieMap map k a) +partition = partitionWithKey . const + +-- | @O(n m)@. Like 'partition', but the key associated with the element is +-- also passed to the given predicate. +partitionWithKey :: Map map k => ([k] -> a -> Bool) + -> TrieMap map k a + -> (TrieMap map k a, TrieMap map k a) +partitionWithKey = Base.partitionWithKey + +-- | @O(n m)@. Apply the given function to the elements in the map, preserving +-- only the 'Just' results. +mapMaybe :: Map map k + => (a -> Maybe b) -> TrieMap map k a -> TrieMap map k b +mapMaybe = mapMaybeWithKey . const + +-- | @O(n m)@. Like 'mapMaybe', but the key associated with the element is also +-- passed to the given function. +mapMaybeWithKey :: Map map k + => ([k] -> a -> Maybe b) -> TrieMap map k a -> TrieMap map k b +mapMaybeWithKey f = + fromList . Maybe.mapMaybe (\(k,v) -> fmap ((,) k) (f k v)) . toList + +-- | @O(n m)@. Apply the given function to the elements in the map, separating +-- the 'Left' results from the 'Right'. The first element of the pair contains +-- the former results, and the second the latter. +mapEither :: Map map k => (a -> Either b c) + -> TrieMap map k a + -> (TrieMap map k b, TrieMap map k c) +mapEither = mapEitherWithKey . const + +-- | @O(n m)@. Like 'mapEither', but the key associated with the element is +-- also passed to the given function. +mapEitherWithKey :: Map map k => ([k] -> a -> Either b c) + -> TrieMap map k a + -> (TrieMap map k b, TrieMap map k c) +mapEitherWithKey f = + (fromList *** fromList) . partitionEithers . + Prelude.map (\(k,v) -> either (Left . (,) k) (Right . (,) k) (f k v)) . + toList + +-- * Mapping + +-- | @O(n m)@. Apply the given function to all the elements in the map. +map :: Map map k => (a -> b) -> TrieMap map k a -> TrieMap map k b +map = genericMap fmap + +-- | @O(n m)@. Like 'map', but apply the function strictly. +map' :: Map map k => (a -> b) -> TrieMap map k a -> TrieMap map k b +map' = genericMap fmap' + +genericMap :: Map map k => ((a -> b) -> Maybe a -> Maybe b) + -> (a -> b) -> TrieMap map k a -> TrieMap map k b +genericMap myFmap f (Tr v m) = Tr (myFmap f v) + (Map.map (genericMap myFmap f) m) + +-- | @O(n m)@. Like 'map', but also pass the key associated with the element to +-- the given function. +mapWithKey :: Map map k + => ([k] -> a -> b) -> TrieMap map k a -> TrieMap map k b +mapWithKey = genericMapWithKey fmap + +-- | @O(n m)@. Like 'mapWithKey', but apply the function strictly. +mapWithKey' :: Map map k + => ([k] -> a -> b) -> TrieMap map k a -> TrieMap map k b +mapWithKey' = genericMapWithKey fmap' + +genericMapWithKey :: Map map k + => ((a -> b) -> Maybe a -> Maybe b) + -> ([k] -> a -> b) -> TrieMap map k a -> TrieMap map k b +genericMapWithKey = go DL.empty + where + go k myFmap f (Tr v m) = + Tr (myFmap (f $ DL.toList k) v) + (Map.mapWithKey (\x -> go (k `DL.snoc` x) myFmap f) m) + +-- | @O(n m)@. Apply the given function to all the keys in a map. +-- +-- > mapKeys = mapKeysWith const +mapKeys :: (Map map k1, Map map k2) + => ([k1] -> [k2]) -> TrieMap map k1 a -> TrieMap map k2 a +mapKeys = mapKeysWith const + +-- | @O(n m)@. Like 'mapKeys', but use the first given function to combine +-- elements if the second function gives two keys the same value. +mapKeysWith :: (Map map k1, Map map k2) => (a -> a -> a) + -> ([k1] -> [k2]) + -> TrieMap map k1 a + -> TrieMap map k2 a +mapKeysWith = Base.mapKeysWith . fromListWith + +-- | @O(n m)@. Apply the given function to the contents of all the keys in the +-- map. +-- +-- > mapInKeys = mapInKeysWith const +mapInKeys :: (Map map k1, Map map k2) + => (k1 -> k2) -> TrieMap map k1 a -> TrieMap map k2 a +mapInKeys = mapInKeysWith defaultUnion + +-- | @O(n m)@. Like 'mapInKeys', but combine identical keys strictly. +-- +-- > mapInKeys' = mapInKeysWith' const +mapInKeys' :: (Map map k1, Map map k2) + => (k1 -> k2) -> TrieMap map k1 a -> TrieMap map k2 a +mapInKeys' = mapInKeysWith' defaultUnion + +-- | @O(n m)@. Like 'mapInKeys', but use the first given function to combine +-- elements if the second function gives two keys the same value. +mapInKeysWith :: (Map map k1, Map map k2) => (a -> a -> a) + -> (k1 -> k2) + -> TrieMap map k1 a + -> TrieMap map k2 a +mapInKeysWith = Base.mapInKeysWith + +-- | @O(n m)@. Like 'mapInKeysWith', but apply the combining function strictly. +mapInKeysWith' :: (Map map k1, Map map k2) => (a -> a -> a) + -> (k1 -> k2) + -> TrieMap map k1 a + -> TrieMap map k2 a +mapInKeysWith' = Base.mapInKeysWith' + +-- | @O(n m)@. Like "Data.List".@mapAccumL@ on the 'toList' representation. +-- +-- Essentially a combination of 'map' and 'foldl': the given +-- function is applied to each element of the map, resulting in a new value for +-- the accumulator and a replacement element for the map. +mapAccum :: Map map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccum = genericMapAccum Map.mapAccum (flip const) + +-- | @O(n m)@. Like 'mapAccum', but the function is applied strictly. +mapAccum' :: Map map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccum' = genericMapAccum Map.mapAccum seq + +-- | @O(n m)@. Like 'mapAccum', but the function receives the key in addition +-- to the value associated with it. +mapAccumWithKey :: Map map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumWithKey = genericMapAccumWithKey Map.mapAccumWithKey (flip const) + +-- | @O(n m)@. Like 'mapAccumWithKey', but the function is applied strictly. +mapAccumWithKey' :: Map map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumWithKey' = genericMapAccumWithKey Map.mapAccumWithKey seq + +-- | @O(n m)@. Like 'mapAccum', but in ascending order, as though operating on +-- the 'toAscList' representation. +mapAccumAsc :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAsc = genericMapAccum Map.mapAccumAsc (flip const) + +-- | @O(n m)@. Like 'mapAccumAsc', but the function is applied strictly. +mapAccumAsc' :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAsc' = genericMapAccum Map.mapAccumAsc seq + +-- | @O(n m)@. Like 'mapAccumAsc', but the function receives the key in +-- addition to the value associated with it. +mapAccumAscWithKey :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAscWithKey = genericMapAccumWithKey Map.mapAccumAscWithKey (flip const) + +-- | @O(n m)@. Like 'mapAccumAscWithKey', but the function is applied strictly. +mapAccumAscWithKey' :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAscWithKey' = genericMapAccumWithKey Map.mapAccumAscWithKey seq + +-- | @O(n m)@. Like 'mapAccum', but in descending order, as though operating on +-- the 'toDescList' representation. +mapAccumDesc :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDesc = genericMapAccum Map.mapAccumDesc (flip const) + +-- | @O(n m)@. Like 'mapAccumDesc', but the function is applied strictly. +mapAccumDesc' :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDesc' = genericMapAccum Map.mapAccumDesc seq + +-- | @O(n m)@. Like 'mapAccumDesc', but the function receives the key in +-- addition to the value associated with it. +mapAccumDescWithKey :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDescWithKey = + genericMapAccumWithKey Map.mapAccumDescWithKey (flip const) + +-- | @O(n m)@. Like 'mapAccumDescWithKey', but the function is applied +-- strictly. +mapAccumDescWithKey' :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDescWithKey' = genericMapAccumWithKey Map.mapAccumDescWithKey seq + +genericMapAccum :: Map map k + => ( (acc -> TrieMap map k a -> (acc, TrieMap map k b)) + -> acc + -> CMap map k a + -> (acc, CMap map k b) + ) + -> (b -> (acc, Maybe b) -> (acc, Maybe b)) + -> (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +genericMapAccum subMapAccum seeq f acc (Tr mv m) = + let (acc', mv') = + case mv of + Nothing -> (acc, Nothing) + Just v -> + let (acc'', v') = f acc v + in v' `seeq` (acc'', Just v') + in second (Tr mv') $ + subMapAccum (genericMapAccum subMapAccum seeq f) acc' m + +genericMapAccumWithKey :: Map map k + => ( ( acc + -> k + -> TrieMap map k a + -> (acc, TrieMap map k b) + ) + -> acc + -> CMap map k a + -> (acc, CMap map k b) + ) + -> (b -> (acc, Maybe b) -> (acc, Maybe b)) + -> (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +genericMapAccumWithKey = go DL.empty + where + go k subMapAccum seeq f acc (Tr mv m) = + let (acc', mv') = + case mv of + Nothing -> (acc, Nothing) + Just v -> + let (acc'', v') = f acc (DL.toList k) v + in v' `seeq` (acc'', Just v') + in second (Tr mv') $ + subMapAccum (\a x -> go (k `DL.snoc` x) subMapAccum seeq f a) + acc' m + +-- * Folding + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toList' representation, +-- folding only over the elements. +foldr :: Map map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldr = foldrWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toList' representation, +-- folding over both the keys and the elements. +foldrWithKey :: Map map k => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldrWithKey = Base.foldrWithKey + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toAscList' representation. +foldrAsc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldrAsc = foldrAscWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toAscList' representation, +-- folding over both the keys and the elements. +foldrAscWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldrAscWithKey = Base.foldrAscWithKey + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toDescList' representation. +foldrDesc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldrDesc = foldrDescWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toDescList' representation, +-- folding over both the keys and the elements. +foldrDescWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldrDescWithKey = Base.foldrDescWithKey + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toList representation. +foldl :: Map map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldl = foldlWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toList representation, +-- folding over both the keys and the elements. +foldlWithKey :: Map map k => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlWithKey = Base.foldlWithKey + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toAscList representation. +foldlAsc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlAsc = foldlAscWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toAscList representation, +-- folding over both the keys and the elements. +foldlAscWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlAscWithKey = Base.foldlAscWithKey + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toDescList representation. +foldlDesc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlDesc = foldlDescWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toDescList representation, +-- folding over both the keys and the elements. +foldlDescWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlDescWithKey = Base.foldlDescWithKey + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toList' representation. +foldl' :: Map map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldl' = foldlWithKey' . const + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toList' representation, +-- folding over both the keys and the elements. +foldlWithKey' :: Map map k => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlWithKey' = Base.foldlWithKey' + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toAscList' representation. +foldlAsc' :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlAsc' = foldlAscWithKey' . const + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toAscList' representation, +-- folding over both the keys and the elements. +foldlAscWithKey' :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlAscWithKey' = Base.foldlAscWithKey' + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toDescList' +-- representation. +foldlDesc' :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlDesc' = foldlDescWithKey' . const + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toDescList' +-- representation, folding over both the keys and the elements. +foldlDescWithKey' :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlDescWithKey' = Base.foldlDescWithKey' + +-- * Conversion between lists + +-- | @O(n m)@. Converts the map to a list of the key-value pairs contained +-- within, in undefined order. +toList :: Map map k => TrieMap map k a -> [([k],a)] +toList = Base.toList + +-- | @O(n m)@. Converts the map to a list of the key-value pairs contained +-- within, in ascending order. +toAscList :: OrdMap map k => TrieMap map k a -> [([k],a)] +toAscList = Base.toAscList + +-- | @O(n m)@. Converts the map to a list of the key-value pairs contained +-- within, in descending order. +toDescList :: OrdMap map k => TrieMap map k a -> [([k],a)] +toDescList = Base.toDescList + +-- | @O(n m)@. Creates a map from a list of key-value pairs. If a key occurs +-- more than once, the value from the last pair (according to the list's order) +-- is the one which ends up in the map. +-- +-- > fromList = fromListWith const +fromList :: Map map k => [([k],a)] -> TrieMap map k a +fromList = Base.fromList + +-- | @O(n m)@. Like 'fromList', but the given function is used to determine the +-- final value if a key occurs more than once. The function is applied as +-- though it were flipped and then applied as a left fold over the values in +-- the given list's order. Or, equivalently (except as far as performance is +-- concerned), as though the function were applied as a right fold over the +-- values in the reverse of the given list's order. For example: +-- +-- > fromListWith (-) [("a",1),("a",2),("a",3),("a",4)] +-- > == fromList [("a",4-(3-(2-1)))] +-- > == fromList [("a",2)] +fromListWith :: Map map k => (a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWith = Base.fromListWith + +-- | @O(n m)@. Like 'fromListWith', but the combining function is applied +-- strictly. +fromListWith' :: Map map k => (a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWith' = Base.fromListWith' + +-- | @O(n m)@. Like 'fromListWith', but the key, in addition to the values to +-- be combined, is passed to the combining function. +fromListWithKey :: Map map k + => ([k] -> a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWithKey = Base.fromListWithKey + +-- | @O(n m)@. Like 'fromListWithKey', but the combining function is applied +-- strictly. +fromListWithKey' :: Map map k + => ([k] -> a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWithKey' = Base.fromListWithKey' + +-- * Ordering ops + +-- | @O(m)@. Removes and returns the minimal key in the map, along with the +-- value associated with it. If the map is empty, 'Nothing' and the original +-- map are returned. +minView :: OrdMap map k => TrieMap map k a -> (Maybe ([k], a), TrieMap map k a) +minView = Base.minView + +-- | @O(m)@. Removes and returns the maximal key in the map, along with the +-- value associated with it. If the map is empty, 'Nothing' and the original +-- map are returned. +maxView :: OrdMap map k => TrieMap map k a -> (Maybe ([k], a), TrieMap map k a) +maxView = Base.maxView + +-- | @O(m)@. Like 'fst' composed with 'minView'. 'Just' the minimal key in the +-- map and its associated value, or 'Nothing' if the map is empty. +findMin :: OrdMap map k => TrieMap map k a -> Maybe ([k], a) +findMin = Base.findMin + +-- | @O(m)@. Like 'fst' composed with 'maxView'. 'Just' the minimal key in the +-- map and its associated value, or 'Nothing' if the map is empty. +findMax :: OrdMap map k => TrieMap map k a -> Maybe ([k], a) +findMax = Base.findMax + +-- | @O(m)@. Like 'snd' composed with 'minView'. The map without its minimal +-- key, or the unchanged original map if it was empty. +deleteMin :: OrdMap map k => TrieMap map k a -> TrieMap map k a +deleteMin = Base.deleteMin + +-- | @O(m)@. Like 'snd' composed with 'maxView'. The map without its maximal +-- key, or the unchanged original map if it was empty. +deleteMax :: OrdMap map k => TrieMap map k a -> TrieMap map k a +deleteMax = Base.deleteMax + +-- | @O(min(m,s))@. Splits the map in two about the given key. The first +-- element of the resulting pair is a map containing the keys lesser than the +-- given key; the second contains those keys that are greater. +split :: OrdMap map k + => [k] -> TrieMap map k a -> (TrieMap map k a, TrieMap map k a) +split = Base.split + +-- | @O(min(m,s))@. Like 'split', but also returns the value associated with +-- the given key, if any. +splitLookup :: OrdMap map k => [k] + -> TrieMap map k a + -> (TrieMap map k a, Maybe a, TrieMap map k a) +splitLookup = Base.splitLookup + +-- | @O(m)@. 'Just' the key of the map which precedes the given key in order, +-- along with its associated value, or 'Nothing' if the map is empty. +findPredecessor :: OrdMap map k => [k] -> TrieMap map k a -> Maybe ([k], a) +findPredecessor = Base.findPredecessor + +-- | @O(m)@. 'Just' the key of the map which succeeds the given key in order, +-- along with its associated value, or 'Nothing' if the map is empty. +findSuccessor :: OrdMap map k => [k] -> TrieMap map k a -> Maybe ([k], a) +findSuccessor = Base.findSuccessor + +-- * Trie-only operations + +-- | @O(s)@. Prepends the given key to all the keys of the map. For example: +-- +-- > addPrefix "xa" (fromList [("a",1),("b",2)]) +-- > == fromList [("xaa",1),("xab",2)] +addPrefix :: Map map k => [k] -> TrieMap map k a -> TrieMap map k a +addPrefix = Base.addPrefix + +-- | @O(m)@. The map which contains all keys of which the given key is a +-- prefix, with the prefix removed from each key. If the given key is not a +-- prefix of any key in the map, the map is returned unchanged. For example: +-- +-- > deletePrefix "a" (fromList [("a",1),("ab",2),("ac",3)]) +-- > == fromList [("",1),("b",2),("c",3)] +-- +-- This function can be used, for instance, to reduce potentially expensive I/O +-- operations: if you need to find the value in a map associated with a string, +-- but you only have a prefix of it and retrieving the rest is an expensive +-- operation, calling 'deletePrefix' with what you have might allow you to +-- avoid the operation: if the resulting map is empty, the entire string cannot +-- be a member of the map. +deletePrefix :: Map map k => [k] -> TrieMap map k a -> TrieMap map k a +deletePrefix = Base.deletePrefix + +-- | @O(m)@. A triple containing the longest common prefix of all keys in the +-- map, the value associated with that prefix, if any, and the map with that +-- prefix removed from all the keys as well as the map itself. Examples: +-- +-- > splitPrefix (fromList [("a",1),("b",2)]) +-- > == ("", Nothing, fromList [("a",1),("b",2)]) +-- > splitPrefix (fromList [("a",1),("ab",2),("ac",3)]) +-- > == ("a", Just 1, fromList [("b",2),("c",3)]) +splitPrefix :: Map map k => TrieMap map k a -> ([k], Maybe a, TrieMap map k a) +splitPrefix = Base.splitPrefix + +-- | @O(m)@. The children of the longest common prefix in the trie as maps, +-- associated with their distinguishing key value. If the map contains less +-- than two keys, this function will return the empty list. Examples; +-- +-- > children (fromList [("a",1),("abc",2),("abcd",3)]) +-- > == [('b',fromList [("c",2),("cd",3)])] +-- > children (fromList [("b",1),("c",2)]) +-- > == [('b',fromList [("",1)]),('c',fromList [("",2)])] +children :: Map map k => TrieMap map k a -> [(k, TrieMap map k a)] +children = Base.children + +-- * Visualization + +-- | @O(n m)@. Displays the map's internal structure in an undefined way. That +-- is to say, no program should depend on the function's results. +showTrie :: (Show k, Show a, Map map k) => TrieMap map k a -> ShowS +showTrie = Base.showTrieWith $ \mv -> case mv of + Nothing -> showChar ' ' + Just v -> showsPrec 11 v + +-- | @O(n m)@. Like 'showTrie', but uses the given function to display the +-- elements of the map. Still undefined. +showTrieWith :: (Show k, Map map k) + => (Maybe a -> ShowS) -> TrieMap map k a -> ShowS +showTrieWith = Base.showTrieWith diff --git a/Data/ListTrie/Map/Enum.hs b/Data/ListTrie/Map/Enum.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Map/Enum.hs @@ -0,0 +1,15 @@ +-- File created: 2009-01-06 13:47:08 + +-- | A map from lists of enumerable elements to arbitrary values, based on a +-- trie. +-- +-- Note that those operations which require an ordering, such as 'toAscList', +-- do not compare the elements themselves, but rather their Int representation +-- after 'fromEnum'. +module Data.ListTrie.Map.Enum (TrieMap, module Data.ListTrie.Map) where + +import Data.ListTrie.Base.Map (WrappedIntMap) +import Data.ListTrie.Map hiding (TrieMap) +import qualified Data.ListTrie.Map as Base + +type TrieMap = Base.TrieMap WrappedIntMap diff --git a/Data/ListTrie/Map/Eq.hs b/Data/ListTrie/Map/Eq.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Map/Eq.hs @@ -0,0 +1,11 @@ +-- File created: 2009-01-06 13:26:25 + +-- | A map from lists of elements that can be compared for equality to +-- arbitrary values, based on a trie. +module Data.ListTrie.Map.Eq (TrieMap, module Data.ListTrie.Map) where + +import Data.ListTrie.Base.Map (AList) +import Data.ListTrie.Map hiding (TrieMap) +import qualified Data.ListTrie.Map as Base + +type TrieMap = Base.TrieMap AList diff --git a/Data/ListTrie/Map/Ord.hs b/Data/ListTrie/Map/Ord.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Map/Ord.hs @@ -0,0 +1,11 @@ +-- File created: 2009-01-06 13:18:32 + +-- | A map from lists of elements that can be totally ordered to arbitrary +-- values, based on a trie. +module Data.ListTrie.Map.Ord (TrieMap, module Data.ListTrie.Map) where + +import Data.Map (Map) +import Data.ListTrie.Map hiding (TrieMap) +import qualified Data.ListTrie.Map as Base + +type TrieMap = Base.TrieMap Map diff --git a/Data/ListTrie/Patricia/Base.hs b/Data/ListTrie/Patricia/Base.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Base.hs @@ -0,0 +1,1401 @@ +-- File created: 2008-12-28 17:20:14 + +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies + , FlexibleContexts, ScopedTypeVariables #-} + +module Data.ListTrie.Patricia.Base + ( Trie(..) + , null, size, size', member, notMember, lookup, lookupWithDefault + , isSubmapOfBy, isProperSubmapOfBy + , empty, singleton + , insert, insert', insertWith, insertWith' + , delete, adjust, adjust', updateLookup, alter, alter' + , unionWith, unionWithKey, unionWith', unionWithKey' + , unionsWith, unionsWithKey, unionsWith', unionsWithKey' + , differenceWith, differenceWithKey + , intersectionWith, intersectionWithKey + , intersectionWith', intersectionWithKey' + , filterWithKey, partitionWithKey + , split, splitLookup + , mapKeysWith, mapInKeysWith, mapInKeysWith' + , foldrWithKey, foldrAscWithKey, foldrDescWithKey + , foldlWithKey, foldlAscWithKey, foldlDescWithKey + , foldlWithKey', foldlAscWithKey', foldlDescWithKey' + , toList, toAscList, toDescList + , fromList, fromListWith, fromListWith', fromListWithKey, fromListWithKey' + , findMin, findMax, deleteMin, deleteMax, minView, maxView + , findPredecessor, findSuccessor + , addPrefix, splitPrefix, deletePrefix, children + , showTrieWith + , eqComparePrefixes, ordComparePrefixes + ) where + +import Control.Applicative (Applicative(..), (<$>)) +import Control.Arrow ((***), first) +import Control.Exception (assert) +import qualified Data.DList as DL +import Data.DList (DList) +import Data.Foldable (foldr, foldl') +import Data.List (foldl1', partition) +import Data.Maybe (fromJust, isJust) +import Prelude hiding (lookup, filter, foldr, null) +import qualified Prelude + +import qualified Data.ListTrie.Base.Map.Internal as Map +import Data.ListTrie.Base.Classes + ( Boolable(..) + , Unwrappable(..) + , Unionable(..), Differentiable(..), Intersectable(..) + , Alt(..) + , fmap', (<$!>) + ) +import Data.ListTrie.Base.Map (Map, OrdMap) +import Data.ListTrie.Util ((.:), both) + +class (Map map k, Functor st, Unwrappable st) + => Trie trie st map k | trie -> st where + + mkTrie :: st a -> [k] -> CMap trie map k a -> trie map k a + tParts :: trie map k a -> (st a, [k], CMap trie map k a) + +type CMap trie map k v = map k (trie map k v) + +hasValue, noValue :: Boolable b => b -> Bool +hasValue = toBool +noValue = not . hasValue + +tVal :: Trie trie st map k => trie map k a -> st a +tVal = (\(a,_,_) -> a) . tParts + +tMap :: Trie trie st map k => trie map k a -> CMap trie map k a +tMap = (\(_,_,c) -> c) . tParts + +----------------------- + +-- * Construction + +-- O(1) +empty :: (Alt st a, Trie trie st map k) => trie map k a +empty = mkTrie altEmpty [] Map.empty + +-- O(1) +singleton :: (Alt st a, Trie trie st map k) => [k] -> a -> trie map k a +singleton k v = mkTrie (pure v) k Map.empty + +-- O(min(m,s)) +insert :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> a -> trie map k a -> trie map k a +insert = insertWith const + +-- O(min(m,s)) +insert' :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> a -> trie map k a -> trie map k a +insert' = insertWith' const + +-- O(min(m,s)) +insertWith :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a +insertWith = genericInsertWith (<$>) + +-- O(min(m,s)) +insertWith' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a +insertWith' = (seq <*>) .: genericInsertWith (<$!>) + +genericInsertWith :: (Alt st a, Boolable (st a), Trie trie st map k) + => ((a -> a) -> st a -> st a) + -> (a -> a -> a) -> [k] -> a -> trie map k a -> trie map k a +genericInsertWith (<$$>) f k new tr = + let (old,prefix,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) prefix k of + Same -> mkTrie ((f new <$$> old) <|> pure new) prefix m + + PostFix (Left (p:pr)) -> mkTrie (pure new) k + (Map.singleton p (mkTrie old pr m)) + PostFix (Right (x:xs)) -> + -- Minor optimization: instead of tryCompress we just check for + -- the case of an empty trie + if null tr + then singleton k new + else mkTrie old prefix $ + Map.insertWith + (\_ oldt -> + genericInsertWith (<$$>) f xs new oldt) + x (singleton xs new) m + + DifferedAt pr' (p:pr) (x:xs) -> + mkTrie altEmpty pr' $ Map.doubleton x (singleton xs new) + p (mkTrie old pr m) + + _ -> error + "Data.ListTrie.Patricia.Base.insertWith :: internal error" + +-- O(min(m,s)) +delete :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> trie map k a +delete = alter (const altEmpty) + +-- O(min(m,s)) +adjust :: Trie trie st map k + => (a -> a) -> [k] -> trie map k a -> trie map k a +adjust = genericAdjust fmap + +-- O(min(m,s)) +adjust' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a) -> [k] -> trie map k a -> trie map k a +adjust' = genericAdjust fmap' + +genericAdjust :: Trie trie st map k + => ((a -> a) -> st a -> st a) + -> (a -> a) -> [k] -> trie map k a -> trie map k a +genericAdjust myFmap f k tr = + let (v,prefix,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) prefix k of + Same -> mkTrie (myFmap f v) prefix m + PostFix (Right (x:xs)) -> + mkTrie v prefix $ Map.adjust (genericAdjust myFmap f xs) x m + _ -> tr + +-- O(min(m,s)) +updateLookup :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> st a) -> [k] -> trie map k a -> (st a, trie map k a) +updateLookup f k tr = + let (v,prefix,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) prefix k of + Same -> let v' = if hasValue v + then f (unwrap v) + else v + in (v, safeMkTrie v' prefix m) + PostFix (Right (x:xs)) -> + case Map.lookup x m of + Nothing -> (altEmpty, tr) + Just tr' -> + let (ret, upd) = updateLookup f xs tr' + in ( ret + , safeMkTrie v prefix $ + if null upd + then Map.delete x m + else Map.adjust (const upd) x m + ) + _ -> (altEmpty, tr) + +-- O(min(m,s)) +-- +-- This can be lazy in exactly one case: the key is a prefix of more than one +-- key in the trie. In that case, we know that the resulting trie continues to +-- contain those children. +-- +-- In all other cases we have to check whether the function removed a key or +-- not, in order to be able to keep the trie in an internally valid state. + +-- (I.e. we need to try to compress it.) +alter :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> st a) -> [k] -> trie map k a -> trie map k a +alter = genericAlter (flip const) + +-- O(min(m,s)) +alter' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> st a) -> [k] -> trie map k a -> trie map k a +alter' = genericAlter seq + +genericAlter :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> trie map k a -> trie map k a) + -> (st a -> st a) -> [k] -> trie map k a -> trie map k a +genericAlter seeq f k tr = + let (v,prefix,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) prefix k of + Same -> + let v' = f v + in -- We need to compress if the map was empty or a singleton + -- and the value was removed + if (Map.null m || isJust (Map.singletonView m)) + && not (hasValue v') + then tryCompress (mkTrie v' prefix m) + else v' `seeq` mkTrie v' prefix m + + PostFix (Right (x:xs)) -> + mkTrie v prefix $ + Map.alter + (\mt -> case mt of + Nothing -> + let v' = f altEmpty + in if hasValue v' + then Just (singleton xs (unwrap v')) + else Nothing + Just t -> + let new = genericAlter seeq f xs t + in if null new then Nothing else Just new) + x m + + PostFix (Left (p:ps)) -> + let v' = f altEmpty + in if hasValue v' + then mkTrie v' k $ Map.singleton p (mkTrie v ps m) + else tr + + DifferedAt pr (p:ps) (x:xs) -> + let v' = f altEmpty + in if hasValue v' + then mkTrie altEmpty pr $ + Map.doubleton p (mkTrie v ps m) + x (mkTrie v' xs Map.empty) + else tr + + _ -> + error + "Data.ListTrie.Patricia.Base.genericAlter :: internal error" + +-- * Querying + +-- O(1) +-- +-- Test the strict field last for maximal laziness +null :: (Boolable (st a), Trie trie st map k) => trie map k a -> Bool +null tr = let (v,p,m) = tParts tr + in Map.null m && noValue v && assert (Prelude.null p) True + +-- O(n m) +size :: (Boolable (st a), Trie trie st map k, Num n) => trie map k a -> n +size tr = foldr ((+) . size) (if hasValue (tVal tr) then 1 else 0) (tMap tr) + +-- O(n m) +size' :: (Boolable (st a), Trie trie st map k, Num n) => trie map k a -> n +size' tr = foldl' (flip $ (+) . size') + (if hasValue (tVal tr) then 1 else 0) + (tMap tr) + +-- O(min(m,s)) +member :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> Bool +member = hasValue .: lookup + +-- O(min(m,s)) +notMember :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> Bool +notMember = not .: member + +-- O(min(m,s)) +lookup :: (Alt st a, Trie trie st map k) => [k] -> trie map k a -> st a +lookup k tr = + let (v,prefix,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) prefix k of + Same -> v + PostFix (Right (x:xs)) -> maybe altEmpty (lookup xs) + (Map.lookup x m) + _ -> altEmpty + +-- O(min(m,s)) +lookupWithDefault :: (Alt st a, Trie trie st map k) + => a -> [k] -> trie map k a -> a +lookupWithDefault def k tr = unwrap $ lookup k tr <|> pure def + +-- O(min(n1 m1,n2 m2)) +isSubmapOfBy :: (Boolable (st a), Boolable (st b), Trie trie st map k) + => (a -> b -> Bool) + -> trie map k a + -> trie map k b + -> Bool +isSubmapOfBy f_ trl trr = + let (vl,prel,ml) = tParts trl + (vr,prer,mr) = tParts trr + in case comparePrefixes (Map.eqCmp ml) prel prer of + DifferedAt _ _ _ -> False + + -- Special case here: if the left trie is empty we return True. + PostFix (Right _) -> null trl + PostFix (Left xs) -> go f_ mr vl ml xs + Same -> same f_ vl vr ml mr + where + go f mr vl ml (x:xs) = + case Map.lookup x mr of + Nothing -> False + Just tr -> + let (vr,pre,mr') = tParts tr + in case comparePrefixes (Map.eqCmp mr) xs pre of + DifferedAt _ _ _ -> False + PostFix (Right _) -> False + PostFix (Left ys) -> go f mr' vl ml ys + Same -> same f vl vr ml mr' + + go _ _ _ _ [] = + error "Data.ListTrie.Patricia.Base.isSubmapOfBy :: internal error" + + same f vl vr ml mr = + let hvl = hasValue vl + hvr = hasValue vr + in and [ not (hvl && not hvr) + , (not hvl && not hvr) || f_ (unwrap vl) (unwrap vr) + , Map.isSubmapOfBy (isSubmapOfBy f) ml mr + ] + +-- O(min(n1 m1,n2 m2)) +isProperSubmapOfBy :: (Boolable (st a), Boolable (st b), Trie trie st map k) + => (a -> b -> Bool) + -> trie map k a + -> trie map k b + -> Bool +isProperSubmapOfBy = f False + where + f proper g trl trr = + let (vl,prel,ml) = tParts trl + (vr,prer,mr) = tParts trr + in case comparePrefixes (Map.eqCmp ml) prel prer of + DifferedAt _ _ _ -> False + + -- Special case, as in isSubsetOf. + -- + -- Note that properness does not affect this: if we hit this + -- case, we already know that the right trie is nonempty. + PostFix (Right _) -> null trl + PostFix (Left xs) -> go proper g mr vl ml xs + Same -> same proper g vl vr ml mr + + go proper g mr vl ml (x:xs) = + case Map.lookup x mr of + Nothing -> False + Just tr -> + let (vr,pre,mr') = tParts tr + in case comparePrefixes (Map.eqCmp mr) xs pre of + DifferedAt _ _ _ -> False + PostFix (Right _) -> False + PostFix (Left ys) -> go proper g mr' vl ml ys + Same -> same proper g vl vr ml mr' + + go _ _ _ _ _ [] = + error "Data.ListTrie.Patricia.Base.isProperSubmapOfBy :: internal error" + + same proper g vl vr ml mr = + let hvl = hasValue vl + hvr = hasValue vr + + -- As the non-Patricia version, so does this seem suboptimal. + proper' = or [ proper + , not hvl && hvr + , not (Map.null $ Map.difference mr ml) + ] + + in and [ not (hvl && not hvr) + , (not hvl && not hvr) || g (unwrap vl) (unwrap vr) + , if Map.null ml + then proper' + else Map.isSubmapOfBy (f proper' g) ml mr + ] + +-- * Combination + +-- The *Key versions are mostly rewritten from the basic ones: they have an +-- additional O(m) cost from keeping track of the key, which is why the basic +-- ones can't just call them. + +-- O(min(n1 m1,n2 m2)) +unionWith :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) + => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a +unionWith f = genericUnionWith (unionVals f) (flip const) + +-- O(min(n1 m1,n2 m2)) +unionWith' :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) + => (a -> a -> a) -> trie map k a -> trie map k a -> trie map k a +unionWith' f = genericUnionWith (unionVals' f) seq + +genericUnionWith :: (Alt st a, Boolable (st a), Trie trie st map k) + => (st a -> st a -> st a) + -> (st a -> trie map k a -> trie map k a) + -> trie map k a + -> trie map k a + -> trie map k a +genericUnionWith valUnion seeq tr1 tr2 = + let (v1,pre1,m1) = tParts tr1 + (v2,pre2,m2) = tParts tr2 + in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of + Same -> + let v = valUnion v1 v2 + + -- safeMkTrie not needed: if pre1 is not null then m1 or v + -- won't be and hence the union won't be. + in v `seeq` (tryCompress.mkTrie v pre1 $ + mapUnion valUnion seeq m1 m2) + + PostFix remainder -> + -- As above, mkTrie is fine + -- + -- The flip is important to retain left-biasedness + tryCompress $ + either + (mkTrie v2 pre2 . mapUnion (flip valUnion) seeq m2 . + decompress m1 v1) + (mkTrie v1 pre1 . mapUnion valUnion seeq m1 . + decompress m2 v2) + remainder + + DifferedAt pr (x:xs) (y:ys) -> + -- As above, mkTrie is fine + mkTrie altEmpty pr $ Map.doubleton x (mkTrie v1 xs m1) + y (mkTrie v2 ys m2) + + _ -> can'tHappen + where + mapUnion = Map.unionWith .: genericUnionWith + + decompress m v (x:xs) = Map.singleton x (mkTrie v xs m) + decompress _ _ [] = can'tHappen + + can'tHappen = + error "Data.ListTrie.Patricia.Base.unionWith :: internal error" + +-- O(min(n1 m1,n2 m2)) +unionWithKey :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) + => ([k] -> a -> a -> a) + -> trie map k a + -> trie map k a + -> trie map k a +unionWithKey = genericUnionWithKey unionVals (flip const) + +-- O(min(n1 m1,n2 m2)) +unionWithKey' :: ( Alt st a, Boolable (st a), Unionable st a + , Trie trie st map k + ) + => ([k] -> a -> a -> a) + -> trie map k a + -> trie map k a + -> trie map k a +unionWithKey' = genericUnionWithKey unionVals' seq + +genericUnionWithKey :: (Alt st a, Boolable (st a), Trie trie st map k) + => ((a -> a -> a) -> st a -> st a -> st a) + -> (st a -> trie map k a -> trie map k a) + -> ([k] -> a -> a -> a) + -> trie map k a + -> trie map k a + -> trie map k a +genericUnionWithKey = go DL.empty + where + go k valUnion seeq j tr1 tr2 = + let (v1,pre1,m1) = tParts tr1 + (v2,pre2,m2) = tParts tr2 + in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of + Same -> + let k' = DL.toList $ k `DL.append` DL.fromList pre1 + v = valUnion (j k') v1 v2 + in v `seeq` + (tryCompress.mkTrie v pre1 $ + mapUnion valUnion seeq j k pre1 m1 m2) + + PostFix remainder -> + tryCompress $ + either + (mk v2 pre2 . mapUnion (flip.valUnion) seeq j k pre2 m2 + . decompress m1 v1) + (mk v1 pre1 . mapUnion valUnion seeq j k pre1 m1 + . decompress m2 v2) + remainder + + DifferedAt pr (x:xs) (y:ys) -> + mkTrie altEmpty pr $ Map.doubleton x (mkTrie v1 xs m1) + y (mkTrie v2 ys m2) + + _ -> can'tHappen + + mk = mkTrie + + mapUnion v s j k p = + Map.unionWithKey $ + \x -> go (k `DL.append` DL.fromList p `DL.snoc` x) v s j + + decompress m v (x:xs) = Map.singleton x (mkTrie v xs m) + decompress _ _ [] = can'tHappen + + can'tHappen = + error "Data.ListTrie.Patricia.Base.unionWithKey :: internal error" + +-- O(sum(n)) +unionsWith :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) + => (a -> a -> a) -> [trie map k a] -> trie map k a +unionsWith j = foldl' (unionWith j) empty + +-- O(sum(n)) +unionsWith' :: (Alt st a, Boolable (st a), Unionable st a, Trie trie st map k) + => (a -> a -> a) -> [trie map k a] -> trie map k a +unionsWith' j = foldl' (unionWith' j) empty + +-- O(sum(n)) +unionsWithKey :: ( Alt st a, Boolable (st a) + , Unionable st a, Trie trie st map k + ) + => ([k] -> a -> a -> a) -> [trie map k a] -> trie map k a +unionsWithKey j = foldl' (unionWithKey j) empty + +-- O(sum(n)) +unionsWithKey' :: ( Alt st a, Boolable (st a) + , Unionable st a, Trie trie st map k + ) + => ([k] -> a -> a -> a) -> [trie map k a] -> trie map k a +unionsWithKey' j = foldl' (unionWithKey' j) empty + +-- O(min(n1 m1,n2 m2)) +differenceWith :: (Boolable (st a), Differentiable st a b, Trie trie st map k) + => (a -> b -> Maybe a) + -> trie map k a + -> trie map k b + -> trie map k a +differenceWith j_ tr1 tr2 = + let (v1,pre1,m1) = tParts tr1 + (v2,pre2,m2) = tParts tr2 + in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of + DifferedAt _ _ _ -> tr1 + Same -> mk j_ v1 v2 pre1 m1 m2 + PostFix (Left xs) -> goRight j_ tr1 m2 xs + PostFix (Right xs) -> goLeft j_ tr1 tr2 xs + where + mapDifference = Map.differenceWith . dw + dw j a b = + let c = differenceWith j a b + in if null c then Nothing else Just c + + mk j v v' p m m' = + let vd = differenceVals j v v' + in tryCompress.mkTrie vd p $ mapDifference j m m' + + -- See the comment in 'intersection' for a longish example of the idea + -- behind this, which is basically that if we see two prefixes like "foo" + -- and "foobar", we traverse the "foo" trie looking for "bar". Then if we + -- find "barbaz", we traverse the "foobar" trie looking for "baz", and so + -- on. + -- + -- We have two functions for the two tries because set difference is a + -- noncommutative operation. + goRight j left rightMap (x:xs) = + let (v,pre,m) = tParts left + in case Map.lookup x rightMap of + Nothing -> left + Just right' -> + let (v',pre',m') = tParts right' + in case comparePrefixes (Map.eqCmp m) xs pre' of + DifferedAt _ _ _ -> left + Same -> mk j v v' pre m m' + PostFix (Left ys) -> goRight j left m' ys + PostFix (Right ys) -> goLeft j left right' ys + + goRight _ _ _ [] = can'tHappen + + goLeft j left right (x:xs) = + tryCompress . mkTrie vl prel $ Map.update f x ml + where + (vl,prel,ml) = tParts left + (vr, _,mr) = tParts right + + f left' = + let (v,pre,m) = tParts left' + in case comparePrefixes (Map.eqCmp m) pre xs of + DifferedAt _ _ _ -> Just left' + Same -> tryNull $ mk j v vr pre m mr + PostFix (Left ys) -> tryNull $ goRight j left' mr ys + PostFix (Right ys) -> tryNull $ goLeft j left' right ys + + tryNull t = if null t then Nothing else Just t + + goLeft _ _ _ [] = can'tHappen + + can'tHappen = + error "Data.ListTrie.Patricia.Base.differenceWith :: internal error" + +-- O(min(n1 m1,n2 m2)) +differenceWithKey :: ( Boolable (st a), Differentiable st a b + , Trie trie st map k + ) + => ([k] -> a -> b -> Maybe a) + -> trie map k a + -> trie map k b + -> trie map k a +differenceWithKey = go DL.empty + where + go k j_ tr1 tr2 = + let (v1,pre1,m1) = tParts tr1 + (v2,pre2,m2) = tParts tr2 + in case comparePrefixes (Map.eqCmp m1) pre1 pre2 of + DifferedAt _ _ _ -> tr1 + Same -> mk j_ k v1 v2 pre1 m1 m2 + PostFix (Left xs) -> goRight (key k pre2) j_ tr1 m2 xs + PostFix (Right xs) -> goLeft (key k pre1) j_ tr1 tr2 xs + + mapDifference k j = + Map.differenceWithKey (\x -> dw (k `DL.snoc` x) j) + + key k p = k `DL.append` DL.fromList p + + dw k j a b = + let c = go k j a b + in if null c then Nothing else Just c + + mk j k v v' p m m' = + let k' = k `DL.append` DL.fromList p + vd = differenceVals (j $ DL.toList k') v v' + in tryCompress.mkTrie vd p $ mapDifference k' j m m' + + goRight k j left rightMap (x:xs) = + let (vl,_,ml) = tParts left + in case Map.lookup x rightMap of + Nothing -> left + Just right -> + let (vr,pre,mr) = tParts right + k' = k `DL.snoc` x + in case comparePrefixes (Map.eqCmp ml) xs pre of + DifferedAt _ _ _ -> left + Same -> mk j k' vl vr pre ml mr + PostFix (Left ys) -> goRight (key k' pre) + j left mr ys + PostFix (Right ys) -> goLeft (key k' xs) + j left right ys + + goRight _ _ _ _ [] = can'tHappen + + goLeft k j left right (x:xs) = + tryCompress . mkTrie vl prel $ Map.update f x ml + where + (vl,prel,ml) = tParts left + (vr, _,mr) = tParts right + + k' = k `DL.snoc` x + + f left' = + let (v,pre,m) = tParts left' + in case comparePrefixes (Map.eqCmp m) pre xs of + DifferedAt _ _ _ -> Just left' + Same -> tryNull $ mk j k' v vr pre m mr + PostFix (Left ys) -> tryNull $ goRight (key k' xs) + j left' mr ys + PostFix (Right ys) -> tryNull $ goLeft (key k' pre) + j left' right ys + + tryNull t = if null t then Nothing else Just t + + goLeft _ _ _ _ [] = can'tHappen + + can'tHappen = + error "Data.ListTrie.Patricia.Base.differenceWithKey :: internal error" + +-- O(min(n1 m1,n2 m2)) +intersectionWith :: ( Alt st c, Boolable (st c) + , Intersectable st a b c, Intersectable st b a c + , Trie trie st map k + ) + => (a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWith f = genericIntersectionWith (intersectionVals f) (flip const) + +-- O(min(n1 m1,n2 m2)) +intersectionWith' :: ( Alt st c, Boolable (st c) + , Intersectable st a b c, Intersectable st b a c + , Trie trie st map k + ) + => (a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWith' f = genericIntersectionWith (intersectionVals' f) seq + +genericIntersectionWith :: forall a b c k map st trie. + ( Alt st c, Boolable (st c) + , Trie trie st map k + ) + => (st a -> st b -> st c) + -> (st c -> trie map k c -> trie map k c) + -> trie map k a + -> trie map k b + -> trie map k c +genericIntersectionWith valIsect_ seeq_ trl trr = + let (vl,prel,ml) = tParts trl + (vr,prer,mr) = tParts trr + in case comparePrefixes (Map.eqCmp ml) prel prer of + DifferedAt _ _ _ -> empty + Same -> mk valIsect_ seeq_ vl vr prel ml mr + PostFix remainder -> + -- use the one with a longer prefix as the base for the + -- intersection, and descend into the map of the one with a + -- shorter prefix + either (go valIsect_ seeq_ mr vl ml (DL.fromList prel)) + (go (flip valIsect_) seeq_ ml vr mr (DL.fromList prer)) + remainder + where + mapIntersect valIsect seeq = + Map.filter (not.null) .: + Map.intersectionWith (genericIntersectionWith valIsect seeq) + + mk valIsect seeq v v' p m m' = + let vi = valIsect v v' + in vi `seeq` (tryCompress.mkTrie vi p $ mapIntersect valIsect seeq m m') + + -- Polymorphic recursion in 'go' (valIsect :: st a -> st b -> st c ---> st b + -- -> st a -> st c) means that it has to be explicitly typed in order to + -- compile. + -- + -- The repeated "Trie trie st map k" constraint is for Hugs. + + -- Like goLeft and goRight in 'difference', but handles both cases (since + -- this is a commutative operation). + -- + -- Traverse the map given as the 1st argument, looking for anything that + -- begins with the given key (x:xs). + -- + -- If it's found, great: make an intersected trie out of the trie found in + -- the map and the boolean, map, and prefix given. + -- + -- If it's not found but might still be, there are two cases. + -- + -- 1. Say we've got the following two TrieSets: + -- + -- fromList ["car","cat"] + -- fromList ["car","cot"] + -- + -- i.e. (where <> is stuff we don't care about here) + -- + -- Tr False "ca" (fromList [('r', Tr True "" <>),<>]) + -- Tr False "c" (fromList [('a', Tr True "r" <>),<>]) + -- + -- We came in here with (x:xs) = "a", the remainder of comparing "ca" and + -- "c". We're looking for anything that begins with "ca" from the children + -- of the "c". + -- + -- We find the prefix pre' = "r", and comparePrefixes gives PostFix (Right + -- "r"). So now we want anything beginning with "car" in the other trie. We + -- switch to traversing the other trie, i.e. the other given map: the + -- children of "ca". + -- + -- 2. Say we have the following: + -- + -- fromList ["cat"] + -- fromList ["cat","cot","cap"] + -- + -- i.e. + -- + -- Tr True "cat" <> + -- Tr False "c" (fromList [('a',Tr False "" (fromList [('t',<>)])),<>]) + -- + -- (x:xs) = "at" now, and we find pre' = "". We get PostFix (Left "t"). This + -- means that we're staying in the same trie, just looking for "t" now + -- instead of "at". So we jump into the m' map. + -- + -- Note that the prefix and boolean don't change: we've already got "ca", + -- and we'd still like "cat" so we keep the True from there. + go :: (Alt st z, Boolable (st z), Trie trie st map k) + => (st x -> st y -> st z) + -> (st z -> trie map k z -> trie map k z) + -> CMap trie map k y + -> st x + -> CMap trie map k x + -> DList k + -> [k] + -> trie map k z + go valIsect seeq ma v mb pre (x:xs) = + case Map.lookup x ma of + Nothing -> empty + Just tr -> + let (v',pre',m') = tParts tr + in case comparePrefixes (Map.eqCmp ma) xs pre' of + DifferedAt _ _ _ -> empty + Same -> + mk valIsect seeq v v' (DL.toList pre) mb m' + PostFix (Right ys) -> + let nextPre = pre `DL.append` DL.fromList ys + in go (flip valIsect) seeq mb v' m' nextPre ys + PostFix (Left ys) -> + go valIsect seeq m' v mb pre ys + + go _ _ _ _ _ _ [] = + error "Data.ListTrie.Patricia.Map.intersectionWith :: internal error" + +-- O(min(n1 m1,n2 m2)) +intersectionWithKey :: ( Alt st c, Boolable (st c) + , Intersectable st a b c, Intersectable st b a c + , Trie trie st map k + ) + => ([k] -> a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWithKey = genericIntersectionWithKey intersectionVals (flip const) + +-- O(min(n1 m1,n2 m2)) +intersectionWithKey' :: ( Alt st c, Boolable (st c) + , Intersectable st a b c, Intersectable st b a c + , Trie trie st map k + ) + => ([k] -> a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +intersectionWithKey' = genericIntersectionWithKey intersectionVals' seq + +genericIntersectionWithKey :: forall a b c k map st trie. + (Alt st c, Boolable (st c), Trie trie st map k) + => ((a -> b -> c) -> st a -> st b -> st c) + -> (st c -> trie map k c -> trie map k c) + -> ([k] -> a -> b -> c) + -> trie map k a + -> trie map k b + -> trie map k c +genericIntersectionWithKey = main DL.empty + where + main k valIsect seeq j trl trr = + let (vl,prel,ml) = tParts trl + (vr,prer,mr) = tParts trr + in case comparePrefixes (Map.eqCmp ml) prel prer of + DifferedAt _ _ _ -> empty + Same -> mk k valIsect seeq j vl vr prel ml mr + PostFix remainder -> + let prel' = DL.fromList prel + prer' = DL.fromList prer + in either + (go k valIsect seeq j mr vl ml prel') + (go k (flipp valIsect) seeq (flip.j) ml vr mr prer') + remainder + + mk k valIsect seeq j v v' p m m' = + let k' = k `DL.append` DL.fromList p + vi = valIsect (j $ DL.toList k') v v' + in vi `seeq` (tryCompress.mkTrie vi p $ + mapIntersect k' valIsect seeq j m m') + + mapIntersect k valIsect seeq j = + Map.filter (not.null) .: + Map.intersectionWithKey (\x -> main (k `DL.snoc` x) valIsect seeq j) + + flipp :: ((x -> y -> z) -> st x -> st y -> st z) + -> ((y -> x -> z) -> st y -> st x -> st z) + flipp f = flip . f . flip + + -- See intersectionWith: this explicit type is necessary + go :: (Alt st z, Boolable (st z), Trie trie st map k) + => DList k + -> ((x -> y -> z) -> st x -> st y -> st z) + -> (st z -> trie map k z -> trie map k z) + -> ([k] -> x -> y -> z) + -> CMap trie map k y + -> st x + -> CMap trie map k x + -> DList k + -> [k] + -> trie map k z + go k valIsect seeq j ma v mb pre (x:xs) = + case Map.lookup x ma of + Nothing -> empty + Just tr -> + let (v',pre',m') = tParts tr + in case comparePrefixes (Map.eqCmp ma) xs pre' of + DifferedAt _ _ _ -> empty + Same -> + mk k valIsect seeq j v v' (DL.toList pre) mb m' + PostFix (Right ys) -> + let nextPre = pre `DL.append` DL.fromList ys + in go k (flipp valIsect) seeq (flip.j) + mb v' m' nextPre ys + PostFix (Left ys) -> + go k valIsect seeq j + m' v mb pre ys + + go _ _ _ _ _ _ _ _ [] = + error "Data.ListTrie.Patricia.Map.intersectionWithKey :: internal error" + +-- * Filtering + +-- O(n m) +filterWithKey :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> Bool) -> trie map k a -> trie map k a +filterWithKey p = fromList . Prelude.filter (uncurry p) . toList + +-- O(n m) +partitionWithKey :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> Bool) + -> trie map k a + -> (trie map k a, trie map k a) +partitionWithKey p = both fromList . partition (uncurry p) . toList + +-- * Mapping + +-- O(n m) +mapKeysWith :: (Boolable (st a), Trie trie st map k1, Trie trie st map k2) + => ([([k2],a)] -> trie map k2 a) + -> ([k1] -> [k2]) + -> trie map k1 a + -> trie map k2 a +mapKeysWith fromlist f = fromlist . map (first f) . toList + +-- O(n m) +mapInKeysWith :: ( Alt st a, Boolable (st a), Unionable st a + , Trie trie st map k1, Trie trie st map k2 + ) + => (a -> a -> a) + -> (k1 -> k2) + -> trie map k1 a + -> trie map k2 a +mapInKeysWith = genericMapInKeysWith (flip const) (const ()) unionWith + +-- O(n m) +mapInKeysWith' :: ( Alt st a, Boolable (st a), Unionable st a + , Trie trie st map k1, Trie trie st map k2 + ) + => (a -> a -> a) + -> (k1 -> k2) + -> trie map k1 a + -> trie map k2 a +mapInKeysWith' = + genericMapInKeysWith + seq + (\xs -> if Prelude.null xs then () else foldl1' seq xs `seq` ()) + unionWith' + +genericMapInKeysWith :: ( Alt st a, Boolable (st a), Unionable st a + , Trie trie st map k1, Trie trie st map k2 + ) + => (() -> trie map k2 a -> trie map k2 a) + -> ([k2] -> ()) + -> (f -> trie map k2 a -> trie map k2 a -> trie map k2 a) + -> f + -> (k1 -> k2) + -> trie map k1 a + -> trie map k2 a +genericMapInKeysWith seeq listSeq unionW j f tr = + let (v,p,m) = tParts tr + p' = map f p + in listSeq p' `seeq` + (mkTrie v p' $ + Map.fromListWith (unionW j) . + map (f *** genericMapInKeysWith seeq listSeq unionW j f) . + Map.toList $ m) + +-- * Folding + +-- O(n m) +foldrWithKey :: (Boolable (st a), Trie trie st map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldrWithKey f x = foldr (uncurry f) x . toList + +-- O(n m) +foldrAscWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldrAscWithKey f x = foldr (uncurry f) x . toAscList + +-- O(n m) +foldrDescWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldrDescWithKey f x = foldr (uncurry f) x . toDescList + +-- O(n m) +foldlWithKey :: (Boolable (st a), Trie trie st map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlWithKey f x = foldl (flip $ uncurry f) x . toList + +-- O(n m) +foldlAscWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlAscWithKey f x = foldl (flip $ uncurry f) x . toAscList + +-- O(n m) +foldlDescWithKey :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlDescWithKey f x = foldl (flip $ uncurry f) x . toDescList + +-- O(n m) +foldlWithKey' :: (Boolable (st a), Trie trie st map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlWithKey' f x = foldl' (flip $ uncurry f) x . toList + +-- O(n m) +foldlAscWithKey' :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlAscWithKey' f x = foldl' (flip $ uncurry f) x . toAscList + +-- O(n m) +foldlDescWithKey' :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => ([k] -> a -> b -> b) -> b -> trie map k a -> b +foldlDescWithKey' f x = foldl' (flip $ uncurry f) x . toDescList + +-- * Conversion between lists + +-- O(n m) +toList :: (Boolable (st a), Trie trie st map k) => trie map k a -> [([k],a)] +toList = genericToList Map.toList DL.cons + +-- O(n m) +toAscList :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> [([k],a)] +toAscList = genericToList Map.toAscList DL.cons + +-- O(n m) +toDescList :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> [([k],a)] +toDescList = genericToList (reverse . Map.toAscList) (flip DL.snoc) + +genericToList :: (Boolable (st a), Trie trie st map k) + => (CMap trie map k a -> [(k, trie map k a)]) + -> (([k],a) -> DList ([k],a) -> DList ([k],a)) + -> trie map k a + -> [([k],a)] +genericToList f_ g_ = DL.toList . go DL.empty f_ g_ + where + go l tolist add tr = + let (v,p,m) = tParts tr + l' = l `DL.append` DL.fromList p + xs = + DL.concat . + map (\(x,t) -> go (l' `DL.snoc` x) tolist add t) . + tolist $ m + in if hasValue v + then add (DL.toList l', unwrap v) xs + else xs + +-- O(n m) +fromList :: (Alt st a, Boolable (st a), Trie trie st map k) + => [([k],a)] -> trie map k a +fromList = fromListWith const + +-- O(n m) +fromListWith :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a -> a) -> [([k],a)] -> trie map k a +fromListWith f = foldl' (flip . uncurry $ insertWith f) empty + +-- O(n m) +fromListWith' :: (Alt st a, Boolable (st a), Trie trie st map k) + => (a -> a -> a) -> [([k],a)] -> trie map k a +fromListWith' f = foldl' (flip . uncurry $ insertWith' f) empty + +-- O(n m) +fromListWithKey :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> a -> a) -> [([k],a)] -> trie map k a +fromListWithKey f = foldl' (\tr (k,v) -> insertWith (f k) k v tr) empty + +-- O(n m) +fromListWithKey' :: (Alt st a, Boolable (st a), Trie trie st map k) + => ([k] -> a -> a -> a) -> [([k],a)] -> trie map k a +fromListWithKey' f = foldl' (\tr (k,v) -> insertWith' (f k) k v tr) empty + +-- * Min/max + +-- O(m) +minView :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> (Maybe ([k], a), trie map k a) +minView = minMaxView (hasValue.tVal) (fst . Map.minViewWithKey) + +-- O(m) +maxView :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> (Maybe ([k], a), trie map k a) +maxView = minMaxView (Map.null.tMap) (fst . Map.maxViewWithKey) + +minMaxView :: (Alt st a, Boolable (st a), Trie trie st map k) + => (trie map k a -> Bool) + -> (CMap trie map k a -> Maybe (k, trie map k a)) + -> trie map k a + -> (Maybe ([k], a), trie map k a) +minMaxView _ _ tr_ | null tr_ = (Nothing, tr_) +minMaxView f g tr_ = first Just (go f g tr_) + where + go isWanted mapView tr = + let (v,pre,m) = tParts tr + in if isWanted tr + then ((pre, unwrap v), safeMkTrie altEmpty pre m) + + else let (k, tr') = fromJust (mapView m) + (minMax, tr'') = go isWanted mapView tr' + in ( first (prepend pre k) minMax + , mkTrie v pre $ if null tr'' + then Map.delete k m + else Map.adjust (const tr'') k m + ) + +-- O(m) +findMin :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> Maybe ([k], a) +findMin = findMinMax (hasValue . tVal) (fst . Map.minViewWithKey) + +-- O(m) +findMax :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> Maybe ([k], a) +findMax = findMinMax (Map.null . tMap) (fst . Map.maxViewWithKey) + +findMinMax :: (Boolable (st a), Trie trie st map k) + => (trie map k a -> Bool) + -> (CMap trie map k a -> Maybe (k, trie map k a)) + -> trie map k a + -> Maybe ([k], a) +findMinMax _ _ tr_ | null tr_ = Nothing +findMinMax f g tr_ = Just (go f g DL.empty tr_) + where + go isWanted mapView xs tr = + let (v,pre,m) = tParts tr + xs' = xs `DL.append` DL.fromList pre + in if isWanted tr + then (DL.toList xs', unwrap v) + else let (k, tr') = fromJust . mapView $ m + in go isWanted mapView (xs' `DL.snoc` k) tr' + +-- O(m) +deleteMin :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> trie map k a +deleteMin = snd . minView + +-- O(m) +deleteMax :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => trie map k a -> trie map k a +deleteMax = snd . maxView + +-- O(min(m,s)) +split :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] -> trie map k a -> (trie map k a, trie map k a) +split xs tr = let (l,_,g) = splitLookup xs tr in (l,g) + +-- O(min(m,s)) +splitLookup :: (Alt st a, Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] + -> trie map k a + -> (trie map k a, st a, trie map k a) +splitLookup xs tr = + let (v,pre,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) pre xs of + Same -> (empty, v, mk altEmpty pre m) + DifferedAt _ (p:_) (x:_) -> + case Map.ordCmp m p x of + LT -> (tr, altEmpty, empty) + GT -> (empty, altEmpty, tr) + EQ -> can'tHappen + + PostFix (Left _) -> (empty, altEmpty, tr) + PostFix (Right (y:ys)) -> + let (ml, maybeTr, mg) = Map.splitLookup y m + in case maybeTr of + -- Prefix goes in left side of split since it's shorter + -- than the given key and thus lesser + Nothing -> (mk v pre ml, altEmpty, mk altEmpty pre mg) + Just tr' -> + let (tl, v', tg) = splitLookup ys tr' + ml' = if null tl then ml else Map.insert y tl ml + mg' = if null tg then mg else Map.insert y tg mg + in (mk v pre ml', v', mk altEmpty pre mg') + _ -> can'tHappen + where + mk v pre = tryCompress . mkTrie v pre + can'tHappen = + error "Data.ListTrie.Patricia.Base.splitLookup :: internal error" + +-- O(m) +findPredecessor :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] -> trie map k a -> Maybe ([k], a) +findPredecessor _ tr | null tr = Nothing +findPredecessor xs_ tr_ = go xs_ tr_ + where + go xs tr = + let (v,pre,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) pre xs of + Same -> Nothing + PostFix (Left _) -> Nothing + + DifferedAt _ (p:_) (x:_) -> + case Map.ordCmp m p x of + LT -> findMax tr + GT -> Nothing + EQ -> can'tHappen + + -- See comment in non-Patricia version for explanation of + -- algorithm + PostFix (Right (y:ys)) -> + let predecessor = Map.findPredecessor y m + in (first (prepend pre y)<$>(Map.lookup y m >>= go ys)) + <|> + case predecessor of + Nothing -> + if hasValue v + then Just (pre, unwrap v) + else Nothing + Just (best,btr) -> + first (prepend pre best) <$> findMax btr + _ -> can'tHappen + + can'tHappen = + error "Data.ListTrie.Patricia.Base.findPredecessor :: internal error" + +-- O(m) +findSuccessor :: (Boolable (st a), Trie trie st map k, OrdMap map k) + => [k] -> trie map k a -> Maybe ([k], a) +findSuccessor _ tr | null tr = Nothing +findSuccessor xs_ tr_ = go xs_ tr_ + where + go xs tr = + let (_,pre,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) pre xs of + Same -> do (k,t) <- fst $ Map.minViewWithKey m + first (prepend pre k) <$> findMin t + + DifferedAt _ (p:_) (x:_) -> + case Map.ordCmp m p x of + LT -> Nothing + GT -> findMin tr + EQ -> can'tHappen + + PostFix (Left _) -> findMin tr + PostFix (Right (y:ys)) -> + let successor = Map.findSuccessor y m + in (first (prepend pre y)<$>(Map.lookup y m >>= go ys)) + <|> + (successor >>= \(best,btr) -> + first (prepend pre best) <$> findMin btr) + + _ -> can'tHappen + + can'tHappen = + error "Data.ListTrie.Patricia.Base.findSuccessor :: internal error" + +-- * Trie-only operations + +-- O(s) +addPrefix :: (Alt st a, Trie trie st map k) + => [k] -> trie map k a -> trie map k a +addPrefix xs tr = + let (v,pre,m) = tParts tr + in mkTrie v (xs ++ pre) m + +-- O(m) +deletePrefix :: (Alt st a, Boolable (st a), Trie trie st map k) + => [k] -> trie map k a -> trie map k a +deletePrefix xs tr = + let (v,pre,m) = tParts tr + in case comparePrefixes (Map.eqCmp m) pre xs of + Same -> tryCompress (mkTrie v [] m) + PostFix (Left _) -> tr + DifferedAt _ _ _ -> empty + PostFix (Right (y:ys)) -> + case Map.lookup y m of + Nothing -> empty + Just tr' -> deletePrefix ys tr' + + _ -> + error + "Data.ListTrie.Patricia.Base.deletePrefix :: internal error" + +-- O(1) +splitPrefix :: (Alt st a, Boolable (st a), Trie trie st map k) + => trie map k a -> ([k], st a, trie map k a) +splitPrefix tr = + let (v,pre,m) = tParts tr + in (pre, v, tryCompress $ mkTrie altEmpty [] m) + +-- O(1) +children :: Trie trie st map k => trie map k a -> [(k, trie map k a)] +children = Map.toList . tMap + +-- * Visualization + +-- O(n m) +showTrieWith :: (Show k, Trie trie st map k) + => (st a -> ShowS) -> trie map k a -> ShowS +showTrieWith = go 0 + where + go indent f tr = + let (v,pre,m) = tParts tr + spre = shows pre + lpre = length (spre []) + sv = f v + lv = length (sv []) + in spre . showChar ' ' + . sv . showChar ' ' + . (foldr (.) id . zipWith (flip ($)) (False : repeat True) $ + map (\(k,t) -> \b -> let sk = shows k + lk = length (sk []) + i = indent + lpre + lv + 2 + in (if b + then showChar '\n' + . showString (replicate i ' ') + else id) + . showString "-> " + . sk . showChar ' ' + . go (i + lk + 4) f t) + (Map.toList m)) + +-- helpers + +-- mkTrie, but makes sure that empty tries don't have nonempty prefixes +-- intentionally strict in the value: gives update its semantics +safeMkTrie :: (Alt st a, Boolable (st a), Trie trie st map k) + => st a -> [k] -> CMap trie map k a -> trie map k a +safeMkTrie v p m = + if noValue v && Map.null m + then empty + else mkTrie v p m + +prepend :: [a] -> a -> [a] -> [a] +prepend prefix key = (prefix++) . (key:) + +data PrefixOrdering a + = Same + | PostFix (Either [a] [a]) + | DifferedAt [a] [a] [a] + +-- Same If they're equal. +-- PostFix (Left xs) If the first argument was longer: xs is the remainder. +-- PostFix (Right xs) Likewise, but for the second argument. +-- DifferedAt pre xs ys Otherwise. pre is the part that was the same and +-- xs and ys are the remainders for the first and second +-- arguments respectively. +-- +-- all (pre `isPrefixOf`) [xs,ys] --> True. +comparePrefixes :: (a -> a -> Bool) -> [a] -> [a] -> PrefixOrdering a +comparePrefixes = go [] + where + go _ _ [] [] = Same + go _ _ [] xs = PostFix (Right xs) + go _ _ xs [] = PostFix (Left xs) + + go samePart (===) xs@(a:as) ys@(b:bs) = + if a === b + then go (a:samePart) (===) as bs + else DifferedAt (reverse samePart) xs ys + +-- Exported for Eq/Ord instances +eqComparePrefixes :: (a -> a -> Bool) -> [a] -> [a] -> Bool +eqComparePrefixes eq xs ys = case comparePrefixes eq xs ys of + Same -> True + _ -> False + +ordComparePrefixes :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering +ordComparePrefixes ord xs ys = + case comparePrefixes (\x y -> ord x y == EQ) xs ys of + Same -> EQ + PostFix r -> either (const GT) (const LT) r + DifferedAt _ (x:_) (y:_) -> ord x y + _ -> + error$ "Data.ListTrie.Patricia.Base.ordComparePrefixes :: " ++ + "internal error" + +-- After modifying the trie, compress a trie node into the prefix if possible. +-- +-- Doesn't recurse into children, only checks if this node and its child can be +-- joined into one. Does it repeatedly, though, until it can't compress any +-- more. +-- +-- Note that this is a sledgehammer: for optimization, instead of using this in +-- every function, we could write a separate tryCompress for each function, +-- checking only for those cases that we know can arise. This has been done in +-- 'insert', at least, but not in many places. +tryCompress :: (Boolable (st a), Trie trie st map k) + => trie map k a -> trie map k a +tryCompress tr = + let (v,pre,m) = tParts tr + in case Map.singletonView m of + + -- We can compress the trie if there is only one child + Just (x, tr') + -- If the parent is empty, we can collapse it into the child + | noValue v -> tryCompress $ mkTrie v' (prepend pre x pre') subM + + -- If the parent is full and the child is empty and childless, the + -- child is irrelevant + | noValue v' && Map.null subM -> mkTrie v pre subM + where + (v',pre',subM) = tParts tr' + + -- If the trie is empty, make sure the prefix is as well. + -- + -- This case can arise in 'intersectionWith', at least. + Nothing | noValue v && Map.null m -> mkTrie v [] m + + -- Otherwise, leave it unchanged. + _ -> tr diff --git a/Data/ListTrie/Patricia/Map.hs b/Data/ListTrie/Patricia/Map.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Map.hs @@ -0,0 +1,1051 @@ +-- File created: 2008-11-12 14:16:48 + +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances + , FlexibleContexts, UndecidableInstances #-} + +#include "exports.h" + +-- | The base implementation of a Patricia trie representing a map with list +-- keys, generalized over any type of map from element values to tries. +-- +-- Worst-case complexities are given in terms of @n@, @m@, and @k@. @n@ refers +-- to the number of keys in the map and @m@ to their maximum length. @k@ refers +-- to the length of a key given to the function, not any property of the map. +-- +-- In addition, the trie's branching factor plays a part in almost every +-- operation, but the complexity depends on the underlying 'Map'. Thus, for +-- instance, 'member' is actually @O(m f(b))@ where @f(b)@ is the complexity of +-- a lookup operation on the 'Map' used. This complexity depends on the +-- underlying operation, which is not part of the specification of the visible +-- function. Thus it could change whilst affecting the complexity only for +-- certain Map types: hence this \"b factor\" is not shown explicitly. +-- +-- Disclaimer: the complexities have not been proven. +-- +-- Strict versions of functions are provided for those who want to be certain +-- that their 'TrieMap' doesn't contain values consisting of unevaluated +-- thunks. Note, however, that they do not evaluate the whole trie strictly, +-- only the values. And only to one level of depth: for instance, 'alter'' does +-- not 'seq' the value within the 'Maybe', only the 'Maybe' itself. The user +-- should add the strictness in such cases himself, if he so wishes. +-- +-- Many functions come in both ordinary and @WithKey@ forms, where the former +-- takes a function of type @a -> b@ and the latter of type @[k] -> a -> b@, +-- where @[k]@ is the key associated with the value @a@. For most of these +-- functions, there is additional overhead involved in keeping track of the +-- key: don't use the latter form of the function unless you need it. +module Data.ListTrie.Patricia.Map (MAP_EXPORTS) where + +import Control.Applicative ((<*>),(<$>)) +import Control.Arrow ((***), second) +import qualified Data.DList as DL +import Data.Either (partitionEithers) +import Data.Function (on) +import qualified Data.Foldable as F +import qualified Data.Maybe as Maybe +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable(traverse)) +import Prelude hiding (filter, foldl, foldr, lookup, map, null) +import qualified Prelude + +#if __GLASGOW_HASKELL__ +import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) +#endif + +import qualified Data.ListTrie.Base.Map as Map +import qualified Data.ListTrie.Patricia.Base as Base +import Data.ListTrie.Base.Classes (fmap') +import Data.ListTrie.Base.Map (Map, OrdMap) + +#include "docs.h" + +-- Invariant: any (Tr Nothing _ _) has at least two children, all of which are +-- Just or have a Just descendant. +-- +-- In order to avoid a lot of special casing it has to be the case that there's +-- only one way to represent a given trie. The above property makes sure of +-- that, so that, for instance, 'fromList [("foo",1)]' can only be 'Tr (Just 1) +-- "foo" Map.empty', and not 'Tr Nothing "fo" (Map.fromList [('o',Tr (Just 1) +-- "" Map.empty)])'. Base.tryCompress is a function which takes care of this. +-- +-- | The data structure itself: a map from keys of type @[k]@ to values of type +-- @v@ implemented as a trie, using @map@ to map keys of type @k@ to sub-tries. +-- +-- Regarding the instances: +-- +-- - The @Trie@ class is internal, ignore it. +-- +-- - The 'Eq' constraint for the 'Ord' instance is misleading: it is needed +-- only because 'Eq' is a superclass of 'Ord'. +-- +-- - The 'Foldable' and 'Traversable' instances allow folding over and +-- traversing only the values, not the keys. +-- +-- - The 'Monoid' instance defines 'mappend' as 'union' and 'mempty' as +-- 'empty'. +data TrieMap map k v = Tr (Maybe v) ![k] !(CMap map k v) + +type CMap map k v = map k (TrieMap map k v) + +instance Map map k => Base.Trie TrieMap Maybe map k where + mkTrie = Tr + tParts (Tr v p m) = (v,p,m) + +-- Don't use CMap in these instances since Haddock won't expand it +instance (Map map k, Eq (map k (TrieMap map k a)), Eq a) + => Eq (TrieMap map k a) + where + Tr v1 p1 m1 == Tr v2 p2 m2 = + v1 == v2 && Base.eqComparePrefixes (Map.eqCmp m1) p1 p2 + && m1 == m2 + +-- Eq constraint only needed because of superclassness... sigh +instance (Eq (map k (TrieMap map k a)), OrdMap map k, Ord k, Ord a) + => Ord (TrieMap map k a) + where + compare = compare `on` toAscList + +instance Map map k => Monoid (TrieMap map k a) where + mempty = empty + mappend = union + mconcat = unions + +instance Map map k => Functor (TrieMap map k) where + fmap = map + +instance Map map k => F.Foldable (TrieMap map k) where + foldl = foldl . flip + foldr = foldr + +instance (Map map k, Traversable (map k)) => Traversable (TrieMap map k) where + traverse f (Tr v p m) = + flip Tr p <$> traverse f v <*> traverse (traverse f) m + +instance (Map map k, Show k, Show a) => Show (TrieMap map k a) where + showsPrec p s = showParen (p > 10) $ + showString "fromList " . shows (toList s) + +instance (Map map k, Read k, Read a) => Read (TrieMap map k a) where +#if __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + fmap fromList readPrec +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList", list) <- lex r + (xs, rest) <- readsPrec (p+1) list + [(fromList xs, rest)] +#endif + +-- * Construction + +-- | @O(1)@. The empty map. +empty :: Map map k => TrieMap map k a +empty = Base.empty + +-- | @O(1)@. The singleton map containing only the given key-value pair. +singleton :: Map map k => [k] -> a -> TrieMap map k a +singleton = Base.singleton + +-- * Modification + +-- | @O(min(m,s))@. Inserts the key-value pair into the map. If the key is +-- already a member of the map, the given value replaces the old one. +-- +-- > insert = insertWith const +insert :: Map map k => [k] -> a -> TrieMap map k a -> TrieMap map k a +insert = Base.insert + +-- | @O(min(m,s))@. Like 'insert', but the new value is reduced to weak head +-- normal form before being placed into the map. +-- +-- > insert' = insertWith' const +insert' :: Map map k => [k] -> a -> TrieMap map k a -> TrieMap map k a +insert' = Base.insert' + +-- | @O(min(m,s))@. Inserts the key-value pair into the map. If the key is +-- already a member of the map, the old value is replaced by @f givenValue +-- oldValue@ where @f@ is the given function. +insertWith :: Map map k + => (a -> a -> a) -> [k] -> a -> TrieMap map k a -> TrieMap map k a +insertWith = Base.insertWith + +-- | @O(min(m,s))@. Like 'insertWith', but the new value is reduced to weak +-- head normal form before being placed into the map, whether it is the given +-- value or a result of the combining function. +insertWith' :: Map map k + => (a -> a -> a) -> [k] -> a -> TrieMap map k a -> TrieMap map k a +insertWith' = Base.insertWith' + +-- | @O(min(m,s))@. Removes the key from the map along with its associated +-- value. If the key is not a member of the map, the map is unchanged. +delete :: Map map k => [k] -> TrieMap map k a -> TrieMap map k a +delete = Base.delete + +-- | @O(min(m,s))@. Adjusts the value at the given key by calling the given +-- function on it. If the key is not a member of the map, the map is unchanged. +adjust :: Map map k => (a -> a) -> [k] -> TrieMap map k a -> TrieMap map k a +adjust = Base.adjust + +-- | @O(min(m,s))@. Like 'adjust', but the function is applied strictly. +adjust' :: Map map k => (a -> a) -> [k] -> TrieMap map k a -> TrieMap map k a +adjust' = Base.adjust' + +-- | @O(min(m,s))@. Updates the value at the given key: if the given +-- function returns 'Nothing', the value and its associated key are removed; if +-- 'Just'@ a@is returned, the old value is replaced with @a@. If the key is +-- not a member of the map, the map is unchanged. +update :: Map map k + => (a -> Maybe a) -> [k] -> TrieMap map k a -> TrieMap map k a +update f k = snd . updateLookup f k + +-- | @O(min(m,s))@. Like 'update', but also returns 'Just' the original value, +-- or 'Nothing' if the key is not a member of the map. +updateLookup :: Map map k => (a -> Maybe a) + -> [k] + -> TrieMap map k a + -> (Maybe a, TrieMap map k a) +updateLookup = Base.updateLookup + +-- | @O(min(m,s))@. The most general modification function, allowing you to +-- modify the value at the given key, whether or not it is a member of the map. +-- In short: the given function is passed 'Just' the value at the key if it is +-- present, or 'Nothing' otherwise; if the function returns 'Just' a value, the +-- new value is inserted into the map, otherwise the old value is removed. More +-- precisely, for @alter f k m@: +-- +-- If @k@ is a member of @m@, @f (@'Just'@ oldValue)@ is called. Now: +-- +-- - If @f@ returned 'Just'@ newValue@, @oldValue@ is replaced with @newValue@. +-- +-- - If @f@ returned 'Nothing', @k@ and @oldValue@ are removed from the map. +-- +-- If, instead, @k@ is not a member of @m@, @f @'Nothing' is called, and: +-- +-- - If @f@ returned 'Just'@ value@, @value@ is inserted into the map, at @k@. +-- +-- - If @f@ returned 'Nothing', the map is unchanged. +-- +-- The function is applied lazily only if the given key is a prefix of more +-- than one key in the map. +alter :: Map map k + => (Maybe a -> Maybe a) -> [k] -> TrieMap map k a -> TrieMap map k a +alter = Base.alter + +-- | @O(min(m,s))@. Like 'alter', but the function is always applied strictly. +alter' :: Map map k + => (Maybe a -> Maybe a) -> [k] -> TrieMap map k a -> TrieMap map k a +alter' = Base.alter' + +-- * Querying + +-- | @O(1)@. 'True' iff the map is empty. +null :: Map map k => TrieMap map k a -> Bool +null = Base.null + +-- | @O(n m)@. The number of elements in the map. The value is built up lazily, +-- allowing for delivery of partial results without traversing the whole map. +size :: (Map map k, Num n) => TrieMap map k a -> n +size = Base.size + +-- | @O(n m)@. The number of elements in the map. The value is built strictly: +-- no value is returned until the map has been fully traversed. +size' :: (Map map k, Num n) => TrieMap map k a -> n +size' = Base.size' + +-- | @O(min(m,s))@. 'True' iff the given key is associated with a value in the +-- map. +member :: Map map k => [k] -> TrieMap map k a -> Bool +member = Base.member + +-- | @O(min(m,s))@. 'False' iff the given key is associated with a value in the +-- map. +notMember :: Map map k => [k] -> TrieMap map k a -> Bool +notMember = Base.notMember + +-- | @O(min(m,s))@. 'Just' the value in the map associated with the given key, +-- or 'Nothing' if the key is not a member of the map. +lookup :: Map map k => [k] -> TrieMap map k a -> Maybe a +lookup = Base.lookup + +-- | @O(min(m,s))@. Like 'lookup', but returns the given value when the key is +-- not a member of the map. +lookupWithDefault :: Map map k => a -> [k] -> TrieMap map k a -> a +lookupWithDefault = Base.lookupWithDefault + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first map is a submap of the second, +-- i.e. all keys that are members of the first map are also members of the +-- second map, and their associated values are the same. +-- +-- > isSubmapOf = isSubmapOfBy (==) +isSubmapOf :: (Map map k, Eq a) => TrieMap map k a -> TrieMap map k a -> Bool +isSubmapOf = isSubmapOfBy (==) + +-- | @O(min(n1 m1,n2 m2))@. Like 'isSubmapOf', but one can specify the equality +-- relation applied to the values. +-- +-- 'True' iff all keys that are members of the first map are also members of +-- the second map, and the given function @f@ returns 'True' for all @f +-- firstMapValue secondMapValue@ where @firstMapValue@ and @secondMapValue@ are +-- associated with the same key. +isSubmapOfBy :: Map map k + => (a -> b -> Bool) -> TrieMap map k a -> TrieMap map k b -> Bool +isSubmapOfBy = Base.isSubmapOfBy + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first map is a proper submap of the +-- second, i.e. all keys that are members of the first map are also members of +-- the second map, and their associated values are the same, but the maps are +-- not equal. That is, at least one key was a member of the second map but not +-- the first. +-- +-- > isProperSubmapOf = isProperSubmapOfBy (==) +isProperSubmapOf :: (Map map k, Eq a) + => TrieMap map k a -> TrieMap map k a -> Bool +isProperSubmapOf = isProperSubmapOfBy (==) + +-- | @O(min(n1 m1,n2 m2))@. Like 'isProperSubmapOf', but one can specify the +-- equality relation applied to the values. +-- +-- 'True' iff all keys that are members of the first map are also members of +-- the second map, and the given function @f@ returns 'True' for all @f +-- firstMapValue secondMapValue@ where @firstMapValue@ and @secondMapValue@ are +-- associated with the same key, and at least one key in the second map is not +-- a member of the first. +isProperSubmapOfBy :: Map map k => (a -> b -> Bool) + -> TrieMap map k a + -> TrieMap map k b + -> Bool +isProperSubmapOfBy = Base.isProperSubmapOfBy + +-- * Combination + +defaultUnion :: a -> a -> a +defaultUnion = const + +-- | @O(min(n1 m1,n2 m2))@. The union of the two maps: the map which contains +-- all keys that are members of either map. This union is left-biased: if a key +-- is a member of both maps, the value from the first map is chosen. +-- +-- The worst-case performance occurs when the two maps are identical. +-- +-- > union = unionWith const +union :: Map map k => TrieMap map k a -> TrieMap map k a -> TrieMap map k a +union = unionWith defaultUnion + +-- | @O(min(n1 m1,n2 m2))@. Like 'union', but the combining function ('const') +-- is applied strictly. +-- +-- > union' = unionWith' const +union' :: Map map k => TrieMap map k a -> TrieMap map k a -> TrieMap map k a +union' = unionWith' defaultUnion + +-- | @O(min(n1 m1,n2 m2))@. Like 'union', but the given function is used to +-- determine the new value if a key is a member of both given maps. For a +-- function @f@, the new value is @f firstMapValue secondMapValue@. +unionWith :: Map map k => (a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWith = Base.unionWith + +-- | @O(min(n1 m1,n2 m2))@. Like 'unionWith', but the combining function is +-- applied strictly. +unionWith' :: Map map k => (a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWith' = Base.unionWith' + +-- | @O(min(n1 m1,n2 m2))@. Like 'unionWith', but in addition to the two +-- values, the key is passed to the combining function. +unionWithKey :: Map map k => ([k] -> a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWithKey = Base.unionWithKey + +-- | @O(min(n1 m1,n2 m2))@. Like 'unionWithKey', but the combining function is +-- applied strictly. +unionWithKey' :: Map map k => ([k] -> a -> a -> a) + -> TrieMap map k a + -> TrieMap map k a + -> TrieMap map k a +unionWithKey' = Base.unionWithKey' + +-- | @O(sum(n))@. The union of all the maps: the map which contains all keys +-- that are members of any of the maps. If a key is a member of multiple maps, +-- the value that occurs in the earliest of the maps (according to the order of +-- the given list) is chosen. +-- +-- The worst-case performance occurs when all the maps are identical. +-- +-- > unions = unionsWith const +unions :: Map map k => [TrieMap map k a] -> TrieMap map k a +unions = unionsWith defaultUnion + +-- | @O(sum(n))@. Like 'unions', but the combining function ('const') is +-- applied strictly. +-- +-- > unions' = unionsWith' const +unions' :: Map map k => [TrieMap map k a] -> TrieMap map k a +unions' = unionsWith' defaultUnion + +-- | @O(sum(n))@. Like 'unions', but the given function determines the final +-- value if a key is a member of more than one map. The function is applied as +-- a left fold over the values in the given list's order. For example: +-- +-- > unionsWith (-) [fromList [("a",1)],fromList [("a",2)],fromList [("a",3)]] +-- > == fromList [("a",(1-2)-3)] +-- > == fromList [("a",-4)] +unionsWith :: Map map k + => (a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWith = Base.unionsWith + +-- | @O(sum(n))@. Like 'unionsWith', but the combining function is applied +-- strictly. +unionsWith' :: Map map k + => (a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWith' = Base.unionsWith' + +-- | @O(sum(n))@. Like 'unionsWith', but in addition to the two values under +-- consideration, the key is passed to the combining function. +unionsWithKey :: Map map k + => ([k] -> a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWithKey = Base.unionsWithKey + +-- | @O(sum(n))@. Like 'unionsWithKey', but the combining function is applied +-- strictly. +unionsWithKey' :: Map map k + => ([k] -> a -> a -> a) -> [TrieMap map k a] -> TrieMap map k a +unionsWithKey' = Base.unionsWithKey' + +-- | @O(min(n1 m1,n2 m2))@. The difference of the two maps: the map which +-- contains all keys that are members of the first map and not of the second. +-- +-- The worst-case performance occurs when the two maps are identical. +-- +-- > difference = differenceWith (\_ _ -> Nothing) +difference :: Map map k + => TrieMap map k a -> TrieMap map k b -> TrieMap map k a +difference = differenceWith (\_ _ -> Nothing) + +-- | @O(min(n1 m1,n2 m2))@. Like 'difference', but the given function +-- determines what to do when a key is a member of both maps. If the function +-- returns 'Nothing', the key is removed; if it returns 'Just' a new value, +-- that value replaces the old one in the first map. +differenceWith :: Map map k => (a -> b -> Maybe a) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k a +differenceWith = Base.differenceWith + +-- | @O(min(n1 m1,n2 m2))@. Like 'differenceWith', but in addition to the two +-- values, the key they are associated with is passed to the combining +-- function. +differenceWithKey :: Map map k => ([k] -> a -> b -> Maybe a) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k a +differenceWithKey = Base.differenceWithKey + +-- | @O(min(n1 m1,n2 m2))@. The intersection of the two maps: the map which +-- contains all keys that are members of both maps. +-- +-- The worst-case performance occurs when the two maps are identical. +-- +-- > intersection = intersectionWith const +intersection :: Map map k + => TrieMap map k a -> TrieMap map k b -> TrieMap map k a +intersection = intersectionWith const + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersection', but the combining function is +-- applied strictly. +-- +-- > intersection' = intersectionWith' const +intersection' :: Map map k + => TrieMap map k a -> TrieMap map k b -> TrieMap map k a +intersection' = intersectionWith' const + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersection', but the given function +-- determines the new values. +intersectionWith :: Map map k => (a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWith = Base.intersectionWith + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersectionWith', but the combining function +-- is applied strictly. +intersectionWith' :: Map map k => (a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWith' = Base.intersectionWith' + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersectionWith', but in addition to the two +-- values, the key they are associated with is passed to the combining +-- function. +intersectionWithKey :: Map map k => ([k] -> a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWithKey = Base.intersectionWithKey + +-- | @O(min(n1 m1,n2 m2))@. Like 'intersectionWithKey', but the combining +-- function is applied strictly. +intersectionWithKey' :: Map map k => ([k] -> a -> b -> c) + -> TrieMap map k a + -> TrieMap map k b + -> TrieMap map k c +intersectionWithKey' = Base.intersectionWithKey' + +-- * Filtering + +-- | @O(n m)@. Apply the given function to the elements in the map, discarding +-- those for which the function returns 'False'. +filter :: Map map k => (a -> Bool) -> TrieMap map k a -> TrieMap map k a +filter = filterWithKey . const + +-- | @O(n m)@. Like 'filter', but the key associated with the element is also +-- passed to the given predicate. +filterWithKey :: Map map k + => ([k] -> a -> Bool) -> TrieMap map k a -> TrieMap map k a +filterWithKey = Base.filterWithKey + +-- | @O(n m)@. A pair of maps: the first element contains those values for +-- which the given predicate returns 'True', and the second contains those for +-- which it was 'False'. +partition :: Map map k => (a -> Bool) + -> TrieMap map k a + -> (TrieMap map k a, TrieMap map k a) +partition = partitionWithKey . const + +-- | @O(n m)@. Like 'partition', but the key associated with the element is +-- also passed to the given predicate. +partitionWithKey :: Map map k => ([k] -> a -> Bool) + -> TrieMap map k a + -> (TrieMap map k a, TrieMap map k a) +partitionWithKey = Base.partitionWithKey + +-- | @O(n m)@. Apply the given function to the elements in the map, preserving +-- only the 'Just' results. +mapMaybe :: Map map k + => (a -> Maybe b) -> TrieMap map k a -> TrieMap map k b +mapMaybe = mapMaybeWithKey . const + +-- | @O(n m)@. Like 'mapMaybe', but the key associated with the element is also +-- passed to the given function. +mapMaybeWithKey :: Map map k + => ([k] -> a -> Maybe b) -> TrieMap map k a -> TrieMap map k b +mapMaybeWithKey f = + fromList . Maybe.mapMaybe (\(k,v) -> fmap ((,) k) (f k v)) . toList + +-- | @O(n m)@. Apply the given function to the elements in the map, separating +-- the 'Left' results from the 'Right'. The first element of the pair contains +-- the former results, and the second the latter. +mapEither :: Map map k => (a -> Either b c) + -> TrieMap map k a + -> (TrieMap map k b, TrieMap map k c) +mapEither = mapEitherWithKey . const + +-- | @O(n m)@. Like 'mapEither', but the key associated with the element is +-- also passed to the given function. +mapEitherWithKey :: Map map k => ([k] -> a -> Either b c) + -> TrieMap map k a + -> (TrieMap map k b, TrieMap map k c) +mapEitherWithKey f = + (fromList *** fromList) . partitionEithers . + Prelude.map (\(k,v) -> either (Left . (,) k) (Right . (,) k) (f k v)) . + toList + +-- * Mapping + +-- | @O(n m)@. Apply the given function to all the elements in the map. +map :: Map map k => (a -> b) -> TrieMap map k a -> TrieMap map k b +map = genericMap fmap + +-- | @O(n m)@. Like 'map', but apply the function strictly. +map' :: Map map k => (a -> b) -> TrieMap map k a -> TrieMap map k b +map' = genericMap fmap' + +genericMap :: Map map k => ((a -> b) -> Maybe a -> Maybe b) + -> (a -> b) -> TrieMap map k a -> TrieMap map k b +genericMap myFmap f (Tr v p m) = Tr (myFmap f v) p + (Map.map (genericMap myFmap f) m) + +-- | @O(n m)@. Like 'map', but also pass the key associated with the element to +-- the given function. +mapWithKey :: Map map k + => ([k] -> a -> b) -> TrieMap map k a -> TrieMap map k b +mapWithKey = genericMapWithKey fmap + +-- | @O(n m)@. Like 'mapWithKey', but apply the function strictly. +mapWithKey' :: Map map k + => ([k] -> a -> b) -> TrieMap map k a -> TrieMap map k b +mapWithKey' = genericMapWithKey fmap' + +genericMapWithKey :: Map map k + => ((a -> b) -> Maybe a -> Maybe b) + -> ([k] -> a -> b) -> TrieMap map k a -> TrieMap map k b +genericMapWithKey = go DL.empty + where + go k myFmap f (Tr v p m) = + let k' = k `DL.append` DL.fromList p + in Tr (myFmap (f $ DL.toList k') v) + p + (Map.mapWithKey (\x -> go (k' `DL.snoc` x) myFmap f) m) + +-- | @O(n m)@. Apply the given function to all the keys in a map. +-- +-- > mapKeys = mapKeysWith const +mapKeys :: (Map map k1, Map map k2) + => ([k1] -> [k2]) -> TrieMap map k1 a -> TrieMap map k2 a +mapKeys = mapKeysWith const + +-- | @O(n m)@. Like 'mapKeys', but use the first given function to combine +-- elements if the second function gives two keys the same value. +mapKeysWith :: (Map map k1, Map map k2) => (a -> a -> a) + -> ([k1] -> [k2]) + -> TrieMap map k1 a + -> TrieMap map k2 a +mapKeysWith = Base.mapKeysWith . fromListWith + +-- | @O(n m)@. Apply the given function to the contents of all the keys in the +-- map. +-- +-- > mapInKeys = mapInKeysWith const +mapInKeys :: (Map map k1, Map map k2) + => (k1 -> k2) -> TrieMap map k1 a -> TrieMap map k2 a +mapInKeys = mapInKeysWith defaultUnion + +-- | @O(n m)@. Like 'mapInKeys', but combine identical keys strictly. +-- +-- > mapInKeys' = mapInKeysWith' const +mapInKeys' :: (Map map k1, Map map k2) + => (k1 -> k2) -> TrieMap map k1 a -> TrieMap map k2 a +mapInKeys' = mapInKeysWith' defaultUnion + +-- | @O(n m)@. Like 'mapInKeys', but use the first given function to combine +-- elements if the second function gives two keys the same value. +mapInKeysWith :: (Map map k1, Map map k2) => (a -> a -> a) + -> (k1 -> k2) + -> TrieMap map k1 a + -> TrieMap map k2 a +mapInKeysWith = Base.mapInKeysWith + +-- | @O(n m)@. Like 'mapInKeysWith', but apply the combining function strictly. +mapInKeysWith' :: (Map map k1, Map map k2) => (a -> a -> a) + -> (k1 -> k2) + -> TrieMap map k1 a + -> TrieMap map k2 a +mapInKeysWith' = Base.mapInKeysWith' + +-- | @O(n m)@. Like "Data.List".@mapAccumL@ on the 'toList' representation. +-- +-- Essentially a combination of 'map' and 'foldl': the given +-- function is applied to each element of the map, resulting in a new value for +-- the accumulator and a replacement element for the map. +mapAccum :: Map map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccum = genericMapAccum Map.mapAccum (flip const) + +-- | @O(n m)@. Like 'mapAccum', but the function is applied strictly. +mapAccum' :: Map map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccum' = genericMapAccum Map.mapAccum seq + +-- | @O(n m)@. Like 'mapAccum', but the function receives the key in addition +-- to the value associated with it. +mapAccumWithKey :: Map map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumWithKey = genericMapAccumWithKey Map.mapAccumWithKey (flip const) + +-- | @O(n m)@. Like 'mapAccumWithKey', but the function is applied strictly. +mapAccumWithKey' :: Map map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumWithKey' = genericMapAccumWithKey Map.mapAccumWithKey seq + +-- | @O(n m)@. Like 'mapAccum', but in ascending order, as though operating on +-- the 'toAscList' representation. +mapAccumAsc :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAsc = genericMapAccum Map.mapAccumAsc (flip const) + +-- | @O(n m)@. Like 'mapAccumAsc', but the function is applied strictly. +mapAccumAsc' :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAsc' = genericMapAccum Map.mapAccumAsc seq + +-- | @O(n m)@. Like 'mapAccumAsc', but the function receives the key in +-- addition to the value associated with it. +mapAccumAscWithKey :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAscWithKey = genericMapAccumWithKey Map.mapAccumAscWithKey (flip const) + +-- | @O(n m)@. Like 'mapAccumAscWithKey', but the function is applied strictly. +mapAccumAscWithKey' :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumAscWithKey' = genericMapAccumWithKey Map.mapAccumAscWithKey seq + +-- | @O(n m)@. Like 'mapAccum', but in descending order, as though operating on +-- the 'toDescList' representation. +mapAccumDesc :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDesc = genericMapAccum Map.mapAccumDesc (flip const) + +-- | @O(n m)@. Like 'mapAccumDesc', but the function is applied strictly. +mapAccumDesc' :: OrdMap map k => (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDesc' = genericMapAccum Map.mapAccumDesc seq + +-- | @O(n m)@. Like 'mapAccumDesc', but the function receives the key in +-- addition to the value associated with it. +mapAccumDescWithKey :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDescWithKey = + genericMapAccumWithKey Map.mapAccumDescWithKey (flip const) + +-- | @O(n m)@. Like 'mapAccumDescWithKey', but the function is applied +-- strictly. +mapAccumDescWithKey' :: OrdMap map k => (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +mapAccumDescWithKey' = genericMapAccumWithKey Map.mapAccumDescWithKey seq + +genericMapAccum :: Map map k + => ( (acc -> TrieMap map k a -> (acc, TrieMap map k b)) + -> acc + -> CMap map k a + -> (acc, CMap map k b) + ) + -> (b -> (acc, Maybe b) -> (acc, Maybe b)) + -> (acc -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +genericMapAccum subMapAccum seeq f acc (Tr mv p m) = + let (acc', mv') = + case mv of + Nothing -> (acc, Nothing) + Just v -> + let (acc'', v') = f acc v + in v' `seeq` (acc'', Just v') + in second (Tr mv' p) $ + subMapAccum (genericMapAccum subMapAccum seeq f) acc' m + +genericMapAccumWithKey :: Map map k => ( ( acc + -> k + -> TrieMap map k a + -> (acc, TrieMap map k b) + ) + -> acc + -> CMap map k a + -> (acc, CMap map k b) + ) + -> (b -> (acc, Maybe b) -> (acc, Maybe b)) + -> (acc -> [k] -> a -> (acc, b)) + -> acc + -> TrieMap map k a + -> (acc, TrieMap map k b) +genericMapAccumWithKey = go DL.empty + where + go k subMapAccum seeq f acc (Tr mv p m) = + let k' = k `DL.append` DL.fromList p + (acc', mv') = + case mv of + Nothing -> (acc, Nothing) + Just v -> + let (acc'', v') = f acc (DL.toList k') v + in v' `seeq` (acc'', Just v') + in second (Tr mv' p) $ + subMapAccum (\a x -> go (k' `DL.snoc` x) subMapAccum seeq f a) + acc' m + +-- * Folding + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toList' representation, +-- folding only over the elements. +foldr :: Map map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldr = foldrWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toList' representation, +-- folding over both the keys and the elements. +foldrWithKey :: Map map k => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldrWithKey = Base.foldrWithKey + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toAscList' representation. +foldrAsc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldrAsc = foldrAscWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toAscList' representation, +-- folding over both the keys and the elements. +foldrAscWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldrAscWithKey = Base.foldrAscWithKey + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toDescList' representation. +foldrDesc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldrDesc = foldrDescWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toDescList' representation, +-- folding over both the keys and the elements. +foldrDescWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldrDescWithKey = Base.foldrDescWithKey + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toList representation. +foldl :: Map map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldl = foldlWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toList representation, +-- folding over both the keys and the elements. +foldlWithKey :: Map map k => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlWithKey = Base.foldlWithKey + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toAscList representation. +foldlAsc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlAsc = foldlAscWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toAscList representation, +-- folding over both the keys and the elements. +foldlAscWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlAscWithKey = Base.foldlAscWithKey + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toDescList representation. +foldlDesc :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlDesc = foldlDescWithKey . const + +-- | @O(n m)@. Equivalent to a list @foldl@ on the toDescList representation, +-- folding over both the keys and the elements. +foldlDescWithKey :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlDescWithKey = Base.foldlDescWithKey + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toList' representation. +foldl' :: Map map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldl' = foldlWithKey' . const + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toList' representation, +-- folding over both the keys and the elements. +foldlWithKey' :: Map map k => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlWithKey' = Base.foldlWithKey' + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toAscList' representation. +foldlAsc' :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlAsc' = foldlAscWithKey' . const + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toAscList' representation, +-- folding over both the keys and the elements. +foldlAscWithKey' :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlAscWithKey' = Base.foldlAscWithKey' + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toDescList' +-- representation. +foldlDesc' :: OrdMap map k => (a -> b -> b) -> b -> TrieMap map k a -> b +foldlDesc' = foldlDescWithKey' . const + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toDescList' +-- representation, folding over both the keys and the elements. +foldlDescWithKey' :: OrdMap map k + => ([k] -> a -> b -> b) -> b -> TrieMap map k a -> b +foldlDescWithKey' = Base.foldlDescWithKey' + +-- * Conversion between lists + +-- | @O(n m)@. Converts the map to a list of the key-value pairs contained +-- within, in undefined order. +toList :: Map map k => TrieMap map k a -> [([k],a)] +toList = Base.toList + +-- | @O(n m)@. Converts the map to a list of the key-value pairs contained +-- within, in ascending order. +toAscList :: OrdMap map k => TrieMap map k a -> [([k],a)] +toAscList = Base.toAscList + +-- | @O(n m)@. Converts the map to a list of the key-value pairs contained +-- within, in descending order. +toDescList :: OrdMap map k => TrieMap map k a -> [([k],a)] +toDescList = Base.toDescList + +-- | @O(n m)@. Creates a map from a list of key-value pairs. If a key occurs +-- more than once, the value from the last pair (according to the list's order) +-- is the one which ends up in the map. +-- +-- > fromList = fromListWith const +fromList :: Map map k => [([k],a)] -> TrieMap map k a +fromList = Base.fromList + +-- | @O(n m)@. Like 'fromList', but the given function is used to determine the +-- final value if a key occurs more than once. The function is applied as +-- though it were flipped and then applied as a left fold over the values in +-- the given list's order. Or, equivalently (except as far as performance is +-- concerned), as though the function were applied as a right fold over the +-- values in the reverse of the given list's order. For example: +-- +-- > fromListWith (-) [("a",1),("a",2),("a",3),("a",4)] +-- > == fromList [("a",4-(3-(2-1)))] +-- > == fromList [("a",2)] +fromListWith :: Map map k => (a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWith = Base.fromListWith + +-- | @O(n m)@. Like 'fromListWith', but the combining function is applied +-- strictly. +fromListWith' :: Map map k => (a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWith' = Base.fromListWith' + +-- | @O(n m)@. Like 'fromListWith', but the key, in addition to the values to +-- be combined, is passed to the combining function. +fromListWithKey :: Map map k + => ([k] -> a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWithKey = Base.fromListWithKey + +-- | @O(n m)@. Like 'fromListWithKey', but the combining function is applied +-- strictly. +fromListWithKey' :: Map map k + => ([k] -> a -> a -> a) -> [([k],a)] -> TrieMap map k a +fromListWithKey' = Base.fromListWithKey' + +-- * Ordering ops + +-- | @O(m)@. Removes and returns the minimal key in the map, along with the +-- value associated with it. If the map is empty, 'Nothing' and the original +-- map are returned. +minView :: OrdMap map k => TrieMap map k a -> (Maybe ([k], a), TrieMap map k a) +minView = Base.minView + +-- | @O(m)@. Removes and returns the maximal key in the map, along with the +-- value associated with it. If the map is empty, 'Nothing' and the original +-- map are returned. +maxView :: OrdMap map k => TrieMap map k a -> (Maybe ([k], a), TrieMap map k a) +maxView = Base.maxView + +-- | @O(m)@. Like 'fst' composed with 'minView'. 'Just' the minimal key in the +-- map and its associated value, or 'Nothing' if the map is empty. +findMin :: OrdMap map k => TrieMap map k a -> Maybe ([k], a) +findMin = Base.findMin + +-- | @O(m)@. Like 'fst' composed with 'maxView'. 'Just' the minimal key in the +-- map and its associated value, or 'Nothing' if the map is empty. +findMax :: OrdMap map k => TrieMap map k a -> Maybe ([k], a) +findMax = Base.findMax + +-- | @O(m)@. Like 'snd' composed with 'minView'. The map without its minimal +-- key, or the unchanged original map if it was empty. +deleteMin :: OrdMap map k => TrieMap map k a -> TrieMap map k a +deleteMin = Base.deleteMin + +-- | @O(m)@. Like 'snd' composed with 'maxView'. The map without its maximal +-- key, or the unchanged original map if it was empty. +deleteMax :: OrdMap map k => TrieMap map k a -> TrieMap map k a +deleteMax = Base.deleteMax + +-- | @O(min(m,s))@. Splits the map in two about the given key. The first +-- element of the resulting pair is a map containing the keys lesser than the +-- given key; the second contains those keys that are greater. +split :: OrdMap map k + => [k] -> TrieMap map k a -> (TrieMap map k a, TrieMap map k a) +split = Base.split + +-- | @O(min(m,s))@. Like 'split', but also returns the value associated with +-- the given key, if any. +splitLookup :: OrdMap map k => [k] + -> TrieMap map k a + -> (TrieMap map k a, Maybe a, TrieMap map k a) +splitLookup = Base.splitLookup + +-- | @O(m)@. 'Just' the key of the map which precedes the given key in order, +-- along with its associated value, or 'Nothing' if the map is empty. +findPredecessor :: OrdMap map k => [k] -> TrieMap map k a -> Maybe ([k], a) +findPredecessor = Base.findPredecessor + +-- | @O(m)@. 'Just' the key of the map which succeeds the given key in order, +-- along with its associated value, or 'Nothing' if the map is empty. +findSuccessor :: OrdMap map k => [k] -> TrieMap map k a -> Maybe ([k], a) +findSuccessor = Base.findSuccessor + +-- * Trie-only operations + +-- | @O(s)@. Prepends the given key to all the keys of the map. For example: +-- +-- > addPrefix "xa" (fromList [("a",1),("b",2)]) +-- > == fromList [("xaa",1),("xab",2)] +addPrefix :: Map map k => [k] -> TrieMap map k a -> TrieMap map k a +addPrefix = Base.addPrefix + +-- | @O(m)@. The map which contains all keys of which the given key is a +-- prefix, with the prefix removed from each key. If the given key is not a +-- prefix of any key in the map, the map is returned unchanged. For example: +-- +-- > deletePrefix "a" (fromList [("a",1),("ab",2),("ac",3)]) +-- > == fromList [("",1),("b",2),("c",3)] +-- +-- This function can be used, for instance, to reduce potentially expensive I/O +-- operations: if you need to find the value in a map associated with a string, +-- but you only have a prefix of it and retrieving the rest is an expensive +-- operation, calling 'deletePrefix' with what you have might allow you to +-- avoid the operation: if the resulting map is empty, the entire string cannot +-- be a member of the map. +deletePrefix :: Map map k => [k] -> TrieMap map k a -> TrieMap map k a +deletePrefix = Base.deletePrefix + +-- | @O(1)@. A triple containing the longest common prefix of all keys in the +-- map, the value associated with that prefix, if any, and the map with that +-- prefix removed from all the keys as well as the map itself. Examples: +-- +-- > splitPrefix (fromList [("a",1),("b",2)]) +-- > == ("", Nothing, fromList [("a",1),("b",2)]) +-- > splitPrefix (fromList [("a",1),("ab",2),("ac",3)]) +-- > == ("a", Just 1, fromList [("b",2),("c",3)]) +splitPrefix :: Map map k => TrieMap map k a -> ([k], Maybe a, TrieMap map k a) +splitPrefix = Base.splitPrefix + +-- | @O(1)@. The children of the longest common prefix in the trie as maps, +-- associated with their distinguishing key value. If the map contains less +-- than two keys, this function will return the empty list. Examples; +-- +-- > children (fromList [("a",1),("abc",2),("abcd",3)]) +-- > == [('b',fromList [("c",2),("cd",3)])] +-- > children (fromList [("b",1),("c",2)]) +-- > == [('b',fromList [("",1)]),('c',fromList [("",2)])] +children :: Map map k => TrieMap map k a -> [(k, TrieMap map k a)] +children = Base.children + +-- * Visualization + +-- | @O(n m)@. Displays the map's internal structure in an undefined way. That +-- is to say, no program should depend on the function's results. +showTrie :: (Show k, Show a, Map map k) => TrieMap map k a -> ShowS +showTrie = Base.showTrieWith $ \mv -> case mv of + Nothing -> showChar ' ' + Just v -> showsPrec 11 v + +-- | @O(n m)@. Like 'showTrie', but uses the given function to display the +-- elements of the map. Still undefined. +showTrieWith :: (Show k, Map map k) + => (Maybe a -> ShowS) -> TrieMap map k a -> ShowS +showTrieWith = Base.showTrieWith diff --git a/Data/ListTrie/Patricia/Map/Enum.hs b/Data/ListTrie/Patricia/Map/Enum.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Map/Enum.hs @@ -0,0 +1,17 @@ +-- File created: 2008-12-29 12:42:12 + +-- | A map from lists of enumerable elements to arbitrary values, based on a +-- Patricia trie. +-- +-- Note that those operations which require an ordering, such as 'toAscList', +-- do not compare the elements themselves, but rather their 'Int' +-- representation after 'fromEnum'. +module Data.ListTrie.Patricia.Map.Enum ( TrieMap + , module Data.ListTrie.Patricia.Map + ) where + +import Data.ListTrie.Base.Map (WrappedIntMap) +import Data.ListTrie.Patricia.Map hiding (TrieMap) +import qualified Data.ListTrie.Patricia.Map as Base + +type TrieMap = Base.TrieMap WrappedIntMap diff --git a/Data/ListTrie/Patricia/Map/Eq.hs b/Data/ListTrie/Patricia/Map/Eq.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Map/Eq.hs @@ -0,0 +1,13 @@ +-- File created: 2009-01-06 13:49:30 + +-- | A map from lists of elements that can be compared for equality to +-- arbitrary values, based on a Patricia trie. +module Data.ListTrie.Patricia.Map.Eq ( TrieMap + , module Data.ListTrie.Patricia.Map + ) where + +import Data.ListTrie.Base.Map (AList) +import Data.ListTrie.Patricia.Map hiding (TrieMap) +import qualified Data.ListTrie.Patricia.Map as Base + +type TrieMap = Base.TrieMap AList diff --git a/Data/ListTrie/Patricia/Map/Ord.hs b/Data/ListTrie/Patricia/Map/Ord.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Map/Ord.hs @@ -0,0 +1,13 @@ +-- File created: 2009-01-06 13:48:52 + +-- | A map from lists of elements that can be totally ordered to arbitrary +-- values, based on a Patricia trie. +module Data.ListTrie.Patricia.Map.Ord ( TrieMap + , module Data.ListTrie.Patricia.Map + ) where + +import Data.Map (Map) +import Data.ListTrie.Patricia.Map hiding (TrieMap) +import qualified Data.ListTrie.Patricia.Map as Base + +type TrieMap = Base.TrieMap Map diff --git a/Data/ListTrie/Patricia/Set.hs b/Data/ListTrie/Patricia/Set.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Set.hs @@ -0,0 +1,405 @@ +-- File created: 2008-11-08 19:22:07 + +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances + , FlexibleContexts, UndecidableInstances #-} + +#include "exports.h" + +-- | The base implementation of a Patricia trie representing a set of lists, +-- generalized over any type of map from element values to tries. +-- +-- Worst-case complexities are given in terms of @n@, @m@, and @k@. @n@ refers +-- to the number of keys in the set and @m@ to their maximum length. @k@ refers +-- to the length of a key given to the function, not any property of the set. +-- +-- In addition, the trie's branching factor plays a part in almost every +-- operation, but the complexity depends on the underlying 'Map'. Thus, for +-- instance, 'member' is actually @O(m f(b))@ where @f(b)@ is the complexity of +-- a lookup operation on the 'Map' used. This complexity depends on the +-- underlying operation, which is not part of the specification of the visible +-- function. Thus it could change whilst affecting the complexity only for +-- certain Map types: hence this \"b factor\" is not shown explicitly. +-- +-- Disclaimer: the complexities have not been proven. +module Data.ListTrie.Patricia.Set (SET_EXPORTS) where + +import Control.Arrow ((***), second) +import Data.Function (on) +import Data.Monoid (Monoid(..)) +import Prelude hiding (filter, foldl, foldr, map, null) +import qualified Prelude + +#if __GLASGOW_HASKELL__ +import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) +#endif + +import qualified Data.ListTrie.Base.Map as Map +import qualified Data.ListTrie.Patricia.Base as Base +import Data.ListTrie.Base.Classes (Identity(..), Unwrappable(..)) +import Data.ListTrie.Base.Map (Map, OrdMap) +import Data.ListTrie.Util ((.:), (.:.), both) + +#include "docs.h" + +-- Invariant: any (Tr False _ _) has at least two children, all of which are +-- True or have a True descendant. +-- +-- In order to avoid a lot of special casing it has to be the case that there's +-- only one way to represent a given trie. The above property makes sure of +-- that, so that, for instance, 'fromList ["foo"]' can only be 'Tr True "foo" +-- Map.empty', and not 'Tr False "fo" (Map.fromList [('o',Tr True "" +-- Map.empty)])'. Base.tryCompress is a function which takes care of this. +-- +-- This Base stuff is needed just as in the non-Patricia version. +data TrieSetBase map a bool = Tr !bool ![a] !(CMap map a bool) +type CMap map a bool = map a (TrieSetBase map a bool) + +-- | The data structure itself: a set of keys of type @[a]@ implemented as a +-- trie, using @map@ to map keys of type @a@ to sub-tries. +-- +-- Regarding the instances: +-- +-- - The @CMap@ type is internal, ignore it. For 'Eq' and 'Ord' an 'Eq' +-- instance is required: what this means is that @map a v@ is expected to be +-- an instance of 'Eq', given 'Eq'@ v@. +-- +-- - The 'Eq' constraint for the 'Ord' instance is misleading: it is needed +-- only because 'Eq' is a superclass of 'Ord'. +-- +-- - The 'Monoid' instance defines 'mappend' as 'union' and 'mempty' as +-- 'empty'. +newtype TrieSet map a = TS { unTS :: TrieSetBase map a Bool } + +inTS :: (TrieSetBase map a Bool -> TrieSetBase nap b Bool) + -> (TrieSet map a -> TrieSet nap b) +inTS f = TS . f . unTS + +instance Map map k => Base.Trie TrieSetBase Identity map k where + mkTrie = Tr . unwrap + tParts (Tr b p m) = (Id b,p,m) + +-- CMap contains TrieSetBase, not TrieSet, hence we must supply these instances +-- for TrieSetBase first +instance (Map map a, Eq (CMap map a Bool)) => Eq (TrieSetBase map a Bool) where + Tr b1 p1 m1 == Tr b2 p2 m2 = + b1 == b2 && Base.eqComparePrefixes (Map.eqCmp m1) p1 p2 + && m1 == m2 + +instance (Eq (CMap map a Bool), OrdMap map a, Ord a) + => Ord (TrieSetBase map a Bool) + where + compare = compare `on` Base.toAscList + +instance (Eq (CMap map a Bool), Map map a) => Eq (TrieSet map a) where + (==) = (==) `on` unTS + +-- The CMap constraint is needed only because Eq is a superclass of Ord.... +-- sigh +instance (Eq (CMap map a Bool), OrdMap map a, Ord a) => Ord (TrieSet map a) + where + compare = compare `on` unTS + +instance Map map a => Monoid (TrieSet map a) where + mempty = empty + mappend = union + mconcat = unions + +instance (Map map a, Show a) => Show (TrieSet map a) where + showsPrec p s = showParen (p > 10) $ + showString "fromList " . shows (toList s) + +instance (Map map a, Read a) => Read (TrieSet map a) where +#if __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + fmap fromList readPrec +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList", list) <- lex r + (xs, rest) <- readsPrec (p+1) list + [(fromList xs, rest)] +#endif + +-- * Construction + +-- | @O(1)@. The empty set. +empty :: Map map a => TrieSet map a +empty = TS Base.empty + +-- | @O(1)@. The singleton set containing only the given key. +singleton :: Map map a => [a] -> TrieSet map a +singleton k = TS$ Base.singleton k True + +-- * Modification + +-- | @O(min(m,s))@. Inserts the key into the set. If the key is already a +-- member of the set, the set is unchanged. +insert :: Map map a => [a] -> TrieSet map a -> TrieSet map a +insert k = inTS$ Base.insert k True + +-- | @O(min(m,s))@. Removes the key from the set. If the key is not a member of +-- the set, the set is unchanged. +delete :: Map map a => [a] -> TrieSet map a -> TrieSet map a +delete = inTS . Base.delete + +-- * Querying + +-- | @O(1)@. 'True' iff the set is empty. +null :: Map map a => TrieSet map a -> Bool +null = Base.null . unTS + +-- | @O(n m)@. The number of keys in the set. The value is built up lazily, +-- allowing for delivery of partial results without traversing the whole set. +size :: (Map map a, Num n) => TrieSet map a -> n +size = Base.size . unTS + +-- | @O(n m)@. The number of keys in the set. The value is built strictly: no +-- value is returned until the set has been fully traversed. +size' :: (Map map a, Num n) => TrieSet map a -> n +size' = Base.size' . unTS + +-- | @O(min(m,s))@. 'True' iff the given key is contained within the set. +member :: Map map a => [a] -> TrieSet map a -> Bool +member = Base.member .:. unTS + +-- | @O(min(m,s))@. 'False' iff the given key is contained within the set. +notMember :: Map map a => [a] -> TrieSet map a -> Bool +notMember = Base.notMember .:. unTS + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first set is a subset of the second, +-- i.e. all keys that are members of the first set are also members of the +-- second set. +isSubsetOf :: Map map a => TrieSet map a -> TrieSet map a -> Bool +isSubsetOf = Base.isSubmapOfBy (&&) `on` unTS + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first set is a proper subset of the +-- second, i.e. the first is a subset of the second, but the sets are not +-- equal. +isProperSubsetOf :: Map map a => TrieSet map a -> TrieSet map a -> Bool +isProperSubsetOf = Base.isProperSubmapOfBy (&&) `on` unTS + +-- * Combination + +defaultUnion :: Bool -> Bool -> Bool +defaultUnion = error "TrieSet.union :: internal error" + +-- | @O(min(n1 m1,n2 m2))@. The union of the two sets: the set which contains +-- all keys that are members of either set. +-- +-- The worst-case performance occurs when the two sets are identical. +union :: Map map a => TrieSet map a -> TrieSet map a -> TrieSet map a +union = TS .: Base.unionWith defaultUnion `on` unTS + +-- | @O(sum(n))@. The union of all the sets: the set which contains all keys +-- that are members of any of the sets. +-- +-- The worst-case performance occurs when all the sets are identical. +unions :: Map map a => [TrieSet map a] -> TrieSet map a +unions = TS . Base.unionsWith defaultUnion . Prelude.map unTS + +-- | @O(min(n1 m1,n2 m2))@. The difference of the two sets: the set which +-- contains all keys that are members of the first set and not members of the +-- second set. +-- +-- The worst-case performance occurs when the two sets are identical. +difference :: Map map a => TrieSet map a -> TrieSet map a -> TrieSet map a +difference = TS .: Base.differenceWith + (error "TrieSet.difference :: internal error") + `on` unTS + +-- | @O(min(n1 m1,n2 m2))@. The intersection of the two sets: the set which +-- contains all keys that are members of both sets. +-- +-- The worst-case performance occurs when the two sets are identical. +intersection :: Map map a => TrieSet map a -> TrieSet map a -> TrieSet map a +intersection = TS .: Base.intersectionWith + (error "TrieSet.intersection :: internal error") + `on` unTS + +-- * Filtering + +-- | @O(n m)@. The set of those keys in the set for which the given predicate +-- returns 'True'. +filter :: Map map a => ([a] -> Bool) -> TrieSet map a -> TrieSet map a +filter p = inTS $ Base.filterWithKey (\k _ -> p k) + +-- | @O(n m)@. A pair of sets: the first element contains those keys for which +-- the given predicate returns 'True', and the second element contains those +-- for which it was 'False'. +partition :: Map map a + => ([a] -> Bool) -> TrieSet map a -> (TrieSet map a, TrieSet map a) +partition p = both TS . Base.partitionWithKey (\k _ -> p k) . unTS + +-- * Mapping + +-- | @O(n m)@. Apply the given function to all the keys in the set. +map :: (Map map a, Map map b) => ([a] -> [b]) -> TrieSet map a -> TrieSet map b +map = inTS . Base.mapKeysWith Base.fromList + +-- | @O(n m)@. Apply the given function to the contents of all the keys in the +-- set. +mapIn :: (Map map a, Map map b) => (a -> b) -> TrieSet map a -> TrieSet map b +mapIn = inTS . Base.mapInKeysWith defaultUnion + +-- * Folding + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toList' representation. +foldr :: Map map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldr f = Base.foldrWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toAscList' representation. +foldrAsc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldrAsc f = Base.foldrAscWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toDescList' representation. +foldrDesc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldrDesc f = Base.foldrDescWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl@ on the 'toList' representation. +foldl :: Map map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldl f = Base.foldlWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl@ on the 'toAscList' representation. +foldlAsc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlAsc f = Base.foldlAscWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl@ on the 'toDescList' representation. +foldlDesc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlDesc f = Base.foldlDescWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toList' representation. +foldl' :: Map map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldl' f = Base.foldlWithKey' (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toAscList' representation. +foldlAsc' :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlAsc' f = Base.foldlAscWithKey' (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toDescList' +-- representation. +foldlDesc' :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlDesc' f = Base.foldlDescWithKey' (\k _ -> f k) .:. unTS + +-- * Conversion between lists + +-- | @O(n m)@. Converts the set to a list of the keys contained within, in +-- undefined order. +toList :: Map map a => TrieSet map a -> [[a]] +toList = Prelude.map fst . Base.toList . unTS + +-- | @O(n m)@. Converts the set to a list of the keys contained within, in +-- ascending order. +toAscList :: OrdMap map a => TrieSet map a -> [[a]] +toAscList = Prelude.map fst . Base.toAscList . unTS + +-- | @O(n m)@. Converts the set to a list of the keys contained within, in +-- descending order. +toDescList :: OrdMap map a => TrieSet map a -> [[a]] +toDescList = Prelude.map fst . Base.toDescList . unTS + +-- | @O(n m)@. Creates a set from a list of keys. +fromList :: Map map a => [[a]] -> TrieSet map a +fromList = TS . Base.fromList . Prelude.map (flip (,) True) + +-- * Ordering ops + +-- | @O(m)@. Removes and returns the minimal key in the set. If the set is +-- empty, 'Nothing' and the original set are returned. +minView :: OrdMap map a => TrieSet map a -> (Maybe [a], TrieSet map a) +minView = (fmap fst *** TS) . Base.minView . unTS + +-- | @O(m)@. Removes and returns the maximal key in the set. If the set is +-- empty, 'Nothing' and the original set are returned. +maxView :: OrdMap map a => TrieSet map a -> (Maybe [a], TrieSet map a) +maxView = (fmap fst *** TS) . Base.maxView . unTS + +-- | @O(m)@. Like 'fst' composed with 'minView'. 'Just' the minimal key in the +-- set, or 'Nothing' if the set is empty. +findMin :: OrdMap map a => TrieSet map a -> Maybe [a] +findMin = fmap fst . Base.findMin . unTS + +-- | @O(m)@. Like 'fst' composed with 'maxView'. 'Just' the maximal key in the +-- set, or 'Nothing' if the set is empty. +findMax :: OrdMap map a => TrieSet map a -> Maybe [a] +findMax = fmap fst . Base.findMax . unTS + +-- | @O(m)@. Like 'snd' composed with 'minView'. The set without its minimal +-- key, or the unchanged original set if it was empty. +deleteMin :: OrdMap map a => TrieSet map a -> TrieSet map a +deleteMin = inTS Base.deleteMin + +-- | @O(m)@. Like 'snd' composed with 'maxView'. The set without its maximal +-- key, or the unchanged original set if it was empty. +deleteMax :: OrdMap map a => TrieSet map a -> TrieSet map a +deleteMax = inTS Base.deleteMax + +-- | @O(min(m,s))@. Splits the set in two about the given key. The first +-- element of the resulting pair is a set containing the keys lesser than the +-- given key; the second contains those keys that are greater. +split :: OrdMap map a => [a] -> TrieSet map a -> (TrieSet map a, TrieSet map a) +split = both TS .: Base.split .:. unTS + +-- | @O(min(m,s))@. Like 'split', but also returns whether the given key was a +-- member of the set or not. +splitMember :: OrdMap map a + => [a] -> TrieSet map a -> (TrieSet map a, Bool, TrieSet map a) +splitMember = (\(l,b,g) -> (TS l,unwrap b,TS g)) .: Base.splitLookup .:. unTS + +-- | @O(m)@. 'Just' the key of the set which precedes the given key in order, +-- or 'Nothing' if the set is empty. +findPredecessor :: OrdMap map a => [a] -> TrieSet map a -> Maybe [a] +findPredecessor = fmap fst .: Base.findPredecessor .:. unTS + +-- | @O(m)@. 'Just' the key of the set which succeeds the given key in order, +-- or 'Nothing' if the set is empty. +findSuccessor :: OrdMap map a => [a] -> TrieSet map a -> Maybe [a] +findSuccessor = fmap fst .: Base.findSuccessor .:. unTS + +-- * Trie-only operations + +-- | @O(s)@. Prepends the given key to all the keys of the set. For example: +-- +-- > addPrefix "pre" (fromList ["a","b"]) == fromList ["prea","preb"] +addPrefix :: Map map a => [a] -> TrieSet map a -> TrieSet map a +addPrefix = TS .: Base.addPrefix .:. unTS + +-- | @O(m)@. The set which contains all keys of which the given key is a +-- prefix, with the prefix removed from each key. If the given key is not a +-- prefix of any key in the set, the set is returned unchanged. For example: +-- +-- > deletePrefix "a" (fromList ["a","ab","ac"]) == fromList ["","b","c"] +-- +-- This function can be used, for instance, to reduce potentially expensive I/O +-- operations: if you need to check whether a string is a member of a set, but +-- you only have a prefix of it and retrieving the rest is an expensive +-- operation, calling 'deletePrefix' with what you have might allow you to +-- avoid the operation: if the resulting set is empty, the entire string cannot +-- be a member of the set. +deletePrefix :: Map map a => [a] -> TrieSet map a -> TrieSet map a +deletePrefix = TS .: Base.deletePrefix .:. unTS + +-- | @O(1)@. A triple containing the longest common prefix of all keys in the +-- set, whether that prefix was a member of the set, and the set with that +-- prefix removed from all the keys as well as the set itself. Examples: +-- +-- > splitPrefix (fromList ["a","b"]) == ("", False, fromList ["a","b"]) +-- > splitPrefix (fromList ["a","ab","ac"]) == ("a", True, fromList ["b","c"]) +splitPrefix :: Map map a => TrieSet map a -> ([a], Bool, TrieSet map a) +splitPrefix = (\(k,b,t) -> (k,unwrap b,TS t)) . Base.splitPrefix . unTS + +-- | @O(1)@. The children of the longest common prefix in the trie as sets, +-- associated with their distinguishing key value. If the set contains less +-- than two keys, this function will return the empty list. Examples; +-- +-- > children (fromList ["a","abc","abcd"]) == [('b',fromList ["c","cd"])] +-- > children (fromList ["b","c"]) == [('b',fromList [""]),('c',fromList [""])] +children :: Map map a => TrieSet map a -> [(a, TrieSet map a)] +children = Prelude.map (second TS) . Base.children . unTS + +-- * Visualization + +-- | @O(n m)@. Displays the set's internal structure in an undefined way. That +-- is to say, no program should depend on the function's results. +showTrie :: (Show a, Map map a) => TrieSet map a -> ShowS +showTrie = Base.showTrieWith (\(Id b) -> showChar $ if b then 'X' else ' ') + . unTS diff --git a/Data/ListTrie/Patricia/Set/Enum.hs b/Data/ListTrie/Patricia/Set/Enum.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Set/Enum.hs @@ -0,0 +1,16 @@ +-- File created: 2008-10-22 20:44:46 + +-- | A set of lists of enumerable elements, based on a Patricia trie. +-- +-- Note that those operations which require an ordering, such as 'toAscList', +-- do not compare the elements themselves, but rather their 'Int' +-- representation after 'fromEnum'. +module Data.ListTrie.Patricia.Set.Enum ( TrieSet + , module Data.ListTrie.Patricia.Set + ) where + +import Data.ListTrie.Base.Map (WrappedIntMap) +import Data.ListTrie.Patricia.Set hiding (TrieSet) +import qualified Data.ListTrie.Patricia.Set as Base + +type TrieSet = Base.TrieSet WrappedIntMap diff --git a/Data/ListTrie/Patricia/Set/Eq.hs b/Data/ListTrie/Patricia/Set/Eq.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Set/Eq.hs @@ -0,0 +1,13 @@ +-- File created: 2009-01-06 13:51:25 + +-- | A set of lists of elements that can be compared for equality, based on a +-- Patricia trie. +module Data.ListTrie.Patricia.Set.Eq ( TrieSet + , module Data.ListTrie.Patricia.Set + ) where + +import Data.ListTrie.Base.Map (AList) +import Data.ListTrie.Patricia.Set hiding (TrieSet) +import qualified Data.ListTrie.Patricia.Set as Base + +type TrieSet = Base.TrieSet AList diff --git a/Data/ListTrie/Patricia/Set/Ord.hs b/Data/ListTrie/Patricia/Set/Ord.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Patricia/Set/Ord.hs @@ -0,0 +1,13 @@ +-- File created: 2009-01-06 13:50:00 + +-- | A set of lists of elements that can be totally ordered, based on a +-- Patricia trie. +module Data.ListTrie.Patricia.Set.Ord ( TrieSet + , module Data.ListTrie.Patricia.Set + ) where + +import Data.Map (Map) +import Data.ListTrie.Patricia.Set hiding (TrieSet) +import qualified Data.ListTrie.Patricia.Set as Base + +type TrieSet = Base.TrieSet Map diff --git a/Data/ListTrie/Set.hs b/Data/ListTrie/Set.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Set.hs @@ -0,0 +1,400 @@ +-- File created: 2008-11-08 15:52:33 + +{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances + , FlexibleContexts, UndecidableInstances #-} + +#include "exports.h" + +-- | The base implementation of a trie representing a set of lists, generalized +-- over any type of map from key values to tries. +-- +-- Worst-case complexities are given in terms of @n@, @m@, and @k@. @n@ refers +-- to the number of keys in the set and @m@ to their maximum length. @k@ refers +-- to the length of a key given to the function, not any property of the set. +-- +-- In addition, the trie's branching factor plays a part in almost every +-- operation, but the complexity depends on the underlying 'Map'. Thus, for +-- instance, 'member' is actually @O(m f(b))@ where @f(b)@ is the complexity of +-- a lookup operation on the 'Map' used. This complexity depends on the +-- underlying operation, which is not part of the specification of the visible +-- function. Thus it could change whilst affecting the complexity only for +-- certain Map types: hence this \"b factor\" is not shown explicitly. +-- +-- Disclaimer: the complexities have not been proven. +module Data.ListTrie.Set (SET_EXPORTS) where + +import Control.Arrow ((***), second) +import Data.Function (on) +import Data.Monoid (Monoid(..)) +import Prelude hiding (filter, foldl, foldr, map, null) +import qualified Prelude + +#if __GLASGOW_HASKELL__ +import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) +#endif + +import qualified Data.ListTrie.Base as Base +import qualified Data.ListTrie.Base.Map as Map +import Data.ListTrie.Base.Classes (Identity(..), Unwrappable(..)) +import Data.ListTrie.Base.Map (Map, OrdMap) +import Data.ListTrie.Util ((.:), (.:.), both) + +#include "docs.h" + +-- Invariant: any (Tr False _) has a True descendant. +-- +-- We need this 'bool' and Base stuff in order to satisfy the Base.Trie type +-- class. +data TrieSetBase map a bool = Tr !bool !(CMap map a bool) +type CMap map a bool = map a (TrieSetBase map a bool) + +-- That makes TrieSet a newtype, which means some unfortunate wrapping and +-- unwrapping in the function definitions below. +-- +-- | The data structure itself: a set of keys of type @[a]@ implemented as a +-- trie, using @map@ to map keys of type @a@ to sub-tries. +-- +-- Regarding the instances: +-- +-- - The @CMap@ type is internal, ignore it. For 'Eq' and 'Ord' an 'Eq' +-- instance is required: what this means is that @map a v@ is expected to be +-- an instance of 'Eq', given 'Eq'@ v@. +-- +-- - The 'Eq' constraint for the 'Ord' instance is misleading: it is needed +-- only because 'Eq' is a superclass of 'Ord'. +-- +-- - The 'Monoid' instance defines 'mappend' as 'union' and 'mempty' as +-- 'empty'. +newtype TrieSet map a = TS { unTS :: TrieSetBase map a Bool } + +inTS :: (TrieSetBase map a Bool -> TrieSetBase nap b Bool) + -> (TrieSet map a -> TrieSet nap b) +inTS f = TS . f . unTS + +instance Map map k => Base.Trie TrieSetBase Identity map k where + mkTrie = Tr . unwrap + tParts (Tr b m) = (Id b,m) + +-- CMap contains TrieSetBase, not TrieSet, hence we must supply these instances +-- for TrieSetBase first +instance Eq (CMap map a Bool) => Eq (TrieSetBase map a Bool) where + Tr b1 m1 == Tr b2 m2 = b1 == b2 && m1 == m2 + +instance (Eq (CMap map a Bool), OrdMap map a, Ord a) + => Ord (TrieSetBase map a Bool) + where + compare = compare `on` Base.toAscList + +instance Eq (CMap map a Bool) => Eq (TrieSet map a) where + (==) = (==) `on` unTS + +-- The CMap constraint is needed only because Eq is a superclass of Ord.... +-- sigh +instance (Eq (CMap map a Bool), OrdMap map a, Ord a) => Ord (TrieSet map a) + where + compare = compare `on` unTS + +instance Map map a => Monoid (TrieSet map a) where + mempty = empty + mappend = union + mconcat = unions + +instance (Map map a, Show a) => Show (TrieSet map a) where + showsPrec p s = showParen (p > 10) $ + showString "fromList " . shows (toList s) + +instance (Map map a, Read a) => Read (TrieSet map a) where +#if __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + fmap fromList readPrec +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList", list) <- lex r + (xs, rest) <- readsPrec (p+1) list + [(fromList xs, rest)] +#endif + +-- * Construction + +-- | @O(1)@. The empty set. +empty :: Map map a => TrieSet map a +empty = TS Base.empty + +-- | @O(s)@. The singleton set containing only the given key. +singleton :: Map map a => [a] -> TrieSet map a +singleton k = TS$ Base.singleton k True + +-- * Modification + +-- | @O(min(m,s))@. Inserts the key into the set. If the key is already a +-- member of the set, the set is unchanged. +insert :: Map map a => [a] -> TrieSet map a -> TrieSet map a +insert k = inTS$ Base.insert k True + +-- | @O(min(m,s))@. Removes the key from the set. If the key is not a member of +-- the set, the set is unchanged. +delete :: Map map a => [a] -> TrieSet map a -> TrieSet map a +delete = inTS . Base.delete + +-- * Querying + +-- | @O(1)@. 'True' iff the set is empty. +null :: Map map a => TrieSet map a -> Bool +null = Base.null . unTS + +-- | @O(n m)@. The number of keys in the set. The value is built up lazily, +-- allowing for delivery of partial results without traversing the whole set. +size :: (Map map a, Num n) => TrieSet map a -> n +size = Base.size . unTS + +-- | @O(n m)@. The number of keys in the set. The value is built strictly: no +-- value is returned until the set has been fully traversed. +size' :: (Map map a, Num n) => TrieSet map a -> n +size' = Base.size' . unTS + +-- | @O(min(m,s))@. 'True' iff the given key is contained within the set. +member :: Map map a => [a] -> TrieSet map a -> Bool +member = Base.member .:. unTS + +-- | @O(min(m,s))@. 'False' iff the given key is contained within the set. +notMember :: Map map a => [a] -> TrieSet map a -> Bool +notMember = Base.notMember .:. unTS + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first set is a subset of the second, +-- i.e. all keys that are members of the first set are also members of the +-- second set. +isSubsetOf :: Map map a => TrieSet map a -> TrieSet map a -> Bool +isSubsetOf = Base.isSubmapOfBy (&&) `on` unTS + +-- | @O(min(n1 m1,n2 m2))@. 'True' iff the first set is a proper subset of the +-- second, i.e. the first is a subset of the second, but the sets are not +-- equal. +isProperSubsetOf :: Map map a => TrieSet map a -> TrieSet map a -> Bool +isProperSubsetOf = Base.isProperSubmapOfBy (&&) `on` unTS + +-- * Combination + +defaultUnion :: Bool -> Bool -> Bool +defaultUnion = error "TrieSet.union :: internal error" + +-- | @O(min(n1 m1,n2 m2))@. The union of the two sets: the set which contains +-- all keys that are members of either set. +-- +-- The worst-case performance occurs when the two sets are identical. +union :: Map map a => TrieSet map a -> TrieSet map a -> TrieSet map a +union = TS .: Base.unionWith defaultUnion `on` unTS + +-- | @O(sum(n))@. The union of all the sets: the set which contains all keys +-- that are members of any of the sets. +-- +-- The worst-case performance occurs when all the sets are identical. +unions :: Map map a => [TrieSet map a] -> TrieSet map a +unions = TS . Base.unionsWith defaultUnion . Prelude.map unTS + +-- | @O(min(n1 m1,n2 m2))@. The difference of the two sets: the set which +-- contains all keys that are members of the first set and not members of the +-- second set. +-- +-- The worst-case performance occurs when the two sets are identical. +difference :: Map map a => TrieSet map a -> TrieSet map a -> TrieSet map a +difference = TS .: Base.differenceWith + (error "TrieSet.difference :: internal error") + `on` unTS + +-- | @O(min(n1 m1,n2 m2))@. The intersection of the two sets: the set which +-- contains all keys that are members of both sets. +-- +-- The worst-case performance occurs when the two sets are identical. +intersection :: Map map a => TrieSet map a -> TrieSet map a -> TrieSet map a +intersection = TS .: Base.intersectionWith + (error "TrieSet.intersection :: internal error") + `on` unTS + +-- * Filtering + +-- | @O(n m)@. The set of those keys in the set for which the given predicate +-- returns 'True'. +filter :: Map map a => ([a] -> Bool) -> TrieSet map a -> TrieSet map a +filter p = inTS $ Base.filterWithKey (\k _ -> p k) + +-- | @O(n m)@. A pair of sets: the first element contains those keys for which +-- the given predicate returns 'True', and the second element contains those +-- for which it was 'False'. +partition :: Map map a + => ([a] -> Bool) -> TrieSet map a -> (TrieSet map a, TrieSet map a) +partition p = both TS . Base.partitionWithKey (\k _ -> p k) . unTS + +-- * Mapping + +-- | @O(n m)@. Apply the given function to all the keys in the set. +map :: (Map map a, Map map b) => ([a] -> [b]) -> TrieSet map a -> TrieSet map b +map = inTS . Base.mapKeysWith Base.fromList + +-- | @O(n m)@. Apply the given function to the contents of all the keys in the +-- set. +mapIn :: (Map map a, Map map b) => (a -> b) -> TrieSet map a -> TrieSet map b +mapIn = inTS . Base.mapInKeysWith defaultUnion + +-- * Folding + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toList' representation. +foldr :: Map map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldr f = Base.foldrWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toAscList' representation. +foldrAsc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldrAsc f = Base.foldrAscWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldr@ on the 'toDescList' representation. +foldrDesc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldrDesc f = Base.foldrDescWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl@ on the 'toList' representation. +foldl :: Map map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldl f = Base.foldlWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl@ on the 'toAscList' representation. +foldlAsc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlAsc f = Base.foldlAscWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl@ on the 'toDescList' representation. +foldlDesc :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlDesc f = Base.foldlDescWithKey (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toList' representation. +foldl' :: Map map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldl' f = Base.foldlWithKey' (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toAscList' representation. +foldlAsc' :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlAsc' f = Base.foldlAscWithKey' (\k _ -> f k) .:. unTS + +-- | @O(n m)@. Equivalent to a list @foldl'@ on the 'toDescList' +-- representation. +foldlDesc' :: OrdMap map a => ([a] -> b -> b) -> b -> TrieSet map a -> b +foldlDesc' f = Base.foldlDescWithKey' (\k _ -> f k) .:. unTS + +-- * Conversion between lists + +-- | @O(n m)@. Converts the set to a list of the keys contained within, in +-- undefined order. +toList :: Map map a => TrieSet map a -> [[a]] +toList = Prelude.map fst . Base.toList . unTS + +-- | @O(n m)@. Converts the set to a list of the keys contained within, in +-- ascending order. +toAscList :: OrdMap map a => TrieSet map a -> [[a]] +toAscList = Prelude.map fst . Base.toAscList . unTS + +-- | @O(n m)@. Converts the set to a list of the keys contained within, in +-- descending order. +toDescList :: OrdMap map a => TrieSet map a -> [[a]] +toDescList = Prelude.map fst . Base.toDescList . unTS + +-- | @O(n m)@. Creates a set from a list of keys. +fromList :: Map map a => [[a]] -> TrieSet map a +fromList = TS . Base.fromList . Prelude.map (flip (,) True) + +-- * Ordering ops + +-- | @O(m)@. Removes and returns the minimal key in the set. If the set is +-- empty, 'Nothing' and the original set are returned. +minView :: OrdMap map a => TrieSet map a -> (Maybe [a], TrieSet map a) +minView = (fmap fst *** TS) . Base.minView . unTS + +-- | @O(m)@. Removes and returns the maximal key in the set. If the set is +-- empty, 'Nothing' and the original set are returned. +maxView :: OrdMap map a => TrieSet map a -> (Maybe [a], TrieSet map a) +maxView = (fmap fst *** TS) . Base.maxView . unTS + +-- | @O(m)@. Like 'fst' composed with 'minView'. 'Just' the minimal key in the +-- set, or 'Nothing' if the set is empty. +findMin :: OrdMap map a => TrieSet map a -> Maybe [a] +findMin = fmap fst . Base.findMin . unTS + +-- | @O(m)@. Like 'fst' composed with 'maxView'. 'Just' the maximal key in the +-- set, or 'Nothing' if the set is empty. +findMax :: OrdMap map a => TrieSet map a -> Maybe [a] +findMax = fmap fst . Base.findMax . unTS + +-- | @O(m)@. Like 'snd' composed with 'minView'. The set without its minimal +-- key, or the unchanged original set if it was empty. +deleteMin :: OrdMap map a => TrieSet map a -> TrieSet map a +deleteMin = inTS Base.deleteMin + +-- | @O(m)@. Like 'snd' composed with 'maxView'. The set without its maximal +-- key, or the unchanged original set if it was empty. +deleteMax :: OrdMap map a => TrieSet map a -> TrieSet map a +deleteMax = inTS Base.deleteMax + +-- | @O(min(m,s))@. Splits the set in two about the given key. The first +-- element of the resulting pair is a set containing the keys lesser than the +-- given key; the second contains those keys that are greater. +split :: OrdMap map a => [a] -> TrieSet map a -> (TrieSet map a, TrieSet map a) +split = both TS .: Base.split .:. unTS + +-- | @O(min(m,s))@. Like 'split', but also returns whether the given key was a +-- member of the set or not. +splitMember :: OrdMap map a + => [a] -> TrieSet map a -> (TrieSet map a, Bool, TrieSet map a) +splitMember = (\(l,b,g) -> (TS l,unwrap b,TS g)) .: Base.splitLookup .:. unTS + +-- | @O(m)@. 'Just' the key of the set which precedes the given key in order, +-- or 'Nothing' if the set is empty. +findPredecessor :: OrdMap map a => [a] -> TrieSet map a -> Maybe [a] +findPredecessor = fmap fst .: Base.findPredecessor .:. unTS + +-- | @O(m)@. 'Just' the key of the set which succeeds the given key in order, +-- or 'Nothing' if the set is empty. +findSuccessor :: OrdMap map a => [a] -> TrieSet map a -> Maybe [a] +findSuccessor = fmap fst .: Base.findSuccessor .:. unTS + +-- * Trie-only operations + +-- | @O(s)@. Prepends the given key to all the keys of the set. For example: +-- +-- > addPrefix "pre" (fromList ["a","b"]) == fromList ["prea","preb"] +addPrefix :: Map map a => [a] -> TrieSet map a -> TrieSet map a +addPrefix = TS .: Base.addPrefix .:. unTS + +-- | @O(m)@. The set which contains all keys of which the given key is a +-- prefix, with the prefix removed from each key. If the given key is not a +-- prefix of any key in the set, the set is returned unchanged. For example: +-- +-- > deletePrefix "a" (fromList ["a","ab","ac"]) == fromList ["","b","c"] +-- +-- This function can be used, for instance, to reduce potentially expensive I/O +-- operations: if you need to check whether a string is a member of a set, but +-- you only have a prefix of it and retrieving the rest is an expensive +-- operation, calling 'deletePrefix' with what you have might allow you to +-- avoid the operation: if the resulting set is empty, the entire string cannot +-- be a member of the set. +deletePrefix :: Map map a => [a] -> TrieSet map a -> TrieSet map a +deletePrefix = TS .: Base.deletePrefix .:. unTS + +-- | @O(m)@. A triple containing the longest common prefix of all keys in the +-- set, whether that prefix was a member of the set, and the set with that +-- prefix removed from all the keys as well as the set itself. Examples: +-- +-- > splitPrefix (fromList ["a","b"]) == ("", False, fromList ["a","b"]) +-- > splitPrefix (fromList ["a","ab","ac"]) == ("a", True, fromList ["b","c"]) +splitPrefix :: Map map a => TrieSet map a -> ([a], Bool, TrieSet map a) +splitPrefix = (\(k,b,t) -> (k,unwrap b,TS t)) . Base.splitPrefix . unTS + +-- | @O(m)@. The children of the longest common prefix in the trie as sets, +-- associated with their distinguishing key value. If the set contains less +-- than two keys, this function will return the empty list. Examples; +-- +-- > children (fromList ["a","abc","abcd"]) == [('b',fromList ["c","cd"])] +-- > children (fromList ["b","c"]) == [('b',fromList [""]),('c',fromList [""])] +children :: Map map a => TrieSet map a -> [(a, TrieSet map a)] +children = Prelude.map (second TS) . Base.children . unTS + +-- * Visualization + +-- | @O(n m)@. Displays the set's internal structure in an undefined way. That +-- is to say, no program should depend on the function's results. +showTrie :: (Show a, Map map a) => TrieSet map a -> ShowS +showTrie = Base.showTrieWith (\(Id b) -> showChar $ if b then 'X' else ' ') + . unTS diff --git a/Data/ListTrie/Set/Enum.hs b/Data/ListTrie/Set/Enum.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Set/Enum.hs @@ -0,0 +1,14 @@ +-- File created: 2008-10-18 21:33:40 + +-- | A set of lists of enumerable elements, based on a trie. +-- +-- Note that those operations which require an ordering, such as 'toAscList', +-- do not compare the elements themselves, but rather their Int representation +-- after 'fromEnum'. +module Data.ListTrie.Set.Enum (TrieSet, module Data.ListTrie.Set) where + +import Data.ListTrie.Base.Map (WrappedIntMap) +import Data.ListTrie.Set hiding (TrieSet) +import qualified Data.ListTrie.Set as Base + +type TrieSet = Base.TrieSet WrappedIntMap diff --git a/Data/ListTrie/Set/Eq.hs b/Data/ListTrie/Set/Eq.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Set/Eq.hs @@ -0,0 +1,11 @@ +-- File created: 2009-01-06 13:26:03 + +-- | A set of lists of elements that can be compared for equality, based on a +-- trie. +module Data.ListTrie.Set.Eq (TrieSet, module Data.ListTrie.Set) where + +import Data.ListTrie.Base.Map (AList) +import Data.ListTrie.Set hiding (TrieSet) +import qualified Data.ListTrie.Set as Base + +type TrieSet = Base.TrieSet AList diff --git a/Data/ListTrie/Set/Ord.hs b/Data/ListTrie/Set/Ord.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Set/Ord.hs @@ -0,0 +1,10 @@ +-- File created: 2009-01-06 13:18:32 + +-- | A set of lists of elements that can be totally ordered, based on a trie. +module Data.ListTrie.Set.Ord (TrieSet, module Data.ListTrie.Set) where + +import Data.Map (Map) +import Data.ListTrie.Set hiding (TrieSet) +import qualified Data.ListTrie.Set as Base + +type TrieSet = Base.TrieSet Map diff --git a/Data/ListTrie/Util.hs b/Data/ListTrie/Util.hs new file mode 100644 --- /dev/null +++ b/Data/ListTrie/Util.hs @@ -0,0 +1,14 @@ +-- File created: 2008-12-27 22:04:52 + +module Data.ListTrie.Util ((.:), (.:.), both) where + +infixr 9 .:, .:. + +(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) +(f .: g) x y = f (g x y) + +(.:.) :: (a -> b -> c) -> (d -> b) -> (a -> d -> c) +(f .:. g) x y = f x (g y) + +both :: (a -> b) -> (a,a) -> (b,b) +both f (a,b) = (f a, f b) diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,24 @@ +Copyright (c) 2009 Matti Niemenmaa +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. + * Neither the name of the project nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/headers/docs.h b/headers/docs.h new file mode 100644 --- /dev/null +++ b/headers/docs.h @@ -0,0 +1,16 @@ +-- File created: 2009-03-08 20:36:00 + +-- $trie-only-ops +-- +-- Functions which utilize the unique structure of tries. +-- +-- 'addPrefix' and 'deletePrefix' allow fast adding and removing of prefixes +-- to/from all keys of a trie. +-- +-- 'splitPrefix' and 'children' allow traversing of a trie in a manner suitable +-- for its structure. + +-- I would have most of the docs here but using #defines and relying on cpphs's +-- --layout flag is a pain due to +-- http://hackage.haskell.org/trac/hackage/ticket/519, and Haddock can't help +-- me until http://trac.haskell.org/haddock/ticket/97 gets attention. diff --git a/headers/exports.h b/headers/exports.h new file mode 100644 --- /dev/null +++ b/headers/exports.h @@ -0,0 +1,134 @@ +-- File created: 2008-12-30 18:33:18 + +#define SET_EXPORTS \ + {- * Set type -} \ + TrieSet, \ + {- * Construction -} \ + empty, singleton, \ + \ + {- * Modification -} \ + insert, delete, \ + \ + {- * Querying -} \ + null, size, size', member, notMember, \ + \ + {- ** Subsets -} \ + isSubsetOf, isProperSubsetOf, \ + \ + {- * Combination -} \ + union, unions, difference, intersection, \ + \ + {- * Filtering -} \ + filter, partition, \ + \ + {- * Mapping -} \ + map, mapIn, \ + \ + {- * Folding -} \ + foldr, foldrAsc, foldrDesc, \ + foldl, foldlAsc, foldlDesc, \ + foldl', foldlAsc', foldlDesc', \ + \ + {- * Conversion to and from lists -} \ + toList, toAscList, toDescList, fromList, \ + \ + {- * Ordering-sensitive operations -} \ + {- ** Minimum and maximum -} \ + minView, maxView, findMin, findMax, deleteMin, deleteMax, \ + \ + {- ** Predecessor and successor -} \ + split, splitMember, \ + findPredecessor, findSuccessor, \ + \ + {- * Trie-specific operations -} \ + {- $trie-only-ops -} \ + addPrefix, deletePrefix, splitPrefix, children, \ + \ + {- * Visualization -} \ + showTrie + +#define MAP_EXPORTS \ + {- * Map type -} \ + TrieMap, \ + \ + {- * Construction -} \ + empty, singleton, \ + \ + {- * Modification -} \ + insert, insert', insertWith, insertWith', \ + delete, \ + update, updateLookup, \ + adjust, adjust', alter, alter', \ + \ + {- * Querying -} \ + null, size, size', member, notMember, \ + lookup, lookupWithDefault, \ + \ + {- ** Submaps -} \ + isSubmapOf, isSubmapOfBy, \ + isProperSubmapOf, isProperSubmapOfBy, \ + \ + {- * Combination -} \ + {- ** Union -} \ + union, union', unions, unions', \ + unionWith, unionWithKey, unionsWith, unionsWithKey, \ + unionWith', unionWithKey', unionsWith', unionsWithKey', \ + \ + {- ** Difference -} \ + difference, differenceWith, differenceWithKey, \ + \ + {- ** Intersection -} \ + intersection, intersection', \ + intersectionWith, intersectionWithKey, \ + intersectionWith', intersectionWithKey', \ + \ + {- * Filtering -} \ + filter, filterWithKey, partition, partitionWithKey, \ + mapMaybe, mapMaybeWithKey, mapEither, mapEitherWithKey, \ + \ + {- * Mapping -} \ + {- ** Values -} \ + map, map', mapWithKey, mapWithKey', \ + \ + {- ** Keys -} \ + mapKeys, mapKeysWith, \ + mapInKeys, mapInKeys', mapInKeysWith, mapInKeysWith', \ + \ + {- ** With accumulation -} \ + mapAccum, mapAccumWithKey, \ + mapAccum', mapAccumWithKey', \ + mapAccumAsc, mapAccumAscWithKey, \ + mapAccumAsc', mapAccumAscWithKey', \ + mapAccumDesc, mapAccumDescWithKey, \ + mapAccumDesc', mapAccumDescWithKey', \ + \ + {- * Folding -} \ + foldr, foldrWithKey, \ + foldrAsc, foldrAscWithKey, \ + foldrDesc, foldrDescWithKey, \ + foldl, foldlWithKey, \ + foldlAsc, foldlAscWithKey, \ + foldlDesc, foldlDescWithKey, \ + foldl', foldlWithKey', \ + foldlAsc', foldlAscWithKey', \ + foldlDesc', foldlDescWithKey', \ + \ + {- * Conversion to and from lists -} \ + toList, toAscList, toDescList, fromList, \ + fromListWith, fromListWithKey, \ + fromListWith', fromListWithKey', \ + \ + {- * Ordering-sensitive operations -} \ + {- ** Minimum and maximum -} \ + minView, maxView, findMin, findMax, deleteMin, deleteMax, \ + \ + {- ** Predecessor and successor -} \ + split, splitLookup, \ + findPredecessor, findSuccessor, \ + \ + {- * Trie-specific operations -} \ + {- $trie-only-ops -} \ + addPrefix, deletePrefix, splitPrefix, children, \ + \ + {- * Visualization -} \ + showTrie, showTrieWith diff --git a/list-tries.cabal b/list-tries.cabal new file mode 100644 --- /dev/null +++ b/list-tries.cabal @@ -0,0 +1,79 @@ +Cabal-Version: >= 1.6 + +Name: list-tries +Version: 0.0 +Homepage: http://iki.fi/matti.niemenmaa/list-tries/ +Synopsis: Tries and Patricia tries: finite sets and maps for list keys +Category: Data, Data Structures +Stability: provisional +Description: + This library provides implementations of finite sets and maps for list keys + using tries, both simple and of the Patricia kind. In most (or all? sorry, + haven't benchmarked yet) cases, the Patricia tries will have better + performance, so use them unless you have reasons not to. + . + The data types are parametrized over the map type they use internally to + store the child nodes: this allows extending them to support different kinds + of key types or increasing efficiency. Child maps are required to be + instances of the Map class in Data.ListTrie.Base.Map. Some operations + additionally require an OrdMap instance. + . + The Eq, Ord, and Enum modules contain ready structures for key types which + are instances of those classes, using lists of pairs, Data.Map, and + Data.IntMap respectively. + +Author: Matti Niemenmaa +Maintainer: Matti Niemenmaa +License: BSD3 +License-File: LICENSE.txt + +Build-Type: Simple + +Extra-Source-Files: headers/*.h + tests/README.txt + tests/*.hs + tests/Tests/*.hs + +Flag containers03 + Description: Assume that containers has a version number of at least 0.3. If + false, some functionality cannot be implemented and is changed + to call 'error' instead. Defaults to False as such a version + hasn't yet been released. + Default: False + +Library + Extensions: CPP + + if flag(containers03) + Build-Depends: base >= 3 && < 4.1 + , containers >= 0.3 && < 0.4 + , dlist == 0.4.* + else + Build-Depends: base >= 3 && < 4.1 + , containers >= 0.2 && < 0.3 + , dlist == 0.4.* + + Exposed-Modules: Data.ListTrie.Base.Map + Data.ListTrie.Map + Data.ListTrie.Map.Eq + Data.ListTrie.Map.Ord + Data.ListTrie.Map.Enum + Data.ListTrie.Set + Data.ListTrie.Set.Eq + Data.ListTrie.Set.Ord + Data.ListTrie.Set.Enum + Data.ListTrie.Patricia.Map + Data.ListTrie.Patricia.Map.Eq + Data.ListTrie.Patricia.Map.Ord + Data.ListTrie.Patricia.Map.Enum + Data.ListTrie.Patricia.Set + Data.ListTrie.Patricia.Set.Eq + Data.ListTrie.Patricia.Set.Ord + Data.ListTrie.Patricia.Set.Enum + Other-Modules: Data.ListTrie.Base + Data.ListTrie.Base.Classes + Data.ListTrie.Base.Map.Internal + Data.ListTrie.Patricia.Base + Data.ListTrie.Util + + Include-Dirs: headers diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,24 @@ +-- File created: 2009-01-06 12:56:34 + +module Main (main) where + +import System.Environment (getArgs) +import Test.Framework + +import qualified Tests.Cases as Cases +import qualified Tests.Properties as Properties +import qualified Tests.Strictness as Strictness + +main = do + args <- getArgs + defaultMainWithArgs tests . concat $ + [ ["--timeout", show 10] + , ["--maximum-generated-tests", show 200] + , args + ] + +tests = + [ Cases.tests + , Properties.tests + , Strictness.tests + ] diff --git a/tests/README.txt b/tests/README.txt new file mode 100644 --- /dev/null +++ b/tests/README.txt @@ -0,0 +1,18 @@ +These are the tests for the Tries library by Matti Niemenmaa, and should reside +in a subdirectory of the Tries distribution. + +To run the tests, run 'Main.hs'. + +You'll need the following packages, other versions may work but haven't been +tested: + + base == 4.* +, HUnit == 1.2.* +, QuickCheck == 2.1.* +, test-framework == 0.2.* +, test-framework-hunit == 0.2.* +, test-framework-quickcheck2 == 0.2.* +, ChasingBottoms == 1.2.* + +In addition, unlike the library itself, no attempt has been made to make sure +that the tests would work with anything other than GHC. diff --git a/tests/Tests/Base.hs b/tests/Tests/Base.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Base.hs @@ -0,0 +1,53 @@ +-- File created: 2009-01-06 13:01:36 + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances + , FunctionalDependencies, FlexibleContexts #-} + +module Tests.Base (Str(..), alpha, unArb, getKey) where + +import Control.Arrow (first) +import Test.QuickCheck (Arbitrary(arbitrary, shrink), sized, choose) + +import Data.ListTrie.Base.Map (Map) +import qualified Data.ListTrie.Set as BS +import qualified Data.ListTrie.Map as BM +import qualified Data.ListTrie.Patricia.Set as PBS +import qualified Data.ListTrie.Patricia.Map as PBM + +newtype Str = Str { unStr :: String } deriving Show + +alpha = ('0','9') + +instance Arbitrary Str where + arbitrary = sized $ \size -> do + s <- mapM (const $ choose alpha) [0..size `mod` 6] + return (Str s) + + shrink (Str s) = map Str (shrink s) + +instance Map map Char => Arbitrary ( BS.TrieSet map Char) where + arbitrary = fmap ( BS.fromList . map unArb) arbitrary +instance Map map Char => Arbitrary (PBS.TrieSet map Char) where + arbitrary = fmap (PBS.fromList . map unArb) arbitrary +instance (Map map Char, Arbitrary a) => Arbitrary ( BM.TrieMap map Char a) + where + arbitrary = fmap ( BM.fromList . map unArb) arbitrary +instance (Map map Char, Arbitrary a) => Arbitrary (PBM.TrieMap map Char a) + where + arbitrary = fmap (PBM.fromList . map unArb) arbitrary + +--------- HACKS TO MAKE LIFE EASY + +-- Some classes that allow us to convert between Str and String for both Sets +-- (where we're interested only in Str) and Maps (where it's (Str,value)) +-- without having to write the functions twice, adding complexity either to +-- them or to TH. + +class UnArbitrary a b | b -> a where unArb :: a -> b + +instance UnArbitrary Str [Char] where unArb = unStr +instance UnArbitrary (Str,c) ([Char],c) where unArb = first unStr + +class GetKey a where getKey :: a -> String +instance GetKey [Char] where getKey = id +instance GetKey ([Char],a) where getKey = fst diff --git a/tests/Tests/Cases.hs b/tests/Tests/Cases.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Cases.hs @@ -0,0 +1,191 @@ +-- File created: 2009-01-16 18:54:26 + +{-# LANGUAGE TemplateHaskell #-} + +module Tests.Cases (tests) where + +import Control.Monad (join) +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assert) + +import qualified Data.ListTrie.Set.Eq +import qualified Data.ListTrie.Set.Ord +import qualified Data.ListTrie.Set.Enum +import qualified Data.ListTrie.Map.Eq +import qualified Data.ListTrie.Map.Ord +import qualified Data.ListTrie.Map.Enum +import qualified Data.ListTrie.Patricia.Set.Eq +import qualified Data.ListTrie.Patricia.Set.Ord +import qualified Data.ListTrie.Patricia.Set.Enum +import qualified Data.ListTrie.Patricia.Map.Eq +import qualified Data.ListTrie.Patricia.Map.Ord +import qualified Data.ListTrie.Patricia.Map.Enum + +import Data.ListTrie.Util + +import Tests.TH + +$(makeFunc allTries ["null","empty"] [d| + nullEmpty null empty = null (empty :: TrieType) + |]) + +-- "foo" is obviously not equal to "fo" +$(makeFunc setsOnly ["singleton"] [d| + eq1_s singleton = singleton "foo" /= (singleton "fo" :: TrieType) + |]) +$(makeFunc mapsOnly ["singleton"] [d| + eq1_m singleton = singleton "foo" 0 /= (singleton "fo" 0 :: TrieType) + |]) + +-- eq1 via compare instead of == +$(makeFunc setsOnly ["singleton"] [d| + ord1_s singleton = + compare (singleton "foo") (singleton "fo" :: TrieType) == GT + |]) +$(makeFunc mapsOnly ["singleton"] [d| + ord1_m singleton = + compare (singleton "foo" 0) (singleton "fo" 0 :: TrieType) == GT + |]) + +-- Subset/map tests where the maps aren't identical or empty, couldn't think of +-- a good property for such cases +$(makeFunc setsOnly ["fromList","isSubsetOf"] [d| + isSubsetOf1 fromList isSubsetOf = + (fromList ["cameroon","camera"] :: TrieType) + `isSubsetOf` + fromList ["cameroon","camera","camel","camouflage","cat"] + |]) +$(makeFunc setsOnly ["fromList","isSubsetOf"] [d| + isSubsetOf2 fromList isSubsetOf = + not $ + (fromList ["cameroon","camera","came"] :: TrieType) + `isSubsetOf` + fromList ["cameroon","camera","camel","camouflage","cat"] + |]) +$(makeFunc mapsOnly ["fromList","isSubmapOf"] [d| + isSubmapOf1 fromList isSubmapOf = + not $ + (fromList (zip ["cameroon","camera","came"] [0..]) :: TrieType) + `isSubmapOf` + fromList (zip ["cameroon","camera","camel","camouflage","cat"] [0..]) + |]) + +-- Simple tests for alter to up the code coverage a bit +$(makeFunc mapsOnly ["fromList","alter"] [d| + alter1 fromList alter = + alter (\Nothing -> Just 42) "foo" (fromList [("foobar",0)] :: TrieType) + == fromList [("foo",42),("foobar",0)] + |]) +$(makeFunc mapsOnly ["fromList","alter"] [d| + alter2 fromList alter = + let x = fromList [("xxx",0)] :: TrieType + in alter id "x" x == x + |]) + +-- Make sure insertWith applies the combining function in the right order +$(makeFunc mapsOnly ["singleton","insertWith"] [d| + insertWith1 singleton insertWith = + insertWith (-) [] 3 (singleton [] 1) == (singleton [] 2 :: TrieType) + |]) + +-- And the same for fromListWith +$(makeFunc mapsOnly ["singleton","fromListWith"] [d| + fromListWith1 singleton fromListWith = + fromListWith (-) (zip (repeat []) [1..4]) == + (singleton [] 2 :: TrieType) + |]) + +-- A couple of simple sanity tests for the *WithKey set operations since they +-- don't have properties at all +$(makeFunc mapsOnly ["fromList","unionWithKey"] [d| + unionWithKey1 fromList unionWithKey = + let al = ["tom","tome","tomatoes","fork"] + bl = ["tom","tomb","tomes","tomato","fark"] + a = fromList $ zip al [1..] :: TrieType + b = fromList $ zip bl [length al..] + in unionWithKey (\k vl vr -> vl - vr + length k) a b + == fromList (("tom",3+1-length al) : zip (tail al ++ tail bl) [2..]) + |]) +$(makeFunc mapsOnly ["fromList","differenceWithKey"] [d| + differenceWithKey1 fromList differenceWithKey = + let al = ["tom","tome","tomatoes","fork"] + bl = ["tom","tomb","tomes","tomato","fark"] + a = fromList $ zip al [1..] :: TrieType + b = fromList $ zip bl [length al..] + in differenceWithKey (\k vl vr -> Just $ vl - vr + length k) a b + == fromList (("tom",3+1-length al) : zip (tail al) [2..]) + |]) +$(makeFunc mapsOnly ["fromList","differenceWithKey"] [d| + differenceWithKey2 fromList differenceWithKey = + let al = ["shiner","shine"] + bl = ["shiner","shin","shiners","shoe"] + a = fromList $ zip al [1..] :: TrieType + b = fromList $ zip bl [length al..] + in differenceWithKey (\k vl vr -> Just $ vl - vr + length k) a b + == fromList (("shiner",6+1-length al) : zip (tail al) [2..]) + |]) +$(makeFunc mapsOnly ["fromList","differenceWithKey"] [d| + differenceWithKey3 fromList differenceWithKey = + let al = ["mar","marks","marksman","marksman's bow"] + bl = ["mark","marksman's","marksman's bow"] + a = fromList $ zip al [1..] :: TrieType + b = fromList $ zip bl [length al..] + in differenceWithKey (\_ _ _ -> Nothing) a b + == fromList (zip (init al) [1..]) + |]) +$(makeFunc mapsOnly ["fromList","intersectionWithKey"] [d| + intersectionWithKey1 fromList intersectionWithKey = + let al = ["cat","caterers","caterwauling","caterer"] + bl = ["cat","caterers","c","caterwauler"] + a = fromList $ zip al [1..] :: TrieType + b = fromList $ zip bl [length al..] + in intersectionWithKey (\k vl vr -> length k - vl + vr) a b + == fromList (zip ["cat","caterers"] $ + zipWith3 (join (.:) (+) . negate) + [1..] [length al..] (map length al)) + |]) +$(makeFunc mapsOnly ["fromList","intersectionWithKey"] [d| + intersectionWithKey2 fromList intersectionWithKey = + let al = ["wa","wart","wartortle"] + bl = ["w","wartor","wartortles","wartortle army"] + a = fromList $ zip al [1..] + b = fromList $ zip bl [length al..] + in intersectionWithKey undefined a b == (fromList [] :: TrieType) + |]) + +-- children should return something nonempty even if there's only one path +-- through the trie +$(makeFunc setsOnly ["fromList","children"] [d| + children1_s fromList children = + children (fromList ["foo","foobar"] :: TrieType) == + [('b',fromList ["ar"])] + |]) +$(makeFunc mapsOnly ["fromList","children"] [d| + children1_m fromList children = + children (fromList [("foo",1),("foobar",2)] :: TrieType) == + [('b',fromList [("ar",2)])] + |]) + +tests = testGroup "Individual cases" + [ $(makeCases allTries "nullEmpty") + , $(makeCases setsOnly "eq1_s") + , $(makeCases mapsOnly "eq1_m") + , $(makeCases setsOnly "ord1_s") + , $(makeCases mapsOnly "ord1_m") + , $(makeCases setsOnly "isSubsetOf1") + , $(makeCases setsOnly "isSubsetOf2") + , $(makeCases mapsOnly "isSubmapOf1") + , $(makeCases mapsOnly "alter1") + , $(makeCases mapsOnly "alter2") + , $(makeCases mapsOnly "insertWith1") + , $(makeCases mapsOnly "fromListWith1") + , $(makeCases mapsOnly "unionWithKey1") + , $(makeCases mapsOnly "differenceWithKey1") + , $(makeCases mapsOnly "differenceWithKey2") + , $(makeCases mapsOnly "differenceWithKey3") + , $(makeCases mapsOnly "intersectionWithKey1") + , $(makeCases mapsOnly "intersectionWithKey2") + , $(makeCases setsOnly "children1_s") + , $(makeCases mapsOnly "children1_m") + ] diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Properties.hs @@ -0,0 +1,536 @@ +-- File created: 2009-01-06 12:59:53 + +{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} + +module Tests.Properties (tests) where + +import Control.Arrow ((&&&), first) +import Data.Foldable (foldMap) +import Data.Function (on) +import Data.List (nubBy) +import Data.Maybe (fromJust, isNothing) +import Data.Monoid (mappend, mempty) +import Data.Traversable (fmapDefault, foldMapDefault) + +import Test.Framework (testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck ((==>)) + +import qualified Data.ListTrie.Set.Eq +import qualified Data.ListTrie.Set.Ord +import qualified Data.ListTrie.Set.Enum +import qualified Data.ListTrie.Map.Eq +import qualified Data.ListTrie.Map.Ord +import qualified Data.ListTrie.Map.Enum +import qualified Data.ListTrie.Patricia.Set.Eq +import qualified Data.ListTrie.Patricia.Set.Ord +import qualified Data.ListTrie.Patricia.Set.Enum +import qualified Data.ListTrie.Patricia.Map.Eq +import qualified Data.ListTrie.Patricia.Map.Ord +import qualified Data.ListTrie.Patricia.Map.Enum + +import Tests.Base +import Tests.TH + +keyNub = nubBy ((==) `on` getKey) + +-- List of tests is at the bottom because it doesn't work at the top: looks +-- like a TH limitation. + +-- The size of a set built from a list should be <= the length of the list +$(makeFunc allTries ["fromList","size"] [d| + prop_size1 fromList size l_ = let l = map unArb l_ + in size (fromList l :: TrieType) <= length l_ + |]) + +-- The size of a set should be == its length in list form +$(makeFunc allTries ["toList","size"] [d| + prop_size2 toList size m = size (m :: TrieType) == length (toList m) + |]) + +-- A set built from a list should include all elements of the original list +$(makeFunc allTries ["fromList","member"] [d| + -- using flip avoids GHC #2956 + prop_member1 fromList member l_ = + let l = map unArb l_ + m = fromList l :: TrieType + in all (flip member m . getKey) (l :: [ListElemType]) + |]) + +-- A map built from a list should have the same key/value pairs as the list +-- Of course the list needs to be nubbed; and in case of duplicates the last +-- value is preferred, so reversed +$(makeFunc mapsOnly ["fromList","lookup"] [d| + prop_lookup1 fromList lookup l_ = + let l = map unArb l_ + m = fromList l :: TrieType + in all (\(k,v) -> fromJust (lookup k m) == v) (keyNub . reverse $ l) + |]) + +-- lookupWithDefault should return the default if the key is not a member of +-- the map +$(makeFunc mapsOnly ["lookupWithDefault","notMember"] [d| + prop_lookupWithDefault1 lookupWithDefault notMember m k_ v = + let k = unArb k_ + in notMember k (m :: TrieType) ==> lookupWithDefault v k m == v + |]) + +-- Sets/maps should be subsets/submaps of themselves +$(makeFunc setsOnly ["isSubsetOf"] [d| + prop_isSubsetOf1 isSubsetOf m = isSubsetOf m (m :: TrieType) + |]) +$(makeFunc mapsOnly ["isSubmapOf"] [d| + prop_isSubmapOf1 isSubmapOf m = isSubmapOf m (m :: TrieType) + |]) + +-- Sets/maps should not be proper subsets/submaps of themselves +$(makeFunc setsOnly ["isProperSubsetOf"] [d| + prop_isProperSubsetOf1 isProperSubsetOf m = + not (isProperSubsetOf m (m :: TrieType)) + |]) +$(makeFunc mapsOnly ["isProperSubmapOf"] [d| + prop_isProperSubmapOf1 isProperSubmapOf m = + not (isProperSubmapOf m (m :: TrieType)) + |]) + +$(makeFunc setsOnly ["isSubsetOf", "isProperSubsetOf"] [d| + prop_isProperSubsetOf2 isSubsetOf isProperSubsetOf m n = + if isProperSubsetOf m n + then isSubsetOf m (n :: TrieType) + else True + |]) +$(makeFunc mapsOnly ["isSubmapOf", "isProperSubmapOf"] [d| + prop_isProperSubmapOf2 isSubmapOf isProperSubmapOf m n = + if isProperSubmapOf m n + then isSubmapOf (m :: TrieType) (n :: TrieType) + else True + |]) + +-- Looking up a singleton's key in a singleton should return the singleton's +-- value +$(makeFunc mapsOnly ["lookup","singleton"] [d| + prop_singleton1 lookup singleton k_ v = + let k = unArb k_ + in (fromJust . lookup k) (singleton k v :: TrieType) == v + |]) + +-- Inserting a value into a map and then looking it up should return that value +-- (note: regardless of whether it was there previously, the new value should +-- overwrite) +$(makeFunc mapsOnly ["lookup","insert"] [d| + prop_insert1 lookup insert m k_ v = + let k = unArb k_ + in (fromJust . lookup k . insert k v) (m :: TrieType) == v + |]) + +-- Inserting into empty is the same thing as a singleton +$(makeFunc setsOnly ["empty","insert","singleton"] [d| + prop_insert2_s empty insert singleton k_ = + let k = unArb k_ + in insert k empty == (singleton k :: TrieType) + |]) +$(makeFunc mapsOnly ["empty","insert","singleton"] [d| + prop_insert2_m empty insert singleton k_ v = + let k = unArb k_ + in insert k v empty == (singleton k v :: TrieType) + |]) + +-- Deleting a key means it should no longer be in the set +$(makeFunc allTries ["notMember","delete"] [d| + prop_delete1 notMember delete k_ m = + let k = unArb k_ + in notMember k . delete k $ (m :: TrieType) + |]) + +-- Altering a value within a map and then looking it up is the same as first +-- looking it up and then altering it: lookup k (alter f k m) == f (lookup k m) +$(makeFunc mapsOnly ["alter","lookup"] [d| + prop_alter1 alter lookup k_ m = + let k = unArb k_ + in lookup k (alter (const Nothing) k m :: TrieType) == Nothing + |]) +$(makeFunc mapsOnly ["alter","lookup"] [d| + prop_alter2 alter lookup k_ m = + let k = unArb k_ + in lookup k (alter (const (Just 2)) k m :: TrieType) == Just 2 + |]) +$(makeFunc mapsOnly ["alter","lookup"] [d| + prop_alter3 alter lookup k_ m = + let k = unArb k_ + in lookup k (alter (fmap ((+) 1)) k m :: TrieType) + == fmap ((+) 1) (lookup k m) + |]) + +-- updateLookup (const Nothing) is equivalent to lookup &&& delete +-- +-- Run on head.toList as well to make sure that the key's actually in there +-- +-- Avoids #2956 +$(makeFunc mapsOnly ["updateLookup","lookup","delete","toList","null"] [d| + prop_updateLookup1 updateLookup lookup delete toList null k_ m = + check (unArb k_) && (null m || check (getKey.head.toList $ m)) + where + check k = + updateLookup (const Nothing) k (m :: TrieType) + == (lookup k &&& delete k) m + |]) +-- updateLookup (Just . f) is equivalent to lookup &&& adjust f +-- +-- Run on head.toList as well to make sure that the key's actually in there +-- +-- Avoids #2956 +$(makeFunc mapsOnly ["updateLookup","lookup","adjust","toList","null"] [d| + prop_updateLookup2 updateLookup lookup adjust toList null k_ m = + check (unArb k_) && (null m || check (getKey.head.toList $ m)) + where + check k = + updateLookup (Just . (+) 1) k (m :: TrieType) + == (lookup k &&& adjust ((+) 1) k) m + |]) + +-- A union should include all keys of the original sets +$(makeFunc allTries ["union","member","toList"] [d| + prop_union1 union member toList m n = + let u = union m (n :: TrieType) + in all (flip member u . getKey) (toList m ++ toList n) + |]) + +-- Union with empty is the identity function +$(makeFunc allTries ["union","empty"] [d| + prop_union2 union empty m = union m empty == (m :: TrieType) + |]) +$(makeFunc allTries ["union","empty"] [d| + prop_union3 union empty m = union empty m == (m :: TrieType) + |]) + +-- Difference with oneself should result in an empty set +$(makeFunc allTries ["null","difference"] [d| + prop_difference1 null difference m = null (difference m (m :: TrieType)) + |]) + +-- Difference with empty is the identity function +$(makeFunc allTries ["empty","difference"] [d| + prop_difference2 difference empty m = difference (m :: TrieType) empty == m + |]) + +-- Difference of anything from empty should stay empty +$(makeFunc allTries ["empty","difference","null"] [d| + prop_difference3 difference empty null m = + null $ difference empty (m :: TrieType) + |]) + +-- Intersection with oneself is the identity function +$(makeFunc allTries ["intersection"] [d| + prop_intersection1 intersection m = intersection m m == (m :: TrieType) + |]) + +-- Intersection with empty should result in the empty set +$(makeFunc allTries ["intersection","null","empty"] [d| + prop_intersection2 intersection null empty m = + null $ intersection empty (m :: TrieType) + |]) + +-- De Morgan's laws: union and intersection interchange under complementation +$(makeFunc allTries ["union","difference","intersection"] [d| + prop_deMorgan1 union difference intersection a b c = + complement (intersection a b) == union (complement a) (complement b) + where + complement :: TrieType -> TrieType + complement = difference c + |]) +$(makeFunc allTries ["union","difference","intersection"] [d| + prop_deMorgan2 union difference intersection a b c = + complement (union a b) == intersection (complement a) (complement b) + where + complement :: TrieType -> TrieType + complement = difference c + |]) + +-- Partition is equivalent to two filters +-- +-- #2956 avoidance +$(makeFunc mapsOnly ["filter","partition"] [d| + prop_partition1 filter partition m = + let (a,b) = partition p (m :: TrieType) + in a == filter p m && b == filter (not.p) m + where + p = (==) 0 . flip mod 2 + |]) + +-- mapMaybe can function as a filter and mapEither as a partition +-- +-- #2956 avoidance +$(makeFunc mapsOnly ["mapMaybe","filter"] [d| + prop_mapMaybe1 mapMaybe filter m = + mapMaybe (\x -> if p x then Just x else Nothing) m + == filter p (m :: TrieType) + where + p = (==) 0 . flip mod 2 + |]) +$(makeFunc mapsOnly ["mapEither","partition"] [d| + prop_mapEither1 mapEither partition m = + mapEither (\x -> if p x then Left x else Right x) m + == partition p (m :: TrieType) + where + p = (==) 0 . flip mod 2 + |]) + +-- The maximum of the left side of a split about k is the predecessor of k +$(makeFunc allTries ["split","findMax","findPredecessor"] [d| + prop_splitMaxPredecessor split findMax findPredecessor m k_ = + let k = unArb k_ + (a,_) = split k (m :: TrieType) + in findMax a == findPredecessor k m + |]) +-- The minimum of the right side of a split about k is the successor of k +$(makeFunc allTries ["split","findMin","findSuccessor"] [d| + prop_splitMinSuccessor split findMin findSuccessor m k_ = + let k = unArb k_ + (_,b) = split k (m :: TrieType) + in findMin b == findSuccessor k m + |]) + +-- The centre of a splitLookup/Member is the result of a lookup/member +$(makeFunc mapsOnly ["splitLookup","lookup"] [d| + prop_splitLookup1 splitLookup lookup m k_ = + let k = unArb k_ + (_,v,_) = splitLookup k (m :: TrieType) + in v == lookup k m + |]) +$(makeFunc setsOnly ["splitMember","member"] [d| + prop_splitMember1 splitMember member m k_ = + let k = unArb k_ + (_,v,_) = splitMember k (m :: TrieType) + in v == member k m + |]) + +-- toList (map trie) should be equivalent to map (toList trie) +-- modulo ordering, hence toAscList +-- +-- #2956 avoidance +$(makeFunc setsOnly ["map","toAscList"] [d| + prop_mapKeys1_s map toAscList m = + toAscList (map f (m :: TrieType)) == + keyNub (Prelude.map f $ toAscList m) + where f = (:) 'x' + |]) +$(makeFunc mapsOnly ["mapKeys","toAscList"] [d| + prop_mapKeys1_m mapKeys toAscList m = + toAscList (mapKeys f (m :: TrieType)) == + keyNub (Prelude.map (first f) $ toAscList m) + where f = (:) 'x' + |]) +$(makeFunc setsOnly ["mapIn","toAscList"] [d| + prop_mapInKeys1_s mapIn toAscList m = + toAscList (mapIn f (m :: TrieType)) == + keyNub (map (map f) $ toAscList m) + where f = toEnum . (+) 1 . fromEnum :: Char -> Char + |]) +$(makeFunc mapsOnly ["mapInKeys","toAscList"] [d| + prop_mapInKeys1_m mapInKeys toAscList m = + toAscList (mapInKeys f (m :: TrieType)) == + keyNub (map (first (map f)) $ toAscList m) + where f = toEnum . (+) 1 . fromEnum :: Char -> Char + |]) + +-- toAscList = reverse . toDescList +$(makeFunc allTries ["toAscList","toDescList"] [d| + prop_ascDesc1 toAscList toDescList m = + toAscList (m :: TrieType) == reverse (toDescList m) + |]) + +-- min/maxView should be equivalent to separately finding and deleting the +-- min/max +$(makeFunc allTries ["minView","findMin","deleteMin"] [d| + prop_minView1 minView findMin deleteMin m = + minView m == (findMin &&& deleteMin) (m :: TrieType) + |]) +$(makeFunc allTries ["maxView","findMax","deleteMax"] [d| + prop_maxView1 maxView findMax deleteMax m = + maxView m == (findMax &&& deleteMax) (m :: TrieType) + |]) + +-- [] has no predecessor +$(makeFunc allTries ["findPredecessor"] [d| + prop_findPredecessor1 findPredecessor m = + isNothing (findPredecessor [] (m :: TrieType)) + |]) + +-- The successor of [] is the minimum (unless [] itself is the minimum) +$(makeFunc allTries ["findSuccessor","findMin","notMember","null"] [d| + prop_findSuccessor1 findSuccessor findMin notMember null m = + not (null m) && notMember [] m ==> + findSuccessor [] (m :: TrieType) == findMin m + |]) + +-- The minimum has no predecessor +$(makeFunc allTries ["findPredecessor","findMin","null"] [d| + prop_findPredecessor2 findPredecessor findMin null m = + not (null m) ==> + isNothing $ findPredecessor (getKey.fromJust.findMin $ m) + (m :: TrieType) + |]) +-- The maximum has no successor +$(makeFunc allTries ["findSuccessor","findMax","null"] [d| + prop_findSuccessor2 findSuccessor findMax null m = + not (null m) ==> + isNothing $ findSuccessor (getKey.fromJust.findMax $ m) + (m :: TrieType) + |]) + +-- Splitting away the common prefix and adding it and its value back +-- should change nothing +$(makeFunc setsOnly ["addPrefix","splitPrefix","insert"] [d| + prop_prefixOps1_s addPrefix splitPrefix insert m = + let (k,b,t) = splitPrefix (m :: TrieType) + in (if b then insert k else id) (addPrefix k t) == m + |]) +$(makeFunc mapsOnly ["addPrefix","splitPrefix","insert"] [d| + prop_prefixOps1_m addPrefix splitPrefix insert m = + let (k,mv,t) = splitPrefix (m :: TrieType) + in (case mv of Just v -> insert k v; _ -> id) (addPrefix k t) == m + |]) + +-- Looking up the common prefix and then adding it back should change nothing +$(makeFunc allTries ["addPrefix","splitPrefix","deletePrefix"] [d| + prop_prefixOps2 addPrefix splitPrefix deletePrefix m = + let (k,_,_) = splitPrefix (m :: TrieType) + in addPrefix k (deletePrefix k m) == m + |]) + +-- Splitting away the prefix shouldn't affect the children +$(makeFunc allTries ["splitPrefix","children"] [d| + prop_prefixOps3 splitPrefix children t = + let (_,_,t') = splitPrefix (t :: TrieType) + in children t == children t' + |]) + +-- Adding the common prefix and value to the union of the children should give +-- back the original trie +$(makeFunc setsOnly ["addPrefix","splitPrefix","children","unions","insert"] + [d| + prop_prefixOps4_s addPrefix splitPrefix children unions insert t = + let (k,b,_) = splitPrefix (t :: TrieType) + in t == ((if b then insert k else id) . addPrefix k . + unions $ map (uncurry $ addPrefix . return) + (children t)) + |]) +$(makeFunc mapsOnly ["addPrefix","splitPrefix","children","unions","insert"] + [d| + prop_prefixOps4_m addPrefix splitPrefix children unions insert t = + let (k,mv,_) = splitPrefix (t :: TrieType) + in t == ((case mv of Just v -> insert k v; _ -> id) . addPrefix k . + unions $ map (uncurry $ addPrefix . return) + (children t)) + |]) + +-- The monoid laws: associativity, left identity, right identity +$(makeFunc allTries [] [d| + prop_monoidLaw1 x y z = + mappend x (mappend y z) == mappend (mappend x y) (z :: TrieType) + |]) +$(makeFunc allTries [] [d| + prop_monoidLaw2 x = mappend mempty x == (x :: TrieType) + |]) +$(makeFunc allTries [] [d| + prop_monoidLaw3 x = mappend x mempty == (x :: TrieType) + |]) + +-- The functor laws: fmap id == id, fmap (f.g) == (fmap f . fmap g) +$(makeFunc mapsOnly [] [d| + prop_functorLaw1 x = fmap id x == (x :: TrieType) + |]) +$(makeFunc mapsOnly [] [d| + prop_functorLaw2 x = fmap (f.g) x == (fmap f . fmap g) (x :: TrieType) + where + f = (+) 10; g = (*) 2; + |]) + +-- The Traversable laws: fmap == fmapDefault, foldMap == foldMapDefault +-- Both avoid #2956 again +$(makeFunc mapsOnly [] [d| + prop_traversableLaw1 x = + fmap ((+) 1) x == fmapDefault ((+) 1) (x :: TrieType) + |]) +$(makeFunc mapsOnly [] [d| + prop_traversableLaw2 x = + foldMap (flip (:) []) x == foldMapDefault (flip (:) []) (x :: TrieType) + |]) + +-- (read.show) is the identity function +$(makeFunc allTries [] [d| + prop_showRead1 x = (read.show) (x :: TrieType) == x + |]) + +-- (compare `on` toAscList) should be equivalent to compare +$(makeFunc allTries ["toAscList"] [d| + prop_ord1 toAscList x y = + compare x (y :: TrieType) == compare (toAscList x) (toAscList y) + |]) + +tests = testGroup "QuickCheck properties" + [ $(makeProps allTries "prop_size1") + , $(makeProps allTries "prop_size2") + , $(makeProps allTries "prop_member1") + , $(makeProps mapsOnly "prop_lookup1") + , $(makeProps mapsOnly "prop_lookupWithDefault1") + , $(makeProps setsOnly "prop_isSubsetOf1") + , $(makeProps setsOnly "prop_isProperSubsetOf1") + , $(makeProps mapsOnly "prop_isSubmapOf1") + , $(makeProps mapsOnly "prop_isProperSubmapOf1") + , $(makeProps setsOnly "prop_isProperSubsetOf2") + , $(makeProps mapsOnly "prop_isProperSubmapOf2") + , $(makeProps mapsOnly "prop_singleton1") + , $(makeProps mapsOnly "prop_insert1") + , $(makeProps setsOnly "prop_insert2_s") + , $(makeProps mapsOnly "prop_insert2_m") + , $(makeProps allTries "prop_delete1") + , $(makeProps mapsOnly "prop_alter1") + , $(makeProps mapsOnly "prop_alter2") + , $(makeProps mapsOnly "prop_alter3") + , $(makeProps mapsOnly "prop_updateLookup1") + , $(makeProps mapsOnly "prop_updateLookup2") + , $(makeProps allTries "prop_union1") + , $(makeProps allTries "prop_union2") + , $(makeProps allTries "prop_union3") + , $(makeProps allTries "prop_difference1") + , $(makeProps allTries "prop_difference2") + , $(makeProps allTries "prop_difference3") + , $(makeProps allTries "prop_intersection1") + , $(makeProps allTries "prop_intersection2") + , $(makeProps allTries "prop_deMorgan1") + , $(makeProps allTries "prop_deMorgan2") + , $(makeProps mapsOnly "prop_partition1") + , $(makeProps mapsOnly "prop_mapMaybe1") + , $(makeProps mapsOnly "prop_mapEither1") + , $(makeProps allTries "prop_splitMaxPredecessor") + , $(makeProps allTries "prop_splitMinSuccessor") + , $(makeProps mapsOnly "prop_splitLookup1") + , $(makeProps setsOnly "prop_splitMember1") + , $(makeProps setsOnly "prop_mapKeys1_s") + , $(makeProps mapsOnly "prop_mapKeys1_m") + , $(makeProps setsOnly "prop_mapInKeys1_s") + , $(makeProps mapsOnly "prop_mapInKeys1_m") + , $(makeProps allTries "prop_ascDesc1") + , $(makeProps allTries "prop_minView1") + , $(makeProps allTries "prop_maxView1") + , $(makeProps allTries "prop_findPredecessor1") + , $(makeProps allTries "prop_findSuccessor1") + , $(makeProps allTries "prop_findPredecessor2") + , $(makeProps allTries "prop_findSuccessor2") + , $(makeProps setsOnly "prop_prefixOps1_s") + , $(makeProps mapsOnly "prop_prefixOps1_m") + , $(makeProps allTries "prop_prefixOps2") + , $(makeProps allTries "prop_prefixOps3") + , $(makeProps setsOnly "prop_prefixOps4_s") + , $(makeProps mapsOnly "prop_prefixOps4_m") + , $(makeProps allTries "prop_monoidLaw1") + , $(makeProps allTries "prop_monoidLaw2") + , $(makeProps allTries "prop_monoidLaw3") + , $(makeProps mapsOnly "prop_functorLaw1") + , $(makeProps mapsOnly "prop_functorLaw2") + , $(makeProps mapsOnly "prop_traversableLaw1") + , $(makeProps mapsOnly "prop_traversableLaw2") + , $(makeProps allTries "prop_showRead1") + , $(makeProps allTries "prop_ord1") + ] diff --git a/tests/Tests/Strictness.hs b/tests/Tests/Strictness.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Strictness.hs @@ -0,0 +1,388 @@ +-- File created: 2009-01-06 13:08:00 + +{-# LANGUAGE CPP, TemplateHaskell #-} + +module Tests.Strictness (tests) where + +import Test.ChasingBottoms.IsBottom (isBottom) +import Test.Framework (testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assert) + +import qualified Data.ListTrie.Set.Eq +import qualified Data.ListTrie.Set.Ord +import qualified Data.ListTrie.Set.Enum +import qualified Data.ListTrie.Map.Eq +import qualified Data.ListTrie.Map.Ord +import qualified Data.ListTrie.Map.Enum +import qualified Data.ListTrie.Patricia.Set.Eq +import qualified Data.ListTrie.Patricia.Set.Ord +import qualified Data.ListTrie.Patricia.Set.Enum +import qualified Data.ListTrie.Patricia.Map.Eq +import qualified Data.ListTrie.Patricia.Map.Ord +import qualified Data.ListTrie.Patricia.Map.Enum + +import Tests.Base +import Tests.TH + +-- size doesn't evaluate the values but it does traverse the whole trie +-- returning a single result, so it works well for checking whether there are +-- any bottoms in the trie +#define IS_LAZY (not.isBottom.size) +#define IS_STRICT ( isBottom.size) + +-- insert' should be strict in the value, insert should not. +$(makeFunc mapsOnly ["size","empty","insert"] [d| + insert size empty insert = + IS_LAZY . insert "foo" undefined $ (empty :: TrieType) + |]) +$(makeFunc mapsOnly ["size","empty","insert'"] [d| + insert' size empty insert' = + IS_STRICT . insert' "foo" undefined $ (empty :: TrieType) + |]) + +-- insertWith' should apply the combining function strictly, insertWith should +-- not. We use a singleton to make sure that the combining function is called. +$(makeFunc mapsOnly ["size","singleton","insertWith"] [d| + insertWith1 size singleton insertWith = + IS_LAZY . insertWith undefined "foo" undefined $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","insertWith'"] [d| + insertWith'1 size singleton insertWith' = + IS_STRICT . insertWith' undefined "foo" undefined $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","insertWith'"] [d| + insertWith'2 size singleton insertWith' = + IS_STRICT . insertWith' (+) "foo" undefined $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","insertWith'"] [d| + insertWith'3 size singleton insertWith' = + IS_STRICT . insertWith' undefined "foo" 0 $ + (singleton "foo" 0 :: TrieType) + |]) + +-- Also, insertWith' should always be strict in the value. +$(makeFunc mapsOnly ["size","empty","insertWith"] [d| + insertWith2 size empty insertWith = + IS_LAZY . insertWith undefined "foo" undefined $ (empty :: TrieType) + |]) +$(makeFunc mapsOnly ["size","empty","insertWith'"] [d| + insertWith'4 size empty insertWith' = + IS_STRICT . insertWith' undefined "foo" undefined $ (empty :: TrieType) + |]) + +-- As for insertWith, but for adjust' and adjust. +$(makeFunc mapsOnly ["size","singleton","adjust"] [d| + adjust size singleton adjust = + IS_LAZY . adjust undefined "foo" $ (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","adjust'"] [d| + adjust' size singleton adjust' = + IS_STRICT . adjust' undefined "foo" $ (singleton "foo" 0 :: TrieType) + |]) + +-- As above, but for alter and alter'. +-- +-- Need to use more sophisticated testing here because now the value itself is +-- ⊥, including whether it's Just or not; size wants that info. +-- +-- And there's also the following facts: +-- - Patricia's alter is lazy for only one case: the key to be altered is the +-- prefix of more than one key in the trie. +-- - Non-Patricia's alter is lazy for only one case: the key to be altered is +-- the prefix of at least one key in the trie. +-- +-- So we have to be careful about the case we test. +$(makeFunc mapsOnly ["member","fromList","alter"] [d| + alter member fromList alter = + not.isBottom.member "foob" . alter undefined "foo" $ + (fromList [("foo",1),("foob",2),("fooz",3)] :: TrieType) + |]) +$(makeFunc mapsOnly ["member","fromList","alter'"] [d| + alter' member fromList alter' = + isBottom.member "foob" . alter' undefined "foo" $ + (fromList [("foo",1),("foob",2),("fooz",3)] :: TrieType) + |]) + +-- As above, but for the union family. +$(makeFunc mapsOnly ["size","singleton","union"] [d| + union size singleton union = + IS_LAZY $ union (singleton "foo" undefined :: TrieType) + (singleton "foo" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","union'"] [d| + union' size singleton union' = + IS_STRICT $ union' (singleton "foo" undefined :: TrieType) + (singleton "foo" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","unionWith"] [d| + unionWith size singleton unionWith = + IS_LAZY $ unionWith undefined (singleton "foo" 1 :: TrieType) + (singleton "foo" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","unionWith'"] [d| + unionWith' size singleton unionWith' = + IS_STRICT $ unionWith' undefined (singleton "foo" 1 :: TrieType) + (singleton "foo" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","unionWithKey"] [d| + unionWithKey size singleton unionWithKey = + IS_LAZY $ unionWithKey undefined (singleton "foo" 1 :: TrieType) + (singleton "foo" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","unionWithKey'"] [d| + unionWithKey' size singleton unionWithKey' = + IS_STRICT $ unionWithKey' undefined (singleton "foo" 1 :: TrieType) + (singleton "foo" 1) + |]) + +-- As above, but for the unions family. +$(makeFunc mapsOnly ["size","singleton","unions"] [d| + unions size singleton unions = + IS_LAZY $ unions [singleton "foo" undefined :: TrieType + ,singleton "foo" 1 + ] + |]) +$(makeFunc mapsOnly ["size","singleton","unions'"] [d| + unions' size singleton unions' = + IS_STRICT $ unions' [singleton "foo" undefined :: TrieType + ,singleton "foo" 1 + ] + |]) +$(makeFunc mapsOnly ["size","singleton","unionsWith"] [d| + unionsWith size singleton unionsWith = + IS_LAZY $ unionsWith undefined [singleton "foo" 1 :: TrieType + ,singleton "foo" 1 + ] + |]) +$(makeFunc mapsOnly ["size","singleton","unionsWith'"] [d| + unionsWith' size singleton unionsWith' = + IS_STRICT $ unionsWith' undefined [singleton "foo" 1 :: TrieType + ,singleton "foo" 1 + ] + |]) +$(makeFunc mapsOnly ["size","singleton","unionsWithKey"] [d| + unionsWithKey size singleton unionsWithKey = + IS_LAZY $ unionsWithKey undefined [singleton "foo" 1 :: TrieType + ,singleton "foo" 1 + ] + |]) +$(makeFunc mapsOnly ["size","singleton","unionsWithKey'"] [d| + unionsWithKey' size singleton unionsWithKey' = + IS_STRICT $ unionsWithKey' undefined [singleton "foo" 1 :: TrieType + ,singleton "foo" 1 + ] + |]) + +-- As above, but for the intersection family. +$(makeFunc mapsOnly ["size","singleton","intersection"] [d| + intersection size singleton intersection = + IS_LAZY $ intersection (singleton "a" undefined :: TrieType) + (singleton "a" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","intersection'"] [d| + intersection' size singleton intersection' = + IS_STRICT $ intersection' (singleton "a" undefined :: TrieType) + (singleton "a" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","intersectionWith"] [d| + intersectionWith size singleton intersectionWith = + IS_LAZY $ intersectionWith undefined (singleton "a" 1 :: TrieType) + (singleton "a" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","intersectionWith'"] [d| + intersectionWith' size singleton intersectionWith' = + IS_STRICT $ intersectionWith' undefined (singleton "a" 1 :: TrieType) + (singleton "a" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","intersectionWithKey"] [d| + intersectionWithKey size singleton intersectionWithKey = + IS_LAZY $ intersectionWithKey undefined (singleton "a" 1 :: TrieType) + (singleton "a" 1) + |]) +$(makeFunc mapsOnly ["size","singleton","intersectionWithKey'"] [d| + intersectionWithKey' size singleton intersectionWithKey' = + IS_STRICT $ intersectionWithKey' undefined (singleton "a" 1 :: TrieType) + (singleton "a" 1) + |]) + +-- As above, but for the map family. +$(makeFunc mapsOnly ["size","singleton","map"] [d| + map size singleton map = + IS_LAZY . map undefined $ (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","map'"] [d| + map' size singleton map' = + IS_STRICT . map' undefined $ (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapWithKey"] [d| + mapWithKey size singleton mapWithKey = + IS_LAZY . mapWithKey undefined $ (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapWithKey'"] [d| + mapWithKey' size singleton mapWithKey' = + IS_STRICT . mapWithKey' undefined $ (singleton "foo" 0 :: TrieType) + |]) + +-- As above, but for the mapInKeys family. +-- +-- The *With ones need to actually trigger the union function, hence a simple +-- singleton won't do. +$(makeFunc mapsOnly ["size","fromList","mapInKeys"] [d| + mapInKeys size fromList mapInKeys = + IS_LAZY . mapInKeys (const 'x') $ + (fromList [("xy",0),("xz",undefined)] :: TrieType) + |]) +$(makeFunc mapsOnly ["size","fromList","mapInKeys'"] [d| + mapInKeys' size fromList mapInKeys' = + IS_STRICT . mapInKeys' (const 'x') $ + (fromList [("xy",0),("xz",undefined)] :: TrieType) + |]) +$(makeFunc mapsOnly ["size","fromList","mapInKeysWith"] [d| + mapInKeysWith size fromList mapInKeysWith = + IS_LAZY . mapInKeysWith undefined (const 'x') $ + (fromList [("xy",0),("xz",1)] :: TrieType) + |]) +$(makeFunc mapsOnly ["size","fromList","mapInKeysWith'"] [d| + mapInKeysWith' size fromList mapInKeysWith' = + IS_STRICT . mapInKeysWith' undefined (const 'x') $ + (fromList [("xy",0),("xz",1)] :: TrieType) + |]) + +-- As above, but for the mapAccum family. +$(makeFunc mapsOnly ["size","singleton","mapAccum"] [d| + mapAccum size singleton mapAccum = + IS_LAZY . snd . mapAccum undefined 0 $ (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccum'"] [d| + mapAccum' size singleton mapAccum' = + IS_STRICT . snd . mapAccum' undefined 0 $ (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumWithKey"] [d| + mapAccumWithKey size singleton mapAccumWithKey = + IS_LAZY . snd . mapAccumWithKey undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumWithKey'"] [d| + mapAccumWithKey' size singleton mapAccumWithKey' = + IS_STRICT . snd . mapAccumWithKey' undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumAsc"] [d| + mapAccumAsc size singleton mapAccumAsc = + IS_LAZY . snd . mapAccumAsc undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumAsc'"] [d| + mapAccumAsc' size singleton mapAccumAsc' = + IS_STRICT . snd . mapAccumAsc' undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumAscWithKey"] [d| + mapAccumAscWithKey size singleton mapAccumAscWithKey = + IS_LAZY . snd . mapAccumAscWithKey undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumAscWithKey'"] [d| + mapAccumAscWithKey' size singleton mapAccumAscWithKey' = + IS_STRICT . snd . mapAccumAscWithKey' undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumDesc"] [d| + mapAccumDesc size singleton mapAccumDesc = + IS_LAZY . snd . mapAccumDesc undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumDesc'"] [d| + mapAccumDesc' size singleton mapAccumDesc' = + IS_STRICT . snd . mapAccumDesc' undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumDescWithKey"] [d| + mapAccumDescWithKey size singleton mapAccumDescWithKey = + IS_LAZY . snd . mapAccumDescWithKey undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) +$(makeFunc mapsOnly ["size","singleton","mapAccumDescWithKey'"] [d| + mapAccumDescWithKey' size singleton mapAccumDescWithKey' = + IS_STRICT . snd . mapAccumDescWithKey' undefined 0 $ + (singleton "foo" 0 :: TrieType) + |]) + +-- As above, but for the fromListWith family. +$(makeFunc mapsOnly ["size","fromListWith"] [d| + fromListWith size fromListWith = + IS_LAZY (fromListWith undefined [("a",1),("a",2)] :: TrieType) + |]) +$(makeFunc mapsOnly ["size","fromListWith'"] [d| + fromListWith' size fromListWith' = + IS_STRICT (fromListWith' undefined [("a",1),("a",2)] :: TrieType) + |]) +$(makeFunc mapsOnly ["size","fromListWithKey"] [d| + fromListWithKey size fromListWithKey = + IS_LAZY (fromListWithKey undefined [("a",1),("a",2)] :: TrieType) + |]) +$(makeFunc mapsOnly ["size","fromListWithKey'"] [d| + fromListWithKey' size fromListWithKey' = + IS_STRICT (fromListWithKey' undefined [("a",1),("a",2)] :: TrieType) + |]) + +tests = testGroup "Strictness" + [ $(makeCases mapsOnly "insert") + , $(makeCases mapsOnly "insert'") + , $(makeCases mapsOnly "insertWith1") + , $(makeCases mapsOnly "insertWith'1") + , $(makeCases mapsOnly "insertWith'2") + , $(makeCases mapsOnly "insertWith'3") + , $(makeCases mapsOnly "insertWith2") + , $(makeCases mapsOnly "insertWith'4") + , $(makeCases mapsOnly "adjust") + , $(makeCases mapsOnly "adjust'") + , $(makeCases mapsOnly "alter") + , $(makeCases mapsOnly "alter'") + , $(makeCases mapsOnly "union") + , $(makeCases mapsOnly "union'") + , $(makeCases mapsOnly "unionWith") + , $(makeCases mapsOnly "unionWith'") + , $(makeCases mapsOnly "unionWithKey") + , $(makeCases mapsOnly "unionWithKey'") + , $(makeCases mapsOnly "unions") + , $(makeCases mapsOnly "unions'") + , $(makeCases mapsOnly "unionsWith") + , $(makeCases mapsOnly "unionsWith'") + , $(makeCases mapsOnly "unionsWithKey") + , $(makeCases mapsOnly "unionsWithKey'") + , $(makeCases mapsOnly "intersection") + , $(makeCases mapsOnly "intersection'") + , $(makeCases mapsOnly "intersectionWith") + , $(makeCases mapsOnly "intersectionWith'") + , $(makeCases mapsOnly "intersectionWithKey") + , $(makeCases mapsOnly "intersectionWithKey'") + , $(makeCases mapsOnly "map") + , $(makeCases mapsOnly "map'") + , $(makeCases mapsOnly "mapWithKey") + , $(makeCases mapsOnly "mapWithKey'") + , $(makeCases mapsOnly "mapInKeys") + , $(makeCases mapsOnly "mapInKeys'") + , $(makeCases mapsOnly "mapInKeysWith") + , $(makeCases mapsOnly "mapInKeysWith'") + , $(makeCases mapsOnly "mapAccum") + , $(makeCases mapsOnly "mapAccum'") + , $(makeCases mapsOnly "mapAccumWithKey") + , $(makeCases mapsOnly "mapAccumWithKey'") + , $(makeCases mapsOnly "mapAccumAsc") + , $(makeCases mapsOnly "mapAccumAsc'") + , $(makeCases mapsOnly "mapAccumAscWithKey") + , $(makeCases mapsOnly "mapAccumAscWithKey'") + , $(makeCases mapsOnly "mapAccumDesc") + , $(makeCases mapsOnly "mapAccumDesc'") + , $(makeCases mapsOnly "mapAccumDescWithKey") + , $(makeCases mapsOnly "mapAccumDescWithKey'") + , $(makeCases mapsOnly "fromListWith") + , $(makeCases mapsOnly "fromListWith'") + , $(makeCases mapsOnly "fromListWithKey") + , $(makeCases mapsOnly "fromListWithKey'") + ] diff --git a/tests/Tests/TH.hs b/tests/Tests/TH.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/TH.hs @@ -0,0 +1,209 @@ +-- File created: 2009-01-09 13:57:13 + +{-# LANGUAGE EmptyDataDecls, PatternGuards, TemplateHaskell #-} + +module Tests.TH + ( Module(..) + , TrieType, ListElemType + , makeFunc, makeCases, makeProps + , setsOnly, mapsOnly, allTries + ) where + +import Control.Arrow ((***)) +import Data.Char (isDigit) +import Data.Maybe (isJust, fromMaybe) +import Data.List (break, isPrefixOf, isSuffixOf) +import Language.Haskell.TH + ( Exp(..), Lit(..), Stmt(..), Dec(..), Type(..), Clause(..), Pat(..) + , Guard(..), Body(..), Match(..) + , Q, ExpQ + , Name, nameBase, nameModule, mkName + ) + +data Module = SetModule String | MapModule String + +moduleName :: Module -> String +moduleName (SetModule m) = m +moduleName (MapModule m) = m + +data TestType = Case | Property + +data ListElemType + +data TrieType_ a +type TrieType = TrieType_ Int + +keyType = ''Char +elemType = ''Int + +replaceTypes :: Module -> Type -> Type +replaceTypes m (ForallT names cxt t) = ForallT names cxt (replaceTypes m t) +replaceTypes m (AppT t1 t2) = AppT (replaceTypes m t1) (replaceTypes m t2) +replaceTypes m (ConT t) | t == ''TrieType = + case m of + SetModule m' -> ConT (mkName $ m' ++ ".TrieSet") `AppT` ConT keyType + MapModule m' -> ConT (mkName $ m' ++ ".TrieMap") `AppT` ConT keyType + `AppT` ConT elemType +replaceTypes m (ConT t) | t == ''ListElemType = + case m of + SetModule _ -> ListT `AppT` ConT keyType + MapModule _ -> TupleT 2 `AppT` (ListT `AppT` ConT keyType) + `AppT` (ConT elemType) + +replaceTypes _ x = x + +-- Given, say: +-- [SetModule "S", MapModule "M"] +-- [("x",Just (AppT (TupleT 2) (ConT Int) (ConT TrieType)))] +-- [d| f x y = x |] +-- +-- generate: [d| f_S y = S.x :: (Int,S.TrieSet Char) +-- f_M y = S2.x :: (Int,M.TrieMap Char Int) +-- |] +-- +-- WARNING: shadowing names will break this! For instance the following: +-- +-- f x y = let x = y in x +-- +-- will result in: +-- +-- f_S y = let x = y in S.x +-- +-- Which is obviously very different in terms of semantics. +-- +-- (Yes, this could be handled properly but I couldn't be bothered.) +makeFunc :: [Module] -> [String] -> Q [Dec] -> Q [Dec] +makeFunc modules expands = + let expandFuns = map expandTopDec modules + in fmap (\decs -> concat [map f decs | f <- expandFuns]) + where + isExpandable n = nameBase n `elem` expands + && fromMaybe True + (fmap ("Data.ListTrie." `isPrefixOf`) (nameModule n)) + + expandTopDec modu (FunD name clauses) = + FunD (modularName (nameBase name) (moduleName modu)) + (map (expandClause modu) clauses) + expandTopDec _ _ = + error "expandTopDec :: shouldn't ever see this declaration type" + + expandDec modu (FunD name clauses) = + FunD name (map (expandClause modu) clauses) + expandDec modu (ValD pat body decs) = + ValD pat (expandBody modu body) (map (expandDec modu) decs) + expandDec modu (SigD name typ) = SigD name (replaceTypes modu typ) + expandDec _ _ = + error "expandDec :: shouldn't ever see this declaration type" + + expandClause modu (Clause pats body decs) = + Clause (concatMap clearPat pats) + (expandBody modu body) + (map (expandDec modu) decs) + + -- Remove matching ones from the function arguments + clearPat (VarP n) | isExpandable n = [] + clearPat x = [x] + + expandBody modu (NormalB expr) = NormalB (expandE modu expr) + expandBody modu (GuardedB guards) = + GuardedB (map (expandGuard modu *** expandE modu) guards) + + expandE m (VarE n) | isExpandable n = qualify VarE m n + expandE m (ConE n) | isExpandable n = qualify ConE m n + expandE m (AppE e1 e2) = AppE (expandE m e1) (expandE m e2) + expandE m (InfixE me1 e me2) = InfixE (fmap (expandE m) me1) + (expandE m e) + (fmap (expandE m) me2) + expandE m (LamE pats e) = LamE pats (expandE m e) + expandE m (TupE es) = TupE (map (expandE m) es) + expandE m (CondE e1 e2 e3) = CondE (expandE m e1) + (expandE m e2) + (expandE m e3) + expandE m (LetE decs e) = LetE (map (expandDec m) decs) (expandE m e) + expandE m (CaseE e matches) = CaseE (expandE m e) + (map (expandMatch m) matches) + expandE m (DoE stmts) = DoE (map (expandStmt m) stmts) + expandE m (CompE stmts) = CompE (map (expandStmt m) stmts) + expandE m (SigE e t) = SigE (expandE m e) (replaceTypes m t) + expandE m (RecConE name fexps) = RecConE name (map (expandFieldExp m) fexps) + expandE m (RecUpdE name fexps) = RecUpdE name (map (expandFieldExp m) fexps) + expandE m (ListE exps) = ListE (map (expandE m) exps) + expandE _ x = x + + qualify expr modu name = + expr $ mkName (moduleName modu ++ "." ++ nameBase name) + + expandMatch modu (Match pat body decs) = + Match pat (expandBody modu body) (map (expandDec modu) decs) + + expandStmt modu (BindS pat expr) = BindS pat (expandE modu expr) + expandStmt modu (LetS decs) = LetS (map (expandDec modu) decs) + expandStmt modu (NoBindS expr) = NoBindS (expandE modu expr) + expandStmt _ (ParS _) = error "expandStmt :: ParS? What's that?" + + expandFieldExp modu (name,expr) = (name, expandE modu expr) + + expandGuard modu (NormalG expr) = NormalG (expandE modu expr) + expandGuard modu (PatG stmts) = PatG (map (expandStmt modu) stmts) + +makeTests :: TestType -> [Module] -> String -> ExpQ +makeTests typ modules test = + return$ + VarE (mkName "testGroup") `AppE` + LitE (StringL (testName typ test)) `AppE` + ListE ( + map (\m -> let mn = moduleName m + n = modularName test mn + in VarE (mkName testType) `AppE` + LitE (StringL (relevantPart mn)) `AppE` + (VarE (mkName testMaker) `AppE` + VarE n) + ) + modules) + where + testType = case typ of + Case -> "testCase" + Property -> "testProperty" + + testMaker = case typ of + Case -> "assert" + Property -> "id" + +makeCases = makeTests Case +makeProps = makeTests Property + +-- Used to name the generated functions +modularName :: String -> String -> Name +modularName name modu = + mkName $ name ++ "_" ++ map (\c -> if c == '.' then '_' else c) modu + +testName :: TestType -> String -> String +testName Case test = test +testName Property test = + let (s,num) = break isDigit.tail.dropWhile (/= '_') $ test + in concat + [ s + , if null num + then "" + else "-" + , num + ] + +relevantPart :: String -> String +relevantPart = drop (length "Data.ListTrie.") + +setsOnly = [SetModule "Data.ListTrie.Set.Eq" + ,SetModule "Data.ListTrie.Set.Ord" + ,SetModule "Data.ListTrie.Set.Enum" + ,SetModule "Data.ListTrie.Patricia.Set.Eq" + ,SetModule "Data.ListTrie.Patricia.Set.Ord" + ,SetModule "Data.ListTrie.Patricia.Set.Enum" + ] +mapsOnly = [MapModule "Data.ListTrie.Map.Eq" + ,MapModule "Data.ListTrie.Map.Ord" + ,MapModule "Data.ListTrie.Map.Enum" + ,MapModule "Data.ListTrie.Patricia.Map.Eq" + ,MapModule "Data.ListTrie.Patricia.Map.Ord" + ,MapModule "Data.ListTrie.Patricia.Map.Enum" + ] +allTries = setsOnly ++ mapsOnly