module Data.Bimap (
Bimap(),
null,
size,
member,
memberR,
notMember,
notMemberR,
pairMember,
pairNotMember,
lookup,
lookupR,
(!),
(!>),
empty,
singleton,
insert,
delete,
deleteR,
fromList,
toList,
toAscList,
toAscListR,
keys,
keysR,
elems,
assocs,
fold,
valid,
twist,
twisted,
) where
import Control.Arrow ((>>>))
import Control.Monad.Error ()
import Data.List (foldl', sort)
import qualified Data.Map as M
import Prelude hiding (lookup, null)
infixr 9 .:
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) = (.).(.)
data Bimap a b = MkBimap !(M.Map a b) !(M.Map b a)
instance (Show a, Show b) => Show (Bimap a b) where
show x = "fromList " ++ (show . toList $ x)
instance (Eq a, Eq b) => Eq (Bimap a b) where
(==) bx by = toAscList bx == toAscList by
empty :: Bimap a b
empty = MkBimap M.empty M.empty
singleton :: a -> b -> Bimap a b
singleton x y = MkBimap (M.singleton x y) (M.singleton y x)
null :: Bimap a b -> Bool
null (MkBimap left _) = M.null left
size :: Bimap a b -> Int
size (MkBimap left _) = M.size left
member :: (Ord a, Ord b) => a -> Bimap a b -> Bool
member x (MkBimap left _) = M.member x left
memberR :: (Ord a, Ord b) => b -> Bimap a b -> Bool
memberR y (MkBimap _ right) = M.member y right
notMember :: (Ord a, Ord b) => a -> Bimap a b -> Bool
notMember = not .: member
notMemberR :: (Ord a, Ord b) => b -> Bimap a b -> Bool
notMemberR = not .: memberR
pairMember :: (Ord a, Ord b)
=> (a, b) -> Bimap a b -> Bool
pairMember (x, y) (MkBimap left _) =
maybe False (== y) (M.lookup x left)
pairNotMember :: (Ord a, Ord b)
=> (a, b) -> Bimap a b -> Bool
pairNotMember = not .: pairMember
insert :: (Ord a, Ord b)
=> a -> b -> Bimap a b -> Bimap a b
insert x y = delete x
>>> deleteR y
>>> unsafeInsert x y
unsafeInsert :: (Ord a, Ord b)
=> a -> b -> Bimap a b -> Bimap a b
unsafeInsert x y (MkBimap left right) =
MkBimap (M.insert x y left) (M.insert y x right)
deleteE :: (Ord a, Ord b)
=> Either a b -> Bimap a b -> Bimap a b
deleteE e (MkBimap left right) =
MkBimap
(perhaps M.delete x $ left)
(perhaps M.delete y $ right)
where
perhaps = maybe id
x = either Just (flip M.lookup right) e
y = either (flip M.lookup left) Just e
delete :: (Ord a, Ord b) => a -> Bimap a b -> Bimap a b
delete = deleteE . Left
deleteR :: (Ord a, Ord b) => b -> Bimap a b -> Bimap a b
deleteR = deleteE . Right
lookup :: (Ord a, Ord b, Monad m)
=> a -> Bimap a b -> m b
lookup x (MkBimap left _) =
maybe (fail "Data.Bimap.lookup: Left key not found")
(return)
(M.lookup x left)
lookupR :: (Ord a, Ord b, Monad m)
=> b -> Bimap a b -> m a
lookupR y (MkBimap _ right) =
maybe (fail "Data.Bimap.lookupR: Right key not found")
(return)
(M.lookup y right)
(!) :: (Ord a, Ord b) => Bimap a b -> a -> b
(!) bi x = either error id (lookup x bi)
(!>) :: (Ord a, Ord b) => Bimap a b -> b -> a
(!>) bi y = either error id (lookupR y bi)
fromList :: (Ord a, Ord b)
=> [(a, b)] -> Bimap a b
fromList xs = foldl' (flip . uncurry $ insert) empty xs
toList :: Bimap a b -> [(a, b)]
toList = toAscList
toAscList :: Bimap a b -> [(a, b)]
toAscList (MkBimap left _) = M.toList left
toAscListR :: Bimap a b -> [(b, a)]
toAscListR = toAscList . twist
assocs :: Bimap a b -> [(a, b)]
assocs = toList
keys :: Bimap a b -> [a]
keys (MkBimap left _) = M.keys left
keysR :: Bimap a b -> [b]
keysR (MkBimap _ right) = M.keys right
elems :: Bimap a b -> [b]
elems = keysR
valid :: (Ord a, Ord b)
=> Bimap a b -> Bool
valid (MkBimap left right) = and
[ M.valid left, M.valid right
, (==)
(sort . M.toList $ left )
(sort . map flipPair . M.toList $ right)
]
where
flipPair (x, y) = (y, x)
twist :: Bimap a b -> Bimap b a
twist (MkBimap left right) = MkBimap right left
twisted :: (Bimap a b -> Bimap a b) -> (Bimap b a -> Bimap b a)
twisted f = twist . f . twist
fold :: (a -> b -> c -> c) -> c -> Bimap a b -> c
fold f z = foldr (uncurry f) z . assocs