module Data.MultiTrie(
MultiTrie,
empty,
singleton,
leaf,
repeat,
updateValues,
addValue,
values,
children,
null,
size,
areEqualStrict,
areEqualWeak,
areEquivalentUpTo,
subnode,
subnodeUpdate,
subnodeAddValue,
subnodeReplace,
subnodeDelete,
subnodeUnite,
subnodeIntersect,
filter,
project,
filterOnNames,
filterWithNames,
map,
mapWithName,
mapMany,
mapManyWithName,
mapOnLists,
mapOnListsWithName,
cartesian,
union,
unions,
intersection,
intersections1,
flatten,
apply,
bind,
toMap,
toList,
fromList,
fromMaybe,
toMaybe,
draw,
listAsMultiSetEquals,
areMapsEquivalentUpTo
) where
import Prelude hiding (null, repeat, map, filter)
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Tree as T
import qualified Data.List as L
import Data.Composition((.:))
type MultiTrieMap v d = M.Map v (MultiTrie v d)
data MultiTrie v d = MultiTrie
{
values :: [d],
children :: MultiTrieMap v d
}
deriving (Show)
instance Ord v => Functor (MultiTrie v) where
fmap = map
instance Ord v => Applicative (MultiTrie v) where
pure = singleton
(<*>) = apply
instance Ord v => Monad (MultiTrie v) where
return = singleton
(>>=) = bind
instance (Ord v, Eq d) => Eq (MultiTrie v d) where
(==) = areEqualStrict
empty :: MultiTrie v d
empty = MultiTrie [] M.empty
singleton :: d -> MultiTrie v d
singleton d = leaf [d]
leaf ::
[d] ->
MultiTrie v d
leaf ds = MultiTrie ds M.empty
repeat :: Ord v =>
[v] ->
[d] ->
MultiTrie v d
repeat vs ds =
if L.null ds
then empty
else MultiTrie ds (M.fromList $ zip vs $ L.repeat $ repeat vs ds)
updateValues ::
([d] -> [d]) ->
MultiTrie v d ->
MultiTrie v d
updateValues f (MultiTrie ds m) = MultiTrie (f ds) m
addValue ::
d ->
MultiTrie v d ->
MultiTrie v d
addValue d = updateValues (d:)
null ::
MultiTrie v d ->
Bool
null (MultiTrie ds m) = L.null ds && L.all null (M.elems m)
size ::
MultiTrie v d ->
Int
size (MultiTrie ds m) = L.length ds + L.sum (L.map size (M.elems m))
areEqualStrict :: (Ord v, Eq d) =>
MultiTrie v d ->
MultiTrie v d ->
Bool
areEqualStrict = areEquivalentUpTo (==)
areEqualWeak :: (Ord v, Eq d) =>
MultiTrie v d ->
MultiTrie v d ->
Bool
areEqualWeak = areEquivalentUpTo listAsMultiSetEquals
areEquivalentUpTo :: (Ord v, Eq d) =>
([d] -> [d] -> Bool) ->
MultiTrie v d ->
MultiTrie v d ->
Bool
areEquivalentUpTo p (MultiTrie ds1 m1) (MultiTrie ds2 m2) =
(p ds1 ds2) &&
(areMapsEquivalentUpTo (areEquivalentUpTo p) m1 m2)
subnode :: Ord v =>
[v] ->
MultiTrie v d ->
MultiTrie v d
subnode [] t = t
subnode (v:vs) (MultiTrie _ m) = maybe empty (subnode vs) (M.lookup v m)
subnodeUpdate :: Ord v =>
[v] ->
(MultiTrie v d -> MultiTrie v d) ->
MultiTrie v d ->
MultiTrie v d
subnodeUpdate [] f t = f t
subnodeUpdate (v:vs) f (MultiTrie ds m) =
MultiTrie ds (M.alter (toMaybe . subnodeUpdate vs f . fromMaybe) v m)
subnodeAddValue :: Ord v =>
[v] ->
d ->
MultiTrie v d ->
MultiTrie v d
subnodeAddValue vs = subnodeUpdate vs . addValue
subnodeReplace :: Ord v =>
[v] ->
MultiTrie v d ->
MultiTrie v d ->
MultiTrie v d
subnodeReplace vs = subnodeUpdate vs . const
subnodeDelete :: Ord v =>
[v] ->
MultiTrie v d ->
MultiTrie v d
subnodeDelete vs = subnodeReplace vs empty
subnodeUnite :: Ord v =>
[v] ->
MultiTrie v d ->
MultiTrie v d ->
MultiTrie v d
subnodeUnite vs = subnodeUpdate vs . union
subnodeIntersect :: (Ord v, Eq d) =>
[v] ->
MultiTrie v d ->
MultiTrie v d ->
MultiTrie v d
subnodeIntersect vs = subnodeUpdate vs . intersection
filter :: Ord v => (d -> Bool) -> MultiTrie v d -> MultiTrie v d
filter p = mapOnLists (L.filter p)
project :: Ord v => [[v]] -> MultiTrie v d -> MultiTrie v d
project vss = filterOnNames ((flip L.elem) vss)
filterOnNames :: Ord v => ([v] -> Bool) -> MultiTrie v d -> MultiTrie v d
filterOnNames p = filterWithNames (flip (const p))
filterWithNames :: Ord v => ([v] -> d -> Bool) -> MultiTrie v d -> MultiTrie v d
filterWithNames p = mapOnListsWithName (\vs ds -> L.filter (p vs) ds)
map :: Ord v =>
(d1 -> d2) ->
MultiTrie v d1 ->
MultiTrie v d2
map f = mapOnLists (L.map f)
mapWithName :: Ord v =>
([v] -> d1 -> d2) ->
MultiTrie v d1 ->
MultiTrie v d2
mapWithName f = mapOnListsWithName (L.map . f)
mapMany :: Ord v =>
[d1 -> d2] ->
MultiTrie v d1 ->
MultiTrie v d2
mapMany fs = mapOnLists (fs <*>)
mapManyWithName :: Ord v =>
[[v] -> d1 -> d2] ->
MultiTrie v d1 ->
MultiTrie v d2
mapManyWithName fs = mapOnListsWithName (\vs -> (L.map ($vs) fs <*>))
mapOnLists :: Ord v =>
([d1] -> [d2]) ->
MultiTrie v d1 ->
MultiTrie v d2
mapOnLists f (MultiTrie ds m) =
MultiTrie (f ds) (M.mapMaybe (toMaybe . mapOnLists f) m)
mapOnListsWithName :: Ord v =>
([v] -> [d1] -> [d2]) ->
MultiTrie v d1 ->
MultiTrie v d2
mapOnListsWithName f (MultiTrie ds m) =
MultiTrie
(f [] ds)
(M.mapMaybeWithKey transformChild m)
where
transformChild v = toMaybe . (mapOnListsWithName $ f . (v:))
cartesian :: Ord v =>
MultiTrie v d1 ->
MultiTrie v d2 ->
MultiTrie v (d1, d2)
cartesian t = apply (map (,) t)
union :: Ord v =>
MultiTrie v d ->
MultiTrie v d ->
MultiTrie v d
union = zipContentsAndChildren (++) (M.unionWith union)
unions :: Ord v =>
[MultiTrie v d] ->
MultiTrie v d
unions = L.foldl union empty
intersection :: (Ord v, Eq d) =>
MultiTrie v d ->
MultiTrie v d ->
MultiTrie v d
intersection = nullToEmpty .:
zipContentsAndChildren
listAsMultiSetIntersection
((M.filter (not . null)) .: (M.intersectionWith intersection))
intersections1 :: (Ord v, Eq d) =>
[MultiTrie v d] ->
MultiTrie v d
intersections1 = L.foldl1 intersection
flatten :: Ord v =>
MultiTrie v (MultiTrie v d) ->
MultiTrie v d
flatten (MultiTrie ts m) =
F.foldr union empty ts `union` MultiTrie [] (M.map flatten m)
apply :: Ord v =>
MultiTrie v (d1 -> d2) ->
MultiTrie v d1 ->
MultiTrie v d2
apply t1 t2 = flatten $ map ((flip map) t2) t1
bind :: Ord v =>
MultiTrie v d1 ->
(d1 -> MultiTrie v d2) ->
MultiTrie v d2
bind = flatten .: (flip map)
toMap :: Ord v =>
MultiTrie v d ->
M.Map [v] [d]
toMap (MultiTrie ds m) = if L.null ds
then childrenMap
else M.insert [] ds childrenMap
where
childrenMap =
M.unions $
M.elems $
M.mapWithKey (\v -> M.mapKeys (v:)) $
M.map toMap m
toList :: Ord v =>
MultiTrie v d ->
[([v], d)]
toList (MultiTrie ds m) = (L.map ((,) []) ds) ++
(
L.concat $
L.map (\(v, ps) -> L.map (\(vs, ds') -> (v:vs, ds')) ps) $
M.toList $
M.map toList m
)
fromList :: Ord v =>
[([v], d)] ->
MultiTrie v d
fromList = L.foldr (uncurry subnodeAddValue) empty
fromMaybe :: Maybe (MultiTrie v d) -> MultiTrie v d
fromMaybe = maybe empty id
toMaybe ::
MultiTrie v d ->
Maybe (MultiTrie v d)
toMaybe t = if null t then Nothing else Just t
draw :: (Show v, Show [d]) =>
MultiTrie v d ->
String
draw = T.drawTree . toTree show show
areMapsEquivalentUpTo :: Ord k =>
(a -> b -> Bool) ->
M.Map k a ->
M.Map k b ->
Bool
areMapsEquivalentUpTo p m1 m2 = mapEquivalenceHelper
(M.minViewWithKey m1)
(M.minViewWithKey m2)
where
mapEquivalenceHelper Nothing Nothing = True
mapEquivalenceHelper _ Nothing = False
mapEquivalenceHelper Nothing _ = False
mapEquivalenceHelper (Just ((k1, v1), m1')) (Just ((k2, v2), m2')) =
k1 == k2 &&
p v1 v2 &&
areMapsEquivalentUpTo p m1' m2'
nullToEmpty ::
MultiTrie v d ->
MultiTrie v d
nullToEmpty t = if null t then empty else t
zipContentsAndChildren :: Ord v =>
([d] -> [d] -> [d]) ->
(MultiTrieMap v d -> MultiTrieMap v d -> MultiTrieMap v d) ->
MultiTrie v d ->
MultiTrie v d ->
MultiTrie v d
zipContentsAndChildren f g (MultiTrie ds1 m1) (MultiTrie ds2 m2) =
MultiTrie (f ds1 ds2) (g m1 m2)
toTree ::
(v -> t) ->
([d] -> t) ->
MultiTrie v d ->
T.Tree t
toTree f g (MultiTrie ds m) =
T.Node (g ds) $ M.elems $ M.mapWithKey namedChildToTree m
where
namedChildToTree k t = T.Node (f k) [toTree f g t]
listAsMultiSetIntersection :: Eq a =>
[a] ->
[a] ->
[a]
listAsMultiSetIntersection [] _ = []
listAsMultiSetIntersection _ [] = []
listAsMultiSetIntersection (x:xs) ys = if x `L.elem` ys
then x : listAsMultiSetIntersection xs (L.delete x ys)
else listAsMultiSetIntersection xs ys
listAsMultiSetEquals :: Eq a =>
[a] ->
[a] ->
Bool
listAsMultiSetEquals [] [] = True
listAsMultiSetEquals [] _ = False
listAsMultiSetEquals _ [] = False
listAsMultiSetEquals (x:xs) ys = if x `L.elem` ys
then listAsMultiSetEquals xs (L.delete x ys)
else False