updated Graph to remove the functor; it is now

imperative, backed by PHashtbl, and offers a simplified Dot-printing interface.
This commit is contained in:
Simon Cruanes 2013-03-04 17:35:22 +01:00
parent 25a7d33985
commit d19abf889c
2 changed files with 399 additions and 511 deletions

710
graph.ml
View file

@ -23,450 +23,344 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*) *)
(** {1 A simple persistent directed graph.} *) (** {1 A simple mutable directed graph.} *)
module type S = sig type ('v, 'e) t = ('v, ('v, 'e) node) PHashtbl.t
(** {2 Basics} *) (** Graph parametrized by a type for vertices, and one for edges *)
and ('v, 'e) node = {
n_vertex : 'v;
mutable n_next : ('e * 'v) list;
mutable n_prev : ('e * 'v) list;
} (** A node of the graph *)
type vertex (** Create an empty graph. The int argument specifies the initial size *)
let empty ?hash ?eq size =
PHashtbl.create ?hash ?eq size
module M : Map.S with type key = vertex let mk_v_set ?(size=10) graph =
module S : Set.S with type elt = vertex let open PHashtbl in
empty ~hash:graph.hash ~eq:graph.eq size
type 'e t let mk_v_table ?(size=10) graph =
(** Graph parametrized by a type for edges *) let open PHashtbl in
create ~hash:graph.hash ~eq:graph.eq size
val empty : 'e t let is_empty graph =
(** Create an empty graph. *) PHashtbl.length graph = 0
val is_empty : 'e t -> bool let length graph =
(** Is the graph empty? *) PHashtbl.length graph
val length : 'e t -> int (** Create an empty node for this vertex *)
(** Number of vertices *) let empty_node v = {
n_vertex = v;
n_next = [];
n_prev = [];
}
val add : 'e t -> vertex -> 'e -> vertex -> 'e t (** Copy of the graph *)
(** Add an edge between two vertices *) let copy graph =
PHashtbl.map
(fun v node ->
let node' = empty_node v in
node'.n_prev <- node.n_prev;
node'.n_next <- node.n_next;
node')
graph
val add_seq : 'e t -> (vertex * 'e * vertex) Sequence.t -> 'e t let get_node t v =
(** Add the vertices to the graph *) try PHashtbl.find t v
with Not_found ->
let n = empty_node v in
PHashtbl.replace t v n;
n
val next : 'e t -> vertex -> ('e * vertex) Sequence.t let add t v1 e v2 =
(** Outgoing edges *) let n1 = get_node t v1
and n2 = get_node t v2 in
n1.n_next <- (e,v2) :: n1.n_next;
n2.n_prev <- (e,v1) :: n2.n_prev;
()
val prev : 'e t -> vertex -> ('e * vertex) Sequence.t let add_seq t seq =
(** Incoming edges *) Sequence.iter (fun (v1,e,v2) -> add t v1 e v2) seq
val between : 'e t -> vertex -> vertex -> 'e Sequence.t let next t v =
Sequence.of_list (PHashtbl.find t v).n_next
val iter_vertices : 'e t -> (vertex -> unit) -> unit let prev t v =
val vertices : 'e t -> vertex Sequence.t Sequence.of_list (PHashtbl.find t v).n_prev
(** Iterate on vertices *)
val iter : 'e t -> (vertex * 'e * vertex -> unit) -> unit let between t v1 v2 =
val to_seq : 'e t -> (vertex * 'e * vertex) Sequence.t let edges = Sequence.of_list (PHashtbl.find t v1).n_prev in
(** Dump the graph as a sequence of vertices *) let edges = Sequence.filter (fun (e, v2') -> (PHashtbl.get_eq t) v2 v2') edges in
Sequence.map fst edges
(** {2 Global operations} *) (** Call [k] on every vertex *)
let iter_vertices t k =
PHashtbl.iter (fun v _ -> k v) t
val roots : 'e t -> vertex Sequence.t let vertices t =
(** Roots, ie vertices with no incoming edges *) Sequence.from_iter (iter_vertices t)
val leaves : 'e t -> vertex Sequence.t (** Call [k] on every edge *)
(** Leaves, ie vertices with no outgoing edges *) let iter t k =
PHashtbl.iter
(fun v1 node -> List.iter (fun (e, v2) -> k (v1, e, v2)) node.n_next)
t
val choose : 'e t -> vertex let to_seq t =
(** Pick a vertex, or raise Not_found *) Sequence.from_iter (iter t)
val rev_edge : (vertex * 'e * vertex) -> (vertex * 'e * vertex) (** {2 Global operations} *)
val rev : 'e t -> 'e t
(** Reverse all edges *)
(** {2 Traversals} *) (** Roots, ie vertices with no incoming edges *)
let roots g =
let vertices = vertices g in
Sequence.filter (fun v -> Sequence.is_empty (prev g v)) vertices
val bfs : 'e t -> vertex -> (vertex -> unit) -> unit (** Leaves, ie vertices with no outgoing edges *)
val bfs_seq : 'e t -> vertex -> vertex Sequence.t let leaves g =
(** Breadth-first search, from given vertex *) let vertices = vertices g in
Sequence.filter (fun v -> Sequence.is_empty (next g v)) vertices
val dfs_full : 'e t -> (** Pick a vertex, or raise Not_found *)
?labels:int M.t ref -> let choose g =
?enter:((vertex * int) list -> unit) -> match Sequence.to_list (Sequence.take 1 (vertices g)) with
?exit:((vertex * int) list -> unit) -> | [x] -> x
?tree_edge:((vertex * 'e * vertex) -> unit) -> | [] -> raise Not_found
?fwd_edge:((vertex * 'e * vertex) -> unit) -> | _ -> assert false
?back_edge:((vertex * 'e * vertex) -> unit) ->
vertex ->
unit
(** DFS, with callbacks called on each encountered node and edge *)
val dfs : 'e t -> vertex -> ((vertex * int) -> unit) -> unit let rev_edge (v,e,v') = (v',e,v)
(** Depth-first search, from given vertex. Each vertex is labelled
with its index in the traversal order. *)
val is_dag : 'e t -> bool (** Reverse all edges in the graph, in place *)
(** Is the graph acyclic? *) let rev g =
PHashtbl.iter
(fun _ node -> (* reverse the incoming and outgoing edges *)
let next = node.n_next in
node.n_next <- node.n_prev;
node.n_prev <- next)
g
(** {2 Path operations} *) (** {2 Traversals} *)
type 'e path = (vertex * 'e * vertex) list (** Breadth-first search *)
let bfs graph first k =
let q = Queue.create ()
and explored = mk_v_set graph in
Hashset.add explored first;
Queue.push first q;
while not (Queue.is_empty q) do
let v = Queue.pop q in
(* yield current node *)
k v;
(* explore children *)
Sequence.iter
(fun (e, v') -> if not (Hashset.mem explored v')
then (Hashset.add explored v'; Queue.push v' q))
(next graph v)
done
val rev_path : 'e path -> 'e path let bfs_seq graph first =
(** Reverse the path *) Sequence.from_iter (fun k -> bfs graph first k)
val min_path_full : 'e t -> (** DFS, with callbacks called on each encountered node and edge *)
?cost:(vertex -> 'e -> vertex -> int) -> let dfs_full graph ?(labels=mk_v_table graph)
?ignore:(vertex -> bool) -> ?(enter=fun _ -> ()) ?(exit=fun _ -> ())
goal:(vertex -> 'e path -> bool) -> ?(tree_edge=fun _ -> ()) ?(fwd_edge=fun _ -> ()) ?(back_edge=fun _ -> ())
vertex -> first
vertex * int * 'e path =
(** Find the minimal path, from the given [vertex], that does not contain (* next free number for traversal *)
any vertex satisfying [ignore], and that reaches a vertex let count = ref (-1) in
that satisfies [goal]. It raises Not_found if no reachable node PHashtbl.iter (fun _ i -> count := max i !count) labels;
satisfies [goal]. *) (* explore the vertex. trail is the reverse path from v to first *)
let rec explore trail v =
val min_path : 'e t -> cost:('e -> int) -> vertex -> vertex -> 'e path if PHashtbl.mem labels v then () else begin
(** Minimal path from first vertex to second, given the cost function, (* first time we explore this node! give it an index, put it in trail *)
or raises Not_found *) let n = (incr count; !count) in
PHashtbl.replace labels v n;
val diameter : 'e t -> vertex -> int let trail' = (v, n) :: trail in
(** Maximal distance between the given vertex, and any other vertex (* enter the node *)
in the graph that is reachable from it. *) enter trail';
(* explore edges *)
(** {2 Print to DOT} *)
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
type 'e dot_printer
(** Helper to print a graph to DOT *)
val mk_dot_printer :
print_edge:(vertex -> 'e -> vertex -> attribute list) ->
print_vertex:(vertex -> attribute list) ->
'e dot_printer
(** Create a Dot graph printer. Functions to convert edges and vertices
to Dot attributes must be provided. *)
val pp : 'e dot_printer -> ?vertices:S.t -> name:string ->
Format.formatter ->
(vertex * 'e * vertex) Sequence.t -> unit
(** Pretty print the graph in DOT, on given formatter. Using a sequence
allows to easily select which edges are important,
or to combine several graphs with [Sequence.append].
An optional set of additional vertices to print can be given. *)
end
module Make(V : Map.OrderedType) = struct
module M = Map.Make(V)
module S = Set.Make(V)
type vertex = V.t
type 'e t = 'e node M.t
(** Graph parametrized by a type for edges *)
and 'e node = {
n_vertex : vertex;
n_next : ('e * vertex) list;
n_prev : ('e * vertex) list;
} (** A node of the graph *)
let empty = M.empty
let is_empty graph = M.is_empty graph
let length graph = M.cardinal graph
let empty_node v = {
n_vertex = v;
n_next = [];
n_prev = [];
}
let add t v1 e v2 =
let n1 = try M.find v1 t with Not_found -> empty_node v1
and n2 = try M.find v2 t with Not_found -> empty_node v2 in
let n1 = { n1 with n_next = (e,v2) :: n1.n_next; }
and n2 = { n2 with n_prev = (e,v1) :: n2.n_prev; } in
M.add v1 n1 (M.add v2 n2 t)
let add_seq t seq = Sequence.fold (fun t (v1,e,v2) -> add t v1 e v2) t seq
let next t v = Sequence.of_list (M.find v t).n_next
let prev t v = Sequence.of_list (M.find v t).n_prev
let between t v1 v2 =
let edges = Sequence.of_list (M.find v1 t).n_prev in
let edges = Sequence.filter (fun (e, v2') -> V.compare v2 v2' = 0) edges in
Sequence.map fst edges
(** Call [k] on every vertex *)
let iter_vertices t k = M.iter (fun v _ -> k v) t
let vertices t = Sequence.from_iter (iter_vertices t)
(** Call [k] on every edge *)
let iter t k =
M.iter
(fun v1 node -> List.iter (fun (e, v2) -> k (v1, e, v2)) node.n_next)
t
let to_seq t = Sequence.from_iter (iter t)
(** {2 Global operations} *)
(** Roots, ie vertices with no incoming edges *)
let roots g =
let vertices = vertices g in
Sequence.filter (fun v -> Sequence.is_empty (prev g v)) vertices
(** Leaves, ie vertices with no outgoing edges *)
let leaves g =
let vertices = vertices g in
Sequence.filter (fun v -> Sequence.is_empty (next g v)) vertices
(** Pick a vertex, or raise Not_found *)
let choose g = fst (M.choose g)
let rev_edge (v,e,v') = (v',e,v)
(** Reverse all edges *)
let rev g =
M.map
(fun node -> {node with n_prev=node.n_next; n_next=node.n_prev})
g
(** {2 Traversals} *)
(** Breadth-first search *)
let bfs graph first k =
let q = Queue.create ()
and explored = ref (S.singleton first) in
Queue.push first q;
while not (Queue.is_empty q) do
let v = Queue.pop q in
(* yield current node *)
k v;
(* explore children *)
Sequence.iter Sequence.iter
(fun (e, v') -> if not (S.mem v' !explored) (fun (e, v') ->
then (explored := S.add v' !explored; Queue.push v' q)) try let n' = PHashtbl.find labels v' in
(next graph v) if n' < n && List.exists (fun (_,n'') -> n' = n'') trail'
done then back_edge (v,e,v') (* back edge, cycle *)
else
fwd_edge (v,e,v') (* forward or cross edge *)
with Not_found ->
tree_edge (v,e,v'); (* tree edge *)
explore trail' v') (* explore the subnode *)
(next graph v);
(* exit the node *)
exit trail'
end
in
explore [] first
let bfs_seq graph first = Sequence.from_iter (fun k -> bfs graph first k) (** Depth-first search, from given vertex. Each vertex is labelled
with its index in the traversal order. *)
let dfs graph first k =
(* callback upon entering node *)
let enter = function
| [] -> assert false
| (v,n)::_ -> k (v,n)
in
dfs_full graph ~enter first
(** DFS, with callbacks called on each encountered node and edge *) (** Is the graph acyclic? *)
let dfs_full graph ?(labels=ref M.empty) let is_dag g =
?(enter=fun _ -> ()) ?(exit=fun _ -> ()) if is_empty g then true
?(tree_edge=fun _ -> ()) ?(fwd_edge=fun _ -> ()) ?(back_edge=fun _ -> ()) else if Sequence.is_empty (roots g) then false (* DAGs have roots *)
first else try
= let labels = mk_v_table g in
(* next free number for traversal *) (* do a DFS from each root; any back edge indicates a cycle *)
let count = ref (-1) in Sequence.iter
M.iter (fun _ i -> count := max i !count) !labels; (fun v ->
(* explore the vertex. trail is the reverse path from v to first *) dfs_full g ~labels ~back_edge:(fun _ -> raise Exit) v)
let rec explore trail v = (roots g);
if M.mem v !labels then () else begin true (* complete traversal without back edge *)
(* first time we explore this node! give it an index, put it in trail *) with Exit ->
let n = (incr count; !count) in false (* back edge detected! *)
labels := M.add v n !labels;
let trail' = (v, n) :: trail in (** {2 Path operations} *)
(* enter the node *)
enter trail'; type ('v, 'e) path = ('v * 'e * 'v) list
(* explore edges *)
(** Reverse the path *)
let rev_path p =
let rec rev acc p = match p with
| [] -> acc
| (v,e,v')::p' -> rev ((v',e,v)::acc) p'
in rev [] p
exception ExitBfs
(** Find the minimal path, from the given [vertex], that does not contain
any vertex satisfying [ignore], and that reaches a vertex
that satisfies [goal]. It raises Not_found if no reachable node
satisfies [goal]. *)
let min_path_full (type v) (type e) graph
?(cost=fun _ _ _ -> 1) ?(ignore=fun _ -> false) ~goal v =
let module HQ = Leftistheap.Make(struct
type t = v * int * (v, e) path
let le (_,i,_) (_,j,_) = i <= j
end) in
let q = ref HQ.empty in
let explored = mk_v_set graph in
q := HQ.insert (v, 0, []) !q;
let best_path = ref (v,0,[]) in
try
while not (HQ.is_empty !q) do
let (v, cost_v, path), q' = HQ.extract_min !q in
q := q';
if Hashset.mem explored v then () (* a shorter path is known *)
else if ignore v then () (* ignore the node. *)
else if goal v path (* shortest path to goal node! *)
then (best_path := v, cost_v, path; raise ExitBfs)
else begin
Hashset.add explored v;
(* explore successors *)
Sequence.iter Sequence.iter
(fun (e, v') -> (fun (e, v') ->
try let n' = M.find v' !labels in if Hashset.mem explored v' || ignore v' then ()
if n' < n && List.exists (fun (_,n'') -> n' = n'') trail' else
then back_edge (v,e,v') (* back edge, cycle *) let cost_v' = (cost v e v') + cost_v in
else let path' = (v',e,v) :: path in
fwd_edge (v,e,v') (* forward or cross edge *) q := HQ.insert (v', cost_v', path') !q)
with Not_found -> (next graph v)
tree_edge (v,e,v'); (* tree edge *)
explore trail' v') (* explore the subnode *)
(next graph v);
(* exit the node *)
exit trail'
end end
in done;
explore [] first (* if a satisfying path was found, Exit would have been raised *)
raise Not_found
with ExitBfs -> (* found shortest satisfying path *)
!best_path
(** Depth-first search, from given vertex. Each vertex is labelled (** Minimal path from first vertex to second, given the cost function *)
with its index in the traversal order. *) let min_path graph ~cost v1 v2 =
let dfs graph first k = let cost _ e _ = cost e in
(* callback upon entering node *) let goal v' _ = (PHashtbl.get_eq graph) v' v2 in
let enter = function let _,_,path = min_path_full graph ~cost ~goal v1 in
| [] -> assert false path
| (v,n)::_ -> k (v,n)
in
dfs_full graph ~enter first
(** Is the graph acyclic? *) (** Maximal distance between the given vertex, and any other vertex
let is_dag g = in the graph that is reachable from it. *)
if is_empty g then true let diameter graph v =
else if Sequence.is_empty (roots g) then false (* DAGs have roots *) let diameter = ref 0 in
else try (* no path is a goal, but we can use its length to update diameter *)
let labels = ref M.empty in let goal _ path =
(* do a DFS from each root; any back edge indicates a cycle *) diameter := max !diameter (List.length path);
Sequence.iter false
(fun v -> in
dfs_full g ~labels ~back_edge:(fun _ -> raise Exit) v) try ignore (min_path_full graph ~goal v); assert false
(roots g); with Not_found ->
true (* complete traversal without back edge *) !diameter (* explored every shortest path *)
with Exit ->
false (* back edge detected! *)
(** {2 Path operations} *) (** {2 Print to DOT} *)
type 'e path = (vertex * 'e * vertex) list type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
(** Reverse the path *) (** Pretty print the graph in DOT, on given formatter. Using a sequence
let rev_path p = allows to easily select which edges are important,
let rec rev acc p = match p with or to combine several graphs with [Sequence.append]. *)
| [] -> acc let pp ~name ?vertices
| (v,e,v')::p' -> rev ((v',e,v)::acc) p' ~(print_edge : 'v -> 'e -> 'v -> attribute list)
in rev [] p ~(print_vertex : 'v -> attribute list) formatter (graph : ('v, 'e) t) =
(* map vertex -> unique int *)
exception ExitBfs let vertices = match vertices with
| Some v -> v
(** Find the minimal path, from the given [vertex], that does not contain | None -> mk_v_table graph in
any vertex satisfying [ignore], and that reaches a vertex (* map from vertices to integers *)
that satisfies [goal]. It raises Not_found if no reachable node let get_id =
satisfies [goal]. *) let count_map = mk_v_table graph
let min_path_full (type e) graph ?(cost=fun _ _ _ -> 1) ?(ignore=fun _ -> false) ~goal v = and count = ref 0 in
let module HQ = Leftistheap.Make(struct fun vertex ->
type t = vertex * int * e path try PHashtbl.find count_map vertex
let le (_,i,_) (_,j,_) = i <= j with Not_found ->
end) in let n = !count in
let q = ref HQ.empty in incr count;
let explored = ref S.empty in PHashtbl.replace count_map vertex n;
q := HQ.insert (v, 0, []) !q; n
let best_path = ref (v,0,[]) in (* print an attribute *)
try and print_attribute formatter attr =
while not (HQ.is_empty !q) do match attr with
let (v, cost_v, path), q' = HQ.extract_min !q in | `Color c -> Format.fprintf formatter "color=%s" c
q := q'; | `Shape s -> Format.fprintf formatter "shape=%s" s
if S.mem v !explored then () (* a shorter path is known *) | `Weight w -> Format.fprintf formatter "weight=%d" w
else if ignore v then () (* ignore the node. *) | `Style s -> Format.fprintf formatter "style=%s" s
else if goal v path (* shortest path to goal node! *) | `Label l -> Format.fprintf formatter "label=\"%s\"" l
then (best_path := v, cost_v, path; raise ExitBfs) | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value
else begin in
explored := S.add v !explored; (* the unique name of a vertex *)
(* explore successors *) let pp_vertex formatter v =
Sequence.iter Format.fprintf formatter "vertex_%d" (get_id v) in
(fun (e, v') -> (* print preamble *)
if S.mem v' !explored || ignore v' then () Format.fprintf formatter "@[<v2>digraph %s {@;" name;
else (* print edges *)
let cost_v' = (cost v e v') + cost_v in Sequence.iter
let path' = (v',e,v) :: path in (fun (v1, e, v2) ->
q := HQ.insert (v', cost_v', path') !q) let attributes = print_edge v1 e v2 in
(next graph v) Format.fprintf formatter " @[<h>%a -> %a [%a];@]@."
end pp_vertex v1 pp_vertex v2
done; (Sequence.pp_seq ~sep:"," print_attribute)
(* if a satisfying path was found, Exit would have been raised *) (Sequence.of_list attributes))
raise Not_found (to_seq graph);
with ExitBfs -> (* found shortest satisfying path *) (* print vertices *)
!best_path PHashtbl.iter
(fun v _ ->
(** Minimal path from first vertex to second, given the cost function *) let attributes = print_vertex v in
let min_path graph ~cost v1 v2 = Format.fprintf formatter " @[<h>%a [%a];@]@." pp_vertex v
let cost _ e _ = cost e in (Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attributes))
let goal v' _ = V.compare v' v2 = 0 in vertices;
let _,_,path = min_path_full graph ~cost ~goal v1 in (* close *)
path Format.fprintf formatter "}@]@;";
()
(** Maximal distance between the given vertex, and any other vertex
in the graph that is reachable from it. *)
let diameter graph v =
let diameter = ref 0 in
(* no path is a goal, but we can use its length to update diameter *)
let goal _ path =
diameter := max !diameter (List.length path);
false
in
try ignore (min_path_full graph ~goal v); assert false
with Not_found ->
!diameter (* explored every shortest path *)
(** {2 Print to DOT} *)
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
type 'e dot_printer = {
print_edge : vertex -> 'e -> vertex -> attribute list;
print_vertex : vertex -> attribute list;
} (** Dot printer for graphs of type ['e G.t] *)
(** Create a Dot graph printer. Functions to convert edges and vertices
to Dot attributes must be provided. *)
let mk_dot_printer ~print_edge ~print_vertex = {
print_vertex;
print_edge;
}
(** Pretty print the graph in DOT, on given formatter. Using a sequence
allows to easily select which edges are important,
or to combine several graphs with [Sequence.append]. *)
let pp printer ?(vertices=S.empty) ~name formatter edges =
(* map from vertices to integers *)
let get_id =
let count_map = ref M.empty
and count = ref 0 in
fun vertex ->
try M.find vertex !count_map
with Not_found ->
let n = !count in
incr count;
count_map := M.add vertex n !count_map;
n
(* accumulate vertices *)
and vertices = ref vertices
(* print an attribute *)
and print_attribute formatter attr =
match attr with
| `Color c -> Format.fprintf formatter "color=%s" c
| `Shape s -> Format.fprintf formatter "shape=%s" s
| `Weight w -> Format.fprintf formatter "weight=%d" w
| `Style s -> Format.fprintf formatter "style=%s" s
| `Label l -> Format.fprintf formatter "label=\"%s\"" l
| `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value
in
(* the name of a vertex *)
let pp_vertex formatter v = Format.fprintf formatter "vertex_%d" (get_id v) in
(* print preamble *)
Format.fprintf formatter "@[<v2>digraph %s {@;" name;
(* print edges *)
Sequence.iter
(fun (v1, e, v2) ->
(* add v1 and v2 to set of vertices *)
vertices := S.add v1 (S.add v2 !vertices);
let attributes = printer.print_edge v1 e v2 in
Format.fprintf formatter " @[<h>%a -> %a [%a];@]@."
pp_vertex v1 pp_vertex v2
(Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attributes))
edges;
(* print vertices *)
S.iter
(fun v ->
let attributes = printer.print_vertex v in
Format.fprintf formatter " @[<h>%a [%a];@]@." pp_vertex v
(Sequence.pp_seq ~sep:"," print_attribute) (Sequence.of_list attributes))
!vertices;
(* close *)
Format.fprintf formatter "}@]@;";
()
end

200
graph.mli
View file

@ -25,141 +25,135 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 A simple persistent directed graph.} *) (** {1 A simple persistent directed graph.} *)
module type S = sig (** {2 Basics} *)
(** {2 Basics} *)
type vertex type ('v, 'e) t
(** Graph parametrized by a type for vertices, and a type for edges *)
module M : Map.S with type key = vertex val empty : ?hash:('v -> int) -> ?eq:('v -> 'v -> bool) -> int -> ('v, 'e) t
module S : Set.S with type elt = vertex (** Create an empty graph. The int argument specifies the initial size *)
type 'e t val mk_v_set : ?size:int -> ('v, _) t -> 'v Hashset.t
(** Graph parametrized by a type for edges *) (** Create an empty set of vertices *)
val empty : 'e t val mk_v_table : ?size:int -> ('v, _) t -> ('v, 'a) PHashtbl.t
(** Create an empty graph. *) (** Create an empty hashtable of vertices *)
val is_empty : 'e t -> bool val copy : ('v, 'e) t -> ('v, 'e) t
(** Is the graph empty? *) (** Copy the graph *)
val length : 'e t -> int val is_empty : (_, _) t -> bool
(** Number of vertices *) (** Is the graph empty? *)
val add : 'e t -> vertex -> 'e -> vertex -> 'e t val length : (_, _) t -> int
(** Add an edge between two vertices *) (** Number of vertices *)
val add_seq : 'e t -> (vertex * 'e * vertex) Sequence.t -> 'e t val add : ('v,'e) t -> 'v -> 'e -> 'v -> unit
(** Add the vertices to the graph *) (** Add an edge between two vertices *)
val next : 'e t -> vertex -> ('e * vertex) Sequence.t val add_seq : ('v,'e) t -> ('v * 'e * 'v) Sequence.t -> unit
(** Outgoing edges *) (** Add the vertices to the graph *)
val prev : 'e t -> vertex -> ('e * vertex) Sequence.t val next : ('v, 'e) t -> 'v -> ('e * 'v) Sequence.t
(** Incoming edges *) (** Outgoing edges *)
val between : 'e t -> vertex -> vertex -> 'e Sequence.t val prev : ('v, 'e) t -> 'v -> ('e * 'v) Sequence.t
(** Incoming edges *)
val iter_vertices : 'e t -> (vertex -> unit) -> unit val between : ('v, 'e) t -> 'v -> 'v -> 'e Sequence.t
val vertices : 'e t -> vertex Sequence.t
(** Iterate on vertices *)
val iter : 'e t -> (vertex * 'e * vertex -> unit) -> unit val iter_vertices : ('v, 'e) t -> ('v -> unit) -> unit
val to_seq : 'e t -> (vertex * 'e * vertex) Sequence.t val vertices : ('v, 'e) t -> 'v Sequence.t
(** Dump the graph as a sequence of vertices *) (** Iterate on vertices *)
(** {2 Global operations} *) val iter : ('v, 'e) t -> ('v * 'e * 'v -> unit) -> unit
val to_seq : ('v, 'e) t -> ('v * 'e * 'v) Sequence.t
(** Dump the graph as a sequence of vertices *)
val roots : 'e t -> vertex Sequence.t (** {2 Global operations} *)
(** Roots, ie vertices with no incoming edges *)
val leaves : 'e t -> vertex Sequence.t val roots : ('v, 'e) t -> 'v Sequence.t
(** Leaves, ie vertices with no outgoing edges *) (** Roots, ie vertices with no incoming edges *)
val choose : 'e t -> vertex val leaves : ('v, 'e) t -> 'v Sequence.t
(** Pick a vertex, or raise Not_found *) (** Leaves, ie vertices with no outgoing edges *)
val rev_edge : (vertex * 'e * vertex) -> (vertex * 'e * vertex) val choose : ('v, 'e) t -> 'v
val rev : 'e t -> 'e t (** Pick a 'v, or raise Not_found *)
(** Reverse all edges *)
(** {2 Traversals} *) val rev_edge : ('v * 'e * 'v) -> ('v * 'e * 'v)
(** Reverse one edge *)
val bfs : 'e t -> vertex -> (vertex -> unit) -> unit val rev : ('v, 'e) t -> unit
val bfs_seq : 'e t -> vertex -> vertex Sequence.t (** Reverse all edges in the graph, in place *)
(** Breadth-first search, from given vertex *)
val dfs_full : 'e t -> (** {2 Traversals} *)
?labels:int M.t ref ->
?enter:((vertex * int) list -> unit) ->
?exit:((vertex * int) list -> unit) ->
?tree_edge:((vertex * 'e * vertex) -> unit) ->
?fwd_edge:((vertex * 'e * vertex) -> unit) ->
?back_edge:((vertex * 'e * vertex) -> unit) ->
vertex ->
unit
(** DFS, with callbacks called on each encountered node and edge *)
val dfs : 'e t -> vertex -> ((vertex * int) -> unit) -> unit val bfs : ('v, 'e) t -> 'v -> ('v -> unit) -> unit
(** Depth-first search, from given vertex. Each vertex is labelled (** Breadth-first search, from given 'v *)
with its index in the traversal order. *)
val is_dag : 'e t -> bool val bfs_seq : ('v, 'e) t -> 'v -> 'v Sequence.t
(** Is the graph acyclic? *) (** Sequence of vertices traversed during breadth-first search *)
(** {2 Path operations} *) val dfs_full : ('v, 'e) t ->
?labels:('v, int) PHashtbl.t ->
?enter:(('v * int) list -> unit) ->
?exit:(('v * int) list -> unit) ->
?tree_edge:(('v * 'e * 'v) -> unit) ->
?fwd_edge:(('v * 'e * 'v) -> unit) ->
?back_edge:(('v * 'e * 'v) -> unit) ->
'v ->
unit
(** DFS, with callbacks called on each encountered node and edge *)
type 'e path = (vertex * 'e * vertex) list val dfs : ('v, 'e) t -> 'v -> (('v * int) -> unit) -> unit
(** Depth-first search, from given 'v. Each 'v is labelled
with its index in the traversal order. *)
val rev_path : 'e path -> 'e path val is_dag : ('v, 'e) t -> bool
(** Reverse the path *) (** Is the graph acyclic? *)
val min_path_full : 'e t -> (** {2 Path operations} *)
?cost:(vertex -> 'e -> vertex -> int) ->
?ignore:(vertex -> bool) ->
goal:(vertex -> 'e path -> bool) ->
vertex ->
vertex * int * 'e path
(** Find the minimal path, from the given [vertex], that does not contain
any vertex satisfying [ignore], and that reaches a vertex
that satisfies [goal]. It raises Not_found if no reachable node
satisfies [goal]. *)
val min_path : 'e t -> cost:('e -> int) -> vertex -> vertex -> 'e path type ('v, 'e) path = ('v * 'e * 'v) list
(** Minimal path from first vertex to second, given the cost function, (** A path is a list of edges connected by vertices. *)
or raises Not_found *)
val diameter : 'e t -> vertex -> int val rev_path : ('v, 'e) path -> ('v, 'e) path
(** Maximal distance between the given vertex, and any other vertex (** Reverse the path *)
in the graph that is reachable from it. *)
(** {2 Print to DOT} *) val min_path_full : ('v, 'e) t ->
?cost:('v -> 'e -> 'v -> int) ->
?ignore:('v -> bool) ->
goal:('v -> ('v, 'e) path -> bool) ->
'v ->
'v * int * ('v, 'e) path
(** Find the minimal path, from the given ['v], that does not contain
any 'v satisfying [ignore], and that reaches a 'v
that satisfies [goal]. It raises Not_found if no reachable node
satisfies [goal]. *)
type attribute = [ val min_path : ('v, 'e) t -> cost:('e -> int) -> 'v -> 'v -> ('v,'e) path
| `Color of string (** Minimal path from first 'v to second, given the cost function,
| `Shape of string or raises Not_found *)
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
type 'e dot_printer val diameter : ('v, 'e) t -> 'v -> int
(** Helper to print a graph to DOT *) (** Maximal distance between the given 'v, and any other 'v
in the graph that is reachable from it. *)
val mk_dot_printer : (** {2 Print to DOT} *)
print_edge:(vertex -> 'e -> vertex -> attribute list) ->
print_vertex:(vertex -> attribute list) ->
'e dot_printer
(** Create a Dot graph printer. Functions to convert edges and vertices
to Dot attributes must be provided. *)
val pp : 'e dot_printer -> ?vertices:S.t -> name:string -> type attribute = [
Format.formatter -> | `Color of string
(vertex * 'e * vertex) Sequence.t -> unit | `Shape of string
(** Pretty print the graph in DOT, on given formatter. Using a sequence | `Weight of int
allows to easily select which edges are important, | `Style of string
or to combine several graphs with [Sequence.append]. | `Label of string
An optional set of additional vertices to print can be given. *) | `Other of string * string
end ] (** Dot attribute *)
module Make(V : Map.OrderedType) : S with type vertex = V.t val pp : name:string -> ?vertices:('v,int) PHashtbl.t ->
print_edge:('v -> 'e -> 'v -> attribute list) ->
print_vertex:('v -> attribute list) ->
Format.formatter ->
('v, 'e) t -> unit
(** Pretty print the graph in DOT, on given formatter. *)