module type NODE = sig
type t
val compare : t -> t -> int
val to_string : t -> string
end
module Make (N : NODE) (NMap : WrappedMap.S with type key = N.t) (NSet : Set.S with type elt = N.t) =
struct
type node = {
value: N.t;
edges: NSet.t;
mutable index: int;
mutable lowlink: int;
mutable on_stack: bool;
}
type topsort_state = {
graph: node NMap.t;
mutable visit_count: int;
mutable stack: node list;
mutable components: N.t Nel.t list;
}
let initial_state graph =
let graph =
NMap.mapi
(fun value edges -> { value; edges; index = -1; lowlink = -1; on_stack = false })
graph
in
{ graph; visit_count = 0; stack = []; components = [] }
let rec strongconnect state v =
let i = state.visit_count in
state.visit_count <- i + 1;
assert (v.index = -1);
v.index <- i;
v.lowlink <- i;
state.stack <- v :: state.stack;
v.on_stack <- true;
v.edges
|> NSet.iter (fun e ->
let w = NMap.find e state.graph in
if w.index = -1 then (
strongconnect state w;
v.lowlink <- min v.lowlink w.lowlink
) else if w.on_stack then
v.lowlink <- min v.lowlink w.index);
if v.lowlink = v.index then
let c = component state v in
state.components <- (v.value, c) :: state.components
and component state v =
let w = List.hd state.stack in
state.stack <- List.tl state.stack;
w.on_stack <- false;
if v.value = w.value then
[]
else
w.value :: component state v
let tarjan ~roots state =
NSet.iter
(fun x ->
let v = NMap.find x state.graph in
if v.index = -1 then strongconnect state v)
roots
let topsort ~roots graph =
let state = initial_state graph in
tarjan ~roots state;
state.components
let log =
List.iter (fun mc ->
if Nel.length mc > 1 then
let nodes = mc |> Nel.to_list |> Base.List.map ~f:N.to_string |> String.concat "\n\t" in
Printf.ksprintf prerr_endline "cycle detected among the following nodes:\n\t%s" nodes)
end