----------------------------------------------------------------------
-- |
-- Module      : Relation
-- Maintainer  : BB
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/26 17:13:13 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.1 $
--
-- A simple module for relations.
-----------------------------------------------------------------------------

module GF.Data.Relation (Rel, mkRel, mkRel'
                           , allRelated , isRelatedTo
                           , transitiveClosure
                           , reflexiveClosure, reflexiveClosure_
                           , symmetricClosure
                           , symmetricSubrelation, reflexiveSubrelation
                           , reflexiveElements
                           , equivalenceClasses
                           , isTransitive, isReflexive, isSymmetric
                           , isEquivalence
                           , isSubRelationOf
                           , topologicalSort, findCycles) where

import Data.Foldable (toList)
--import Data.List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set

import GF.Data.Utilities

type Rel a = Map a (Set a)

-- | Creates a relation from a list of related pairs.
mkRel :: Ord a => [(a,a)] -> Rel a
mkRel :: [(a, a)] -> Rel a
mkRel [(a, a)]
ps = [(a, a)] -> Rel a -> Rel a
forall a. Ord a => [(a, a)] -> Rel a -> Rel a
relates [(a, a)]
ps Rel a
forall k a. Map k a
Map.empty

-- | Creates a relation from a list pairs of elements and the elements
--   related to them.
mkRel' :: Ord a => [(a,[a])] -> Rel a
mkRel' :: [(a, [a])] -> Rel a
mkRel' [(a, [a])]
xs = (Set a -> Set a -> Set a) -> [(a, Set a)] -> Rel a
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union [(a
x,[a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
ys) | (a
x,[a]
ys) <- [(a, [a])]
xs]

relToList :: Ord a => Rel a -> [(a,a)]
relToList :: Rel a -> [(a, a)]
relToList Rel a
r = [ (a
x,a
y) | (a
x,Set a
ys) <- Rel a -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toList Rel a
r, a
y <- Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ys ]

-- | Add a pair to the relation.
relate :: Ord a => a -> a -> Rel a -> Rel a
relate :: a -> a -> Rel a -> Rel a
relate a
x a
y Rel a
r = (Set a -> Set a -> Set a) -> a -> Set a -> Rel a -> Rel a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union a
x (a -> Set a
forall a. a -> Set a
Set.singleton a
y) Rel a
r

-- | Add a list of pairs to the relation.
relates :: Ord a => [(a,a)] -> Rel a -> Rel a
relates :: [(a, a)] -> Rel a -> Rel a
relates [(a, a)]
ps Rel a
r = (Rel a -> (a, a) -> Rel a) -> Rel a -> [(a, a)] -> Rel a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Rel a
r' (a
x,a
y) -> a -> a -> Rel a -> Rel a
forall a. Ord a => a -> a -> Rel a -> Rel a
relate a
x a
y Rel a
r') Rel a
r [(a, a)]
ps

