1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
|
(**************************************************************************)
(* *)
(* Menhir *)
(* *)
(* Franois Pottier and Yann Rgis-Gianas, INRIA Rocquencourt *)
(* *)
(* Copyright 2005 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, with the *)
(* change described in file LICENSE. *)
(* *)
(**************************************************************************)
(* This module provides an implementation of Tarjan's algorithm for
finding the strongly connected components of a graph.
The algorithm runs when the functor is applied. Its complexity is
$O(V+E)$, where $V$ is the number of vertices in the graph $G$, and
$E$ is the number of edges. *)
module Run (G : sig
type node
(* We assume each node has a unique index. Indices must range from
$0$ to $n-1$, where $n$ is the number of nodes in the graph. *)
val n: int
val index: node -> int
(* Iterating over a node's immediate successors. *)
val successors: (node -> unit) -> node -> unit
(* Iterating over all nodes. *)
val iter: (node -> unit) -> unit
end) = struct
(* Define the internal data structure associated with each node. *)
type data = {
(* Each node carries a flag which tells whether it appears
within the SCC stack (which is defined below). *)
mutable stacked: bool;
(* Each node carries a number. Numbers represent the order in
which nodes were discovered. *)
mutable number: int;
(* Each node [x] records the lowest number associated to a node
already detected within [x]'s SCC. *)
mutable low: int;
(* Each node carries a pointer to a representative element of
its SCC. This field is used by the algorithm to store its
results. *)
mutable representative: G.node;
(* Each representative node carries a list of the nodes in
its SCC. This field is used by the algorithm to store its
results. *)
mutable scc: G.node list
}
(* Define a mapping from external nodes to internal ones. Here, we
simply use each node's index as an entry into a global array. *)
let table =
(* Create the array. We initially fill it with [None], of type
[data option], because we have no meaningful initial value of
type [data] at hand. *)
let table = Array.create G.n None in
(* Initialize the array. *)
G.iter (fun x ->
table.(G.index x) <- Some {
stacked = false;
number = 0;
low = 0;
representative = x;
scc = []
}
);
(* Define a function which gives easy access to the array. It maps
each node to its associated piece of internal data. *)
function x ->
match table.(G.index x) with
| Some dx ->
dx
| None ->
assert false (* Indices do not cover the range $0\ldots n$, as expected. *)
(* Create an empty stack, used to record all nodes which belong to
the current SCC. *)
let scc_stack = Stack.create()
(* Initialize a function which allocates numbers for (internal)
nodes. A new number is assigned to each node the first time it is
visited. Numbers returned by this function start at 1 and
increase. Initially, all nodes have number 0, so they are
considered unvisited. *)
let mark =
let counter = ref 0 in
fun dx ->
incr counter;
dx.number <- !counter;
dx.low <- !counter
(* Look at all nodes of the graph, one after the other. Any
unvisited nodes become roots of the search forest. *)
let () = G.iter (fun root ->
let droot = table root in
if droot.number = 0 then begin
(* This node hasn't been visited yet. Start a depth-first walk
from it. *)
mark droot;
droot.stacked <- true;
Stack.push droot scc_stack;
let rec walk x =
let dx = table x in
G.successors (fun y ->
let dy = table y in
if dy.number = 0 then begin
(* $y$ hasn't been visited yet, so $(x,y)$ is a regular
edge, part of the search forest. *)
mark dy;
dy.stacked <- true;
Stack.push dy scc_stack;
(* Continue walking, depth-first. *)
walk y;
if dy.low < dx.low then
dx.low <- dy.low
end
else if (dy.low < dx.low) & dy.stacked then begin
(* The first condition above indicates that $y$ has been
visited before $x$, so $(x, y)$ is a backwards or
transverse edge. The second condition indicates that
$y$ is inside the same SCC as $x$; indeed, if it
belongs to another SCC, then the latter has already
been identified and moved out of [scc_stack]. *)
if dy.number < dx.low then
dx.low <- dy.number
end
) x;
(* We are done visiting $x$'s neighbors. *)
if dx.low = dx.number then begin
(* $x$ is the entry point of a SCC. The whole SCC is now
available; move it out of the stack. We pop elements out
of the SCC stack until $x$ itself is found. *)
let rec loop () =
let element = Stack.pop scc_stack in
element.stacked <- false;
dx.scc <- element.representative :: dx.scc;
element.representative <- x;
if element != dx then
loop() in
loop()
end in
walk root
end
)
(* There only remains to make our results accessible to the
outside. *)
let representative x =
(table x).representative
let scc x =
(table x).scc
end
|