exception Cycle
type mark = NotVisited | InProgress | Visited
 
type 'a graph =
    { mutable g_nodes : 'a node list }
and 'a node = {
  n_label : 'a;
  mutable n_mark : mark;
  mutable n_link_to : 'a node list;
  mutable n_linked_by : 'a node list;
}
 
let mk_graph () = { g_nodes = [] }
 
let add_node g x =
  let n = { n_label = x; n_mark = NotVisited; n_link_to = []; n_linked_by = [] } in
  g.g_nodes <- n::g.g_nodes
 
let node_for_label g x =
  List.find (fun n -> n.n_label = x) g.g_nodes
 
let add_edge g id1 id2 =
  let n1 = node_for_label g id1 in
  let n2 = node_for_label g id2 in
  n1.n_link_to <- n2::n1.n_link_to;
  n2.n_linked_by <- n1::n2.n_linked_by
 
let clear_marks g =
  List.iter (fun n -> n.n_mark <- NotVisited) g.g_nodes
 
let find_roots g =
  List.filter (fun n -> n.n_linked_by = []) g.g_nodes
 
let rec has_cycle g =
    let rec aux = function
        | n::_ when n.n_mark = InProgress -> true
        | n::g -> n.n_mark <- InProgress;
                  let depn = aux n.n_link_to in
                  n.n_mark <- Visited;
                  depn || aux g
        | [] -> false
     in
     aux g.g_nodes
 
let topological g =
    let rec aux acc n = match n.n_mark with
        |  InProgress -> raise Cycle
        |  NotVisited -> n.n_mark <- InProgress;
                         let ln = n.n_label::(List.fold_left aux acc n.n_link_to) in
                         n.n_mark <- Visited;
                         ln
        | Visited   -> acc 
    in
    List.fold_left aux [] (find_roots g)