-- | Checks if an element is related to another.
isRelatedTo :: Ord a => Rel a -> a  -> a -> Bool
isRelatedTo :: Rel a -> a -> a -> Bool
isRelatedTo Rel a
r a
x a
y = Bool -> (Set a -> Bool) -> Maybe (Set a) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (a
y a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member`) (a -> Rel a -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Rel a
r)

-- | Get the set of elements to which a given element is related.
allRelated :: Ord a => Rel a -> a -> Set a
allRelated :: Rel a -> a -> Set a
allRelated Rel a
r a
x = Set a -> Maybe (Set a) -> Set a
forall a. a -> Maybe a -> a
fromMaybe Set a
forall a. Set a
Set.empty (a -> Rel a -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Rel a
r)

-- | Get all elements in the relation.
domain :: Ord a => Rel a -> Set a
domain :: Rel a -> Set a
domain Rel a
r = (Set a -> Set a -> Set a) -> Set a -> [Set a] -> Set a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Rel a -> Set a
forall k a. Map k a -> Set k
Map.keysSet Rel a
r) (Rel a -> [Set a]
forall k a. Map k a -> [a]
Map.elems Rel a
r)

reverseRel :: Ord a => Rel a -> Rel a
reverseRel :: Rel a -> Rel a
reverseRel Rel a
r = [(a, a)] -> Rel a
forall a. Ord a => [(a, a)] -> Rel a
mkRel [(a
y,a
x) | (a
x,a
y) <- Rel a -> [(a, a)]
forall a. Ord a => Rel a -> [(a, a)]
relToList Rel a
r]

-- | Keep only pairs for which both elements are in the given set.
intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
intersectSetRel :: Set a -> Rel a -> Rel a
intersectSetRel Set a
s = (a -> a -> Bool) -> Rel a -> Rel a
forall a. Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel (\a
x a
y -> a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s Bool -> Bool -> Bool
&& a
y a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s)

transitiveClosure :: Ord a => Rel a -> Rel a
transitiveClosure :: Rel a -> Rel a
transitiveClosure Rel a
r = (Rel a -> Rel a) -> Rel a -> Rel a
forall a. Eq a => (a -> a) -> a -> a
fix ((Set a -> Set a) -> Rel a -> Rel a
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Set a -> Set a
growSet) Rel a
r
  where growSet :: Set a -> Set a
growSet Set a
ys = (Set a -> Set a -> Set a) -> Set a -> [Set a] -> Set a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set a
ys ((a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map (Rel a -> a -> Set a
forall a. Ord a => Rel a -> a -> Set a
allRelated Rel a
r) ([a] -> [Set a]) -> [a] -> [Set a]
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ys)

reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
                  -> Rel a -> Rel a
reflexiveClosure_ :: [a] -> Rel a -> Rel a
reflexiveClosure_ [a]
u Rel a
r = [(a, a)] -> Rel a -> Rel a
forall a. Ord a => [(a, a)] -> Rel a -> Rel a
relates [(a
x,a
x) | a
x <- [a]
u] Rel a
r

-- | Uses 'domain'
reflexiveClosure :: Ord a => Rel a -> Rel a
reflexiveClosure :: Rel a -> Rel a
reflexiveClosure Rel a
r = [a] -> Rel a -> Rel a
forall a. Ord a => [a] -> Rel a -> Rel a
reflexiveClosure_ (Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ Rel a -> Set a
forall a. Ord a => Rel a -> Set a
domain Rel a
r) Rel a
r

symmetricClosure :: Ord a => Rel a -> Rel a
symmetricClosure :: Rel a -> Rel a
symmetricClosure Rel a
r = [(a, a)] -> Rel a -> Rel a
forall a. Ord a => [(a, a)] -> Rel a -> Rel a
relates [ (a
y,a
x) | (a
x,a
y) <- Rel a -> [(a, a)]
forall a. Ord a => Rel a -> [(a, a)]
relToList Rel a
r ] Rel a
r

symmetricSubrelation :: Ord a => Rel a -> Rel a
symmetricSubrelation :: Rel a -> Rel a
symmetricSubrelation Rel a
r = (a -> a -> Bool) -> Rel a -> Rel a
forall a. Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel ((a -> a -> Bool) -> a -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((a -> a -> Bool) -> a -> a -> Bool)
-> (a -> a -> Bool) -> a -> a -> Bool
forall a b. (a -> b) -> a -> b
$ Rel a -> a -> a -> Bool
forall a. Ord a => Rel a -> a -> a -> Bool
isRelatedTo Rel a
r) Rel a
r

reflexiveSubrelation :: Ord a => Rel a -> Rel a
reflexiveSubrelation :: Rel a -> Rel a
reflexiveSubrelation Rel a
r = Set a -> Rel a -> Rel a
forall a. Ord a => Set a -> Rel a -> Rel a
intersectSetRel (Rel a -> Set a
forall a. Ord a => Rel a -> Set a
reflexiveElements Rel a
r) Rel a
r

-- | Get the set of elements which are related to themselves.
reflexiveElements :: Ord a => Rel a -> Set a
reflexiveElements :: Rel a -> Set a
reflexiveElements Rel a
r = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [ a
x | (a
x,Set a
ys) <- Rel a -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toList Rel a
r, a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
ys ]

-- | Keep the related pairs for which the predicate is true.
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
filterRel :: (a -> a -> Bool) -> Rel a -> Rel a
filterRel a -> a -> Bool
p = (Rel a, Set a) -> Rel a
forall a b. (a, b) -> a
fst ((Rel a, Set a) -> Rel a)
-> (Rel a -> (Rel a, Set a)) -> Rel a -> Rel a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel a -> (Rel a, Set a)
forall a. Ord a => Rel a -> (Rel a, Set a)
purgeEmpty (Rel a -> (Rel a, Set a))
-> (Rel a -> Rel a) -> Rel a -> (Rel a, Set a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Set a -> Set a) -> Rel a -> Rel a
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ((a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((a -> Bool) -> Set a -> Set a)
-> (a -> a -> Bool) -> a -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Bool
p)

-- | Remove keys that map to no elements.
purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
purgeEmpty :: Rel a -> (Rel a, Set a)
purgeEmpty Rel a
r = let (Rel a
r',Rel a
r'') = (Set a -> Bool) -> Rel a -> (Rel a, Rel a)
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (Bool -> Bool
not (Bool -> Bool) -> (Set a -> Bool) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
forall a. Set a -> Bool
Set.null) Rel a
r
                in (Rel a
r', Rel a -> Set a
forall k a. Map k a -> Set k
Map.keysSet Rel a
r'')

-- | Get the equivalence classes from an equivalence relation.
equivalenceClasses :: Ord a => Rel a -> [Set a]
equivalenceClasses :: Rel a -> [Set a]
equivalenceClasses Rel a
r = [a] -> Rel a -> [Set a]
forall a. Ord a => [a] -> Map a (Set a) -> [Set a]
equivalenceClasses_ (Rel a -> [a]
forall k a. Map k a -> [k]
Map.keys Rel a
r) Rel a
r
 where equivalenceClasses_ :: [a] -> Map a (Set a) -> [Set a]
equivalenceClasses_ [] Map a (Set a)
_ = []
       equivalenceClasses_ (a
x:[a]
xs) Map a (Set a)
r = Set a
ysSet a -> [Set a] -> [Set a]
forall a. a -> [a] -> [a]
:[a] -> Map a (Set a) -> [Set a]
equivalenceClasses_ [a]
zs Map a (Set a)
r
          where ys :: Set a
ys = Map a (Set a) -> a -> Set a
forall a. Ord a => Rel a -> a -> Set a
allRelated Map a (Set a)
r a
x
                zs :: [a]
zs = [a
x' | a
x' <- [a]
xs, Bool -> Bool
not (a
x' a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
ys)]

isTransitive :: Ord a => Rel a -> Bool
isTransitive :: Rel a -> Bool
isTransitive Rel a
r = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [a
z a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
ys | (a
x,Set a
ys) <- Rel a -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toList Rel a
r,
                      a
y <- Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
ys, a
z <- Set a -> [a]
forall a. Set a -> [a]
Set.toList (Rel a -> a -> Set a
forall a. Ord a => Rel a -> a -> Set a
allRelated Rel a
r a
y)]

isReflexive :: Ord a => Rel a -> Bool
isReflexive :: Rel a -> Bool
isReflexive Rel a
r = ((a, Set a) -> Bool) -> [(a, Set a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ (a
x,Set a
ys) -> a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
ys) (Rel a -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toList Rel a
r)

isSymmetric :: Ord a => Rel a -> Bool
isSymmetric :: Rel a -> Bool
isSymmetric Rel a
r = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Rel a -> a -> a -> Bool
forall a. Ord a => Rel a -> a -> a -> Bool
isRelatedTo Rel a
r a
y a
x | (a
x,a
y) <- Rel a -> [(a, a)]
forall a. Ord a => Rel a -> [(a, a)]
relToList Rel a
r]

isEquivalence :: Ord a => Rel a -> Bool
isEquivalence :: Rel a -> Bool
isEquivalence Rel a
r = Rel a -> Bool
forall a. Ord a => Rel a -> Bool
isReflexive Rel a
r Bool -> Bool -> Bool
&& Rel a -> Bool
forall a. Ord a => Rel a -> Bool
isSymmetric Rel a
r Bool -> Bool -> Bool
&& Rel a -> Bool
forall a. Ord a => Rel a -> Bool
isTransitive Rel a
r

isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
isSubRelationOf :: Rel a -> Rel a -> Bool
isSubRelationOf Rel a
r1 Rel a
r2 = ((a, a) -> Bool) -> [(a, a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((a -> a -> Bool) -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Rel a -> a -> a -> Bool
forall a. Ord a => Rel a -> a -> a -> Bool
isRelatedTo Rel a
r2)) (Rel a -> [(a, a)]
forall a. Ord a => Rel a -> [(a, a)]
relToList Rel a
r1)

-- | Returns 'Left' if there are cycles, and 'Right' if there are cycles.
topologicalSort :: Ord a => Rel a -> Either [a] [[a]]
topologicalSort :: Rel a -> Either [a] [[a]]
topologicalSort Rel a
r = Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
forall a. Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
tsort Rel' a
r' Seq a
noIncoming Seq a
forall a. Seq a
Seq.empty
  where r' :: Rel' a
r' = Rel a -> Rel' a
forall a. Ord a => Rel a -> Rel' a
relToRel' Rel a
r
        noIncoming :: Seq a
noIncoming = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList [a
x | (a
x,(Set a
is,Set a
_)) <- Rel' a -> [(a, (Set a, Set a))]
forall k a. Map k a -> [(k, a)]
Map.toList Rel' a
r', Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
is]

tsort :: Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
tsort :: Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
tsort Rel' a
r Seq a
xs Seq a
l = case Seq a -> ViewL a
forall a. Seq a -> ViewL a
Seq.viewl Seq a
xs of
                 ViewL a
Seq.EmptyL | Rel' a -> Bool
forall a. Ord a => Rel' a -> Bool
isEmpty' Rel' a
r -> [a] -> Either [a] [[a]]
forall a b. a -> Either a b
Left (Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq a
l)
                            | Bool
otherwise  -> [[a]] -> Either [a] [[a]]
forall a b. b -> Either a b
Right (Rel a -> [[a]]
forall a. Ord a => Rel a -> [[a]]
findCycles (Rel' a -> Rel a
forall a. Ord a => Rel' a -> Rel a
rel'ToRel Rel' a
r))
                 a
x Seq.:< Seq a
xs -> Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
forall a. Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
tsort Rel' a
r' (Seq a
xs Seq a -> Seq a -> Seq a
forall a. Seq a -> Seq a -> Seq a
Seq.>< [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList [a]
new) (Seq a
l Seq a -> a -> Seq a
forall a. Seq a -> a -> Seq a
Seq.|> a
x)
                     where (Rel' a
r',Set a
_,Set a
os) = a -> Rel' a -> (Rel' a, Set a, Set a)
forall a. Ord a => a -> Rel' a -> (Rel' a, Set a, Set a)
remove a
x Rel' a
r
                           new :: [a]
new = [a
o | a
o <- Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
os, Set a -> Bool
forall a. Set a -> Bool
Set.null (a -> Rel' a -> Set a
forall a. Ord a => a -> Rel' a -> Set a
incoming a
o Rel' a
r')]

findCycles :: Ord a => Rel a -> [[a]]
findCycles :: Rel a -> [[a]]
findCycles = (Set a -> [a]) -> [Set a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Set a -> [a]
forall a. Set a -> [a]
Set.toList ([Set a] -> [[a]]) -> (Rel a -> [Set a]) -> Rel a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel a -> [Set a]
forall a. Ord a => Rel a -> [Set a]
equivalenceClasses (Rel a -> [Set a]) -> (Rel a -> Rel a) -> Rel a -> [Set a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel a -> Rel a
forall a. Ord a => Rel a -> Rel a
reflexiveSubrelation (Rel a -> Rel a) -> (Rel a -> Rel a) -> Rel a -> Rel a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel a -> Rel a
forall a. Ord a => Rel a -> Rel a
symmetricSubrelation (Rel a -> Rel a) -> (Rel a -> Rel a) -> Rel a -> Rel a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel a -> Rel a
forall a. Ord a => Rel a -> Rel a
transitiveClosure

--
-- * Alternative representation that keeps both incoming and outgoing edges
--

-- | Keeps both incoming and outgoing edges.
type Rel' a = Map a (Set a, Set a)

isEmpty' :: Ord a => Rel' a -> Bool
isEmpty' :: Rel' a -> Bool
isEmpty' = Rel' a -> Bool
forall k a. Map k a -> Bool
Map.null

relToRel' :: Ord a => Rel a -> Rel' a
relToRel' :: Rel a -> Rel' a
relToRel' Rel a
r = ((Set a, Set a) -> (Set a, Set a) -> (Set a, Set a))
-> Rel' a -> Rel' a -> Rel' a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\ (Set a
i,Set a
_) (Set a
_,Set a
o) -> (Set a
i,Set a
o)) Rel' a
forall a. Map a (Set a, Set a)
ir Rel' a
forall a. Map a (Set a, Set a)
or
  where ir :: Map a (Set a, Set a)
ir = (Set a -> (Set a, Set a)) -> Rel a -> Map a (Set a, Set a)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Set a
s -> (Set a
s,Set a
forall a. Set a
Set.empty)) (Rel a -> Map a (Set a, Set a)) -> Rel a -> Map a (Set a, Set a)
forall a b. (a -> b) -> a -> b
$ Rel a -> Rel a
forall a. Ord a => Rel a -> Rel a
reverseRel Rel a
r
        or :: Map a (Set a, Set a)
or = (Set a -> (Set a, Set a)) -> Rel a -> Map a (Set a, Set a)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Set a
s -> (Set a
forall a. Set a
Set.empty,Set a
s)) (Rel a -> Map a (Set a, Set a)) -> Rel a -> Map a (Set a, Set a)
forall a b. (a -> b) -> a -> b
$ Rel a
r

rel'ToRel :: Ord a => Rel' a -> Rel a
rel'ToRel :: Rel' a -> Rel a
rel'ToRel = ((Set a, Set a) -> Set a) -> Rel' a -> Rel a
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Set a, Set a) -> Set a
forall a b. (a, b) -> b
snd

-- | Removes an element from a relation.
-- Returns the new relation, and the set of incoming and outgoing edges
-- of the removed element.
remove :: Ord a => a -> Rel' a -> (Rel' a, Set a, Set a)
remove :: a -> Rel' a -> (Rel' a, Set a, Set a)
remove a
x Rel' a
r = let (Maybe (Set a, Set a)
mss,Rel' a
r') = (a -> (Set a, Set a) -> Maybe (Set a, Set a))
-> a -> Rel' a -> (Maybe (Set a, Set a), Rel' a)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\a
_ (Set a, Set a)
_ -> Maybe (Set a, Set a)
forall a. Maybe a
Nothing) a
x Rel' a
r
              in case Maybe (Set a, Set a)
mss of
                   -- element was not in the relation
                   Maybe (Set a, Set a)
Nothing      -> (Rel' a
r', Set a
forall a. Set a
Set.empty, Set a
forall a. Set a
Set.empty)
                   -- remove element from all incoming and outgoing sets
                   -- of other elements
                   Just (Set a
is,Set a
os) ->
                       let r'' :: Rel' a
r''  = (a -> Rel' a -> Rel' a) -> Rel' a -> [a] -> Rel' a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
i -> ((Set a, Set a) -> (Set a, Set a)) -> a -> Rel' a -> Rel' a
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\ (Set a
is',Set a
os') -> (Set a
is', a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
x Set a
os')) a
i) Rel' a
r'  ([a] -> Rel' a) -> [a] -> Rel' a
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
is
                           r''' :: Rel' a
r''' = (a -> Rel' a -> Rel' a) -> Rel' a -> [a] -> Rel' a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
o -> ((Set a, Set a) -> (Set a, Set a)) -> a -> Rel' a -> Rel' a
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\ (Set a
is',Set a
os') -> (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
x Set a
is', Set a
os')) a
o) Rel' a
r'' ([a] -> Rel' a) -> [a] -> Rel' a
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
os
                        in (Rel' a
r''', Set a
is, Set a
os)

incoming :: Ord a => a -> Rel' a -> Set a
incoming :: a -> Rel' a -> Set a
incoming a
x Rel' a
r = Set a -> ((Set a, Set a) -> Set a) -> Maybe (Set a, Set a) -> Set a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set a
forall a. Set a
Set.empty (Set a, Set a) -> Set a
forall a b. (a, b) -> a
fst (Maybe (Set a, Set a) -> Set a) -> Maybe (Set a, Set a) -> Set a
forall a b. (a -> b) -> a -> b
$ a -> Rel' a -> Maybe (Set a, Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Rel' a
r

--outgoing :: Ord a => a -> Rel' a -> Set a
--outgoing x r = maybe Set.empty snd $ Map.lookup x r