add SCC code
Mark Shinwell
parent
f55d23deac
commit
e0a2c13162
|
|
@ -0,0 +1,195 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Pierre Chambart, OCamlPro *)
|
||||
(* Mark Shinwell, Jane Street Europe *)
|
||||
(* *)
|
||||
(* Copyright 2015 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. All rights reserved. This file is distributed *)
|
||||
(* under the terms of the Q Public License version 1.0. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
module Int = Numbers.Int
|
||||
|
||||
module Kosaraju : sig
|
||||
type component_graph =
|
||||
{ sorted_connected_components : int list array;
|
||||
component_edges : int list array;
|
||||
}
|
||||
|
||||
val component_graph : int list array -> component_graph
|
||||
end = struct
|
||||
let transpose graph =
|
||||
let size = Array.length graph in
|
||||
let transposed = Array.make size [] in
|
||||
let add src dst = transposed.(src) <- dst :: transposed.(src) in
|
||||
Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts)
|
||||
graph;
|
||||
transposed
|
||||
|
||||
let depth_first_order (graph : int list array) : int array =
|
||||
let size = Array.length graph in
|
||||
let marked = Array.make size false in
|
||||
let stack = Array.make size ~-1 in
|
||||
let pos = ref 0 in
|
||||
let push i =
|
||||
stack.(!pos) <- i;
|
||||
incr pos
|
||||
in
|
||||
let rec aux node =
|
||||
if not marked.(node)
|
||||
then begin
|
||||
marked.(node) <- true;
|
||||
List.iter aux graph.(node);
|
||||
push node
|
||||
end
|
||||
in
|
||||
for i = 0 to size - 1 do
|
||||
aux i
|
||||
done;
|
||||
stack
|
||||
|
||||
let mark order graph =
|
||||
let size = Array.length graph in
|
||||
let graph = transpose graph in
|
||||
let marked = Array.make size false in
|
||||
let id = Array.make size ~-1 in
|
||||
let count = ref 0 in
|
||||
let rec aux node =
|
||||
if not marked.(node)
|
||||
then begin
|
||||
marked.(node) <- true;
|
||||
id.(node) <- !count;
|
||||
List.iter aux graph.(node)
|
||||
end
|
||||
in
|
||||
for i = size - 1 downto 0 do
|
||||
let node = order.(i) in
|
||||
if not marked.(node)
|
||||
then begin
|
||||
aux order.(i);
|
||||
incr count
|
||||
end
|
||||
done;
|
||||
id, !count
|
||||
|
||||
let kosaraju graph =
|
||||
let dfo = depth_first_order graph in
|
||||
let components, ncomponents = mark dfo graph in
|
||||
ncomponents, components
|
||||
|
||||
type component_graph =
|
||||
{ sorted_connected_components : int list array;
|
||||
component_edges : int list array;
|
||||
}
|
||||
|
||||
let component_graph graph =
|
||||
let ncomponents, components = kosaraju graph in
|
||||
let id_scc = Array.make ncomponents [] in
|
||||
let component_graph = Array.make ncomponents Int.Set.empty in
|
||||
let add_component_dep node set =
|
||||
let node_deps = graph.(node) in
|
||||
List.fold_left (fun set dep -> Int.Set.add components.(dep) set)
|
||||
set node_deps
|
||||
in
|
||||
Array.iteri (fun node component ->
|
||||
id_scc.(component) <- node :: id_scc.(component);
|
||||
component_graph.(component) <-
|
||||
add_component_dep node (component_graph.(component)))
|
||||
components;
|
||||
{ sorted_connected_components = id_scc;
|
||||
component_edges = Array.map Int.Set.elements component_graph;
|
||||
}
|
||||
end
|
||||
|
||||
module type S = sig
|
||||
module Id : Identifiable.S
|
||||
|
||||
type directed_graph = Id.Set.t Id.Map.t
|
||||
|
||||
type component =
|
||||
| Has_loop of Id.t list
|
||||
| No_loop of Id.t
|
||||
|
||||
val connected_components_sorted_from_roots_to_leaf
|
||||
: directed_graph
|
||||
-> component array
|
||||
|
||||
val component_graph : directed_graph -> (component * int list) array
|
||||
end
|
||||
|
||||
module Make (Id : Identifiable.S) = struct
|
||||
type directed_graph = Id.Set.t Id.Map.t
|
||||
|
||||
type component =
|
||||
| Has_loop of Id.t list
|
||||
| No_loop of Id.t
|
||||
|
||||
(* ensure that the dependency graph does not have external dependencies *)
|
||||
let check dependencies =
|
||||
Id.Map.iter (fun id set ->
|
||||
Id.Set.iter (fun v ->
|
||||
if not (Id.Map.mem v dependencies)
|
||||
then
|
||||
Misc.fatal_errorf "Sort_connected_components.check: the graph \
|
||||
has external dependencies (%a -> %a)"
|
||||
Id.print id Id.print v)
|
||||
set)
|
||||
dependencies
|
||||
|
||||
type numbering =
|
||||
{ back : int Id.Map.t;
|
||||
forth : Id.t array;
|
||||
}
|
||||
|
||||
let number graph =
|
||||
let size = Id.Map.cardinal graph in
|
||||
let bindings = Id.Map.bindings graph in
|
||||
let a = Array.of_list bindings in
|
||||
let forth = Array.map fst a in
|
||||
let back =
|
||||
let back = ref Id.Map.empty in
|
||||
for i = 0 to size - 1 do
|
||||
back := Id.Map.add forth.(i) i !back;
|
||||
done;
|
||||
!back
|
||||
in
|
||||
let integer_graph =
|
||||
Array.init size (fun i ->
|
||||
let _, dests = a.(i) in
|
||||
Id.Set.fold (fun dest acc ->
|
||||
let v =
|
||||
try Id.Map.find dest back
|
||||
with Not_found ->
|
||||
Misc.fatal_errorf
|
||||
"Sort_connected_components: missing dependency %a"
|
||||
Id.print dest
|
||||
in
|
||||
v :: acc)
|
||||
dests [])
|
||||
in
|
||||
{ back; forth }, integer_graph
|
||||
|
||||
let component_graph graph =
|
||||
let numbering, integer_graph = number graph in
|
||||
let { Kosaraju.sorted_connected_components;
|
||||
component_edges } = Kosaraju.component_graph integer_graph
|
||||
in
|
||||
Array.mapi (fun component nodes ->
|
||||
match nodes with
|
||||
| [] -> assert false
|
||||
| [node] ->
|
||||
(if List.mem node integer_graph.(node)
|
||||
then Has_loop [numbering.forth.(node)]
|
||||
else No_loop numbering.forth.(node)),
|
||||
component_edges.(component)
|
||||
| _::_ ->
|
||||
(Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)),
|
||||
component_edges.(component))
|
||||
sorted_connected_components
|
||||
|
||||
let connected_components_sorted_from_roots_to_leaf graph =
|
||||
Array.map fst (component_graph graph)
|
||||
end
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Pierre Chambart, OCamlPro *)
|
||||
(* Mark Shinwell, Jane Street Europe *)
|
||||
(* *)
|
||||
(* Copyright 2015 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. All rights reserved. This file is distributed *)
|
||||
(* under the terms of the Q Public License version 1.0. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(** The sorting of connected components of a directed graph. *)
|
||||
|
||||
module type S = sig
|
||||
module Id : Identifiable.S
|
||||
|
||||
type directed_graph = Id.Set.t Id.Map.t
|
||||
(** If (a -> set) belongs to the map, it means that there are edges
|
||||
from [a] to every element of [set]. It is assumed that no edge
|
||||
points to a vertex not represented in the map. *)
|
||||
|
||||
type component =
|
||||
| Has_loop of Id.t list
|
||||
| No_loop of Id.t
|
||||
|
||||
val connected_components_sorted_from_roots_to_leaf
|
||||
: directed_graph
|
||||
-> component array
|
||||
|
||||
val component_graph : directed_graph -> (component * int list) array
|
||||
end
|
||||
|
||||
module Make (Id : Identifiable.S) : S with module Id := Id
|
||||
Loading…
Reference in New Issue