namespace Graph.TransitiveReduction open System open System.Collections open System.Collections.Generic /// Adjacency list representation of a graph, mapping each vertex to its successors type Graph<'a when 'a : comparison> = Map<'a, 'a Set> #nowarn "40" module Graph = /// Reachable nodes from the given root let reachableF (g: Graph<'a>) k (root:'a) = match g.TryFind root with | None -> Set.empty | Some nn -> Seq.map k nn |> Set.unionMany let rec fix f x = f (fix f) x let reachable g root = fix (reachableF g) root /// Builds a table of the reachable nodes from every node in the graph let reachableAll g : Map<'a,Set<'a>> = let rec m = g |> Map.map (fun n _ -> lazy(Set.add n (reachableF g k n))) and k n = m.[n].Value m |> Map.map(fun _ e -> e.Value) /// The transitive reduction of a graph is the minimal set of edges with the same transitive closure let transitiveReductionHelper (dfss : Map<_,_>) (g:Graph<'a>) : Graph<'a> = let reachable n = Set.add n (dfss.[n]) g |> Map.map(fun n ss -> ss |> Set.filter(fun s -> not <| Seq.exists (fun s' -> s' <> s && reachable(s').Contains s) ss) |> Set.ofSeq) let transitiveReduction g = transitiveReductionHelper (reachableAll g) g module Example = let g1 : Graph = Map.ofSeq <| [ 0, Set.ofSeq [|1;2;3|] 1, Set.ofSeq [|2|] 2, Set.ofSeq [|3|] 3, Set.ofSeq [| |] ] let g1' = Graph.transitiveReduction g1