# Transitive graph

What follows is a small but useful set of functions on transitive graphs and graphs that must be conformed to transitivity. Natural language is rich in transitive relationships expressed in a synthetic way, such as "they live in the same city", "they are friends". These two examples are binary transitive relations expressed succinctly.

The two propositions: "A, C, F and H live in the same city." and "W lives in the same city as X and Y.", although having substantially the same meaning, they cannot be unified as: "A, C, F, W, X, Y and H live in the same city." Their formulation as pairs of a transitive graph allows it, using the correct algorithm. The functions of this module perform this task.

module TransitiveGraph
(checkGraphTransitivity
,addPairPreservingGraphTransitivity
,makeGraphTransitive
,unionOfTransitiveGraphsPreservingTransitivity
,fromGraphsToTransitiveGraph
,missingPairsToMakeTheGraphTransitive
) where

import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Foldable as F (all,any)

type Pair a = (a,a)

type Graph a = Set (Pair a)

checkGraphTransitivity
:: Ord a => Graph a -> Bool
checkGraphTransitivity gr =
let (dom,cod) = S.foldr (\(a,b) (dom,cod) -> (S.insert a dom, S.insert b cod)) (S.empty,S.empty) gr
nonterminals = S.intersection dom cod
terminals = cod S.\\ nonterminals
mp_gr = S.foldr (\(k,v) -> M.insertWith S.union k (S.singleton v)) M.empty gr
in go mp_gr (S.toList dom) nonterminals terminals S.empty
where
go :: Ord a => Map a (Set a) -> [a] -> Set a -> Set a -> Set a -> Bool
go _ [] _ _ _ = True
go mp_gr (d:ds) nonterminals terminals antecs =
let antecs' = S.insert d antecs
image_d = mp_gr M.! d
preimage = (S.intersection nonterminals image_d) S.\\ terminals
image2 = S.foldr (\i_d acc -> S.union acc (mp_gr M.! i_d)) S.empty preimage
image2' = image2 S.\\ antecs'
antecs'' = S.union preimage antecs'
in F.all (S.member image_d) image2' && go mp_gr ds nonterminals terminals antecs

addPairPreservingGraphTransitivity
:: Ord a => Graph a -> Pair a -> Graph a
addPairPreservingGraphTransitivity gr c@(a,b)
| F.any ((== b) . fst) gr = S.insert c . S.union gr . S.map (\x -> (a,x)) . S.map snd . S.filter ((== b) . fst) $gr | otherwise = S.insert c gr makeGraphTransitive :: Ord a => Graph a -> Graph a makeGraphTransitive gr = S.foldr (flip addPairPreservingGraphTransitivity) S.empty gr -- Graphs transitivity of arguments is NOT checked unionOfTransitiveGraphsPreservingTransitivity :: Ord a => Graph a -> Graph a -> Graph a unionOfTransitiveGraphsPreservingTransitivity gr1 gr2 = S.union (f gr1 gr2) (f gr2 gr1) where f g1 g2 = S.foldr (\c acc -> addPairPreservingGraphTransitivity acc c) g1 (g2 S.\\ g1) fromGraphsToTransitiveGraph :: Ord a => Graph a -> Graph a -> Graph a fromGraphsToTransitiveGraph gr1 gr2 = unionOfTransitiveGraphsPreservingTransitivity (makeGraphTransitive gr1) (makeGraphTransitive gr2) missingPairsToMakeTheGraphTransitive :: Ord a => Graph a -> Graph a missingPairsToMakeTheGraphTransitive gr = makeGraphTransitive gr S.\\ gr  EXAMPLES gr1 = S.fromList [(1,3),(3,5),(5,2),(2,7),(1,5),(1,2),(5,7)] gr2 = S.fromList [(1,7),(3,2),(3,7),(2,5)] checkGraphTransitivity gr1 == False makeGraphTransitive gr1 == S.fromList [(1,2),(1,3),(1,5),(1,7),(2,7),(3,2),(3,5),(3,7),(5,2),(5,7)] missingPairsToMakeTheGraphTransitive gr1 == S.fromList [(1,7),(3,2),(3,7)] unionOfTransitiveGraphsPreservingTransitivity gr1 gr2 == S.fromList [(1,2),(1,3),(1,5),(1,7),(2,2),(2,5),(2,7),(3,2),(3,5),(3,7),(5,2),(5,5),(5,7)] ------------------------------ livesInTheSameCity1 = S.fromList [('a','f'),('c','d'),('d','b')] livesInTheSameCity2 = S.fromList [('e','f'),('c','g'),('d','b'),('g','a')] makeGraphTransitive livesInTheSameCity1 fromList [('a','f'),('c','b'),('c','d'),('d','b')] makeGraphTransitive livesInTheSameCity2 fromList [('c','a'),('c','g'),('d','b'),('e','f'),('g','a')] fromGraphsToTransitiveGraph livesInTheSameCity1 livesInTheSameCity2 fromList [('a','f'),('c','a'),('c','b'),('c','d'),('c','f'),('c','g'),('d','b'),('e','f'),('g','a'),('g','f')]  The error detected by Franky is fixed: addPairPreservingGraphTransitivity :: Ord a => Graph a -> Pair a -> Graph a addPairPreservingGraphTransitivity gr p | S.member p gr = gr | otherwise = makeGraphTransitive$ S.insert p gr
-- ex. addPairPreservingGraphTransitivity (S.fromList [('a','b'), ('c','d')]) ('b','c')
-- > fromList [('a','b'),('a','c'),('a','d'),('b','c'),('b','d'),('c','d')]

