heptagon/utilities/graph.ml

(**************************************************************************)
(*                                                                        *)
(*  Heptagon                                                              *)
(*                                                                        *)
(*  Author : Marc Pouzet                                                  *)
(*  Organization : Demons, LRI, University of Paris-Sud, Orsay            *)
(*                                                                        *)
(**************************************************************************)
(* graph manipulation *)
(* $Id$ *)
type 'a graph =
  { g_top: 'a node list;
    g_bot: 'a node list }

and 'a node =
    { g_containt: 'a;
      g_tag: int;
      mutable g_visited: bool;
      mutable g_mark: int;
      mutable g_depends_on: 'a node list;
      mutable g_depends_by: 'a node list;
    }

exception Cycle of int (* returns the index of the node *)

let tag = ref 0
let new_tag () = incr tag; !tag
let containt g = g.g_containt
let linked g1 g2 =
  (List.memq g2 g1.g_depends_on) or (List.memq g1 g2.g_depends_on)
let make c =
  { g_containt = c; g_tag = new_tag (); g_visited = false;
    g_mark = -1; g_depends_on = []; g_depends_by = [] }
let add_depends node1 node2 =
  if not (node1.g_tag = node2.g_tag or linked node1 node2) then (
    node1.g_depends_on <- node2 :: node1.g_depends_on;
    node2.g_depends_by <- node1 :: node2.g_depends_by
  )

let remove_depends node1 node2 =
  if not (node1.g_tag = node2.g_tag) then (
    node1.g_depends_on <- List.filter (fun n -> n.g_tag <> node2.g_tag) node1.g_depends_on;
    node2.g_depends_by <- List.filter (fun n -> n.g_tag <> node1.g_tag) node2.g_depends_by
  )

let graph top_list bot_list = { g_top = top_list; g_bot = bot_list }


let topological g_list =
  let rec sortrec g_list seq =
    match g_list with
    | [] -> seq
    | g :: g_list ->
        if g.g_visited then sortrec g_list seq
        else
          begin
            g.g_visited <- true;
            let seq = sortrec g.g_depends_on seq in
            sortrec g_list (g :: seq)
          end in
  let seq = sortrec g_list [] in
  List.iter
    (fun ({ g_visited = _ } as node) -> node.g_visited <- false) g_list;
  List.rev seq

(** Detection of cycles *)
(* Mark nodes with:
   - -1 initially, for unvisited nodes
   - 0 for "opened" nodes, currently visited, while visiting its descendents
   - 1 for "closed" nodes, visited once, no circuits found from it.
   A circuit is found when a node marked with 0 is visited again.
*)

let cycle g_list =
  (* store nodes in a stack *)
  let s = Stack.create () in
  (* flush the connected component *)
  let rec flush index =
    if Stack.is_empty s then []
    else let v = Stack.pop s in
    v.g_containt :: flush v.g_tag in

  let rec visit g =
    match g.g_mark with
      | -1 ->
          (* Unvisited yet *)
          (* Open node *)
          Stack.push g s;
          g.g_mark <- 0;
          (* Visit descendents *)
          List.iter visit g.g_depends_on;
          (* Close node *)
          ignore (Stack.pop s);
          g.g_mark <- 1
      | 0 ->
          (* Visit an opened node (visited and not close) : circuit *)
          raise (Cycle g.g_tag)
      | 1 | _ ->
          (* Visit a closed node (no existing circuit) : pass *)
          () in
  try
    List.iter visit g_list; None
  with
    | Cycle(index) -> Some(flush index)

(** [accessible useful_nodes g_list] returns the list of
  accessible nodes starting from useful_nodes and belonging to
  g_list. *)
let accessible useful_nodes g_list =
  let rec follow g =
    if not g.g_visited then
      begin
        g.g_visited <- true;
        List.iter follow g.g_depends_on
      end in
  let read acc g =
    if g.g_visited then begin g.g_visited <- false; g :: acc end else acc in
  List.iter follow useful_nodes;
  List.fold_left read [] g_list

(** [exists_path nodes n1 n2] returns whether there is a path
  from n1 to n2 in the graph. nodes is the list of all the nodes
  in the graph. *)
let exists_path nodes n1 n2 =
  List.mem n2 (accessible [n1] nodes)

open Format

let print_node print g =
  printf "Node : @[<hov>";
  print_int g.g_tag;
  printf "@]";
  printf "  Depends on :@\n";
  printf "  @[<v>";
  List.iter
    (fun node ->
       printf "@[<hov 2>";
       print_int node.g_tag;
       printf "@]@ ")
    g.g_depends_on;
  printf "@]"