3
\$\begingroup\$

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
\$\endgroup\$
3
\$\begingroup\$

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')]
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.