type Domain a = Set a

makeGraphTransitive :: Ord a => Graph a -> Graph a
makeGraphTransitive gr = go (domain gr) gr
where
go :: Ord a => Domain a -> Graph a -> Graph a
go dom  gr
| changed = go dom gr'
| otherwise = gr
where
(gr',changed) = go2 dom gr
go2 :: Ord a => Domain a -> Graph a -> (Graph a, Bool)
go2 dom gr = S.foldr (\d res@(acc, changed) ->
case go3 acc d of
Nothing   -> res
Just acc' -> (acc',True)
) (gr,False) dom
go3 :: Ord a => Graph a -> a -> Maybe (Graph a)
go3 gr d
| S.isSubsetOf images2 image_d = Nothing
| otherwise = Just $S.union gr$ S.map (\i -> (d,i)) images2
where
images2 = S.map snd preimages
preimages = S.filter ((S.member image_d) . fst) gr
image_d = elementImage gr d
-- ex. makeGraphTransitive $S.fromList [('a','b'),('b','c'),('z','w'),('w','y'),('c','d'),('d','e'),('e','f')] -- > fromList [('a','b'),('a','c'),('a','d'),('a','e'),('a','f'),('b','c'),('b','d'),('b','e'),('b','f'),('c','d'),('c','e'),('c','f'),('d','e'),('d','f'),('e','f'),('w','y'),('z','w'),('z','y')] -- ex. makeGraphTransitive$ S.fromList [('b','a'),('c','b'),('z','w'),('w','y'),('d','c'),('e','d'),('f','e')]
-- > fromList [('b','a'),('c','a'),('c','b'),('d','a'),('d','b'),('d','c'),('e','a'),('e','b'),('e','c'),('e','d'),('f','a'),('f','b'),('f','c'),('f','d'),('f','e'),('w','y'),('z','w'),('z','y')]

domain :: Ord b1 => Set (b1, b2) -> Set b1
domain gr = S.map fst gr

elementImage :: (Ord a1, Eq a2) => Set (a2, a1) -> a2 -> Set a1
elementImage gr d = S.foldr (\(x,y) acc -> if x == d then S.insert y acc else acc) S.empty gr


## 1 Answer

There is some asymmetry in your code:

addPairPreservingGraphTransitivity gr c@(a,b)
| F.any ((== b) . fst) gr = S.insert c . S.union gr . S.map (\x -> (a,x)) . S.map snd . S.filter ((== b) . fst) $gr  If there is F.any ((== b) . fst) gr, where is the opposite direction F.any ((== a) . snd) gr? And indeed, makeGraphTransitive does not work as I expect: *TransitiveGraph> makeGraphTransitive (S.fromList [('c','b'), ('b','a')]) fromList [('b','a'),('c','b')]  The easy example with a and c renamed works fine in makeGraphTransitive (S.fromList [('a','b'), ('b','c')]). I tried to fix it with addPairPreservingGraphTransitivity gr c@(a,b) | F.any ((== b) . fst) gr || F.any ((== a) . snd) gr = S.insert c . S.union gr . S.union (S.map (\x -> (x,b)) . S.map fst . S.filter ((== a) . snd)$ gr). S.map (\x -> (a,x)) . S.map snd . S.filter ((== b) . fst) \$ gr


but this still fails with this example, ('a','d') is missing:

*TransitiveGraph> addPairPreservingGraphTransitivity (S.fromList [('a','b'), ('c','d')]) ('b','c')
fromList [('a','b'),('a','c'),('b','c'),('b','d'),('c','d')]