simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 19:25:28 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

simplify and cleanup of CCGraph

Browse source
This commit is contained in:
Simon Cruanes 2016-11-03 23:25:39 +01:00
parent 7229f04981
commit 13b34f4fcf
2 changed files with 187 additions and 265 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

300
src/data/CCGraph.ml
View file

@ -1,27 +1,9 @@
(*
copyright (c) 2013-2015, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without (* This file is free software, part of containers. See file "license" for more details. *)
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this (** {1 Simple Graph Interface} *)
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND (** {2 Sequence Helpers} *)
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
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.
*)
type 'a sequence = ('a -> unit) -> unit type 'a sequence = ('a -> unit) -> unit
@ -51,24 +33,12 @@ end
(** {2 Interfaces for graphs} *) (** {2 Interfaces for graphs} *)
(** Directed graph with vertices of type ['v] and edges of type [e'] *) (** Directed graph with vertices of type ['v] and edges labeled with [e'] *)
type ('v, 'e) t = { type ('v, 'e) t = ('v -> ('e * 'v) sequence)
children: 'v -> 'e sequence;
origin: 'e -> 'v;
dest: 'e -> 'v;
}
type ('v, 'e) graph = ('v, 'e) t type ('v, 'e) graph = ('v, 'e) t
let make ~origin ~dest f = {origin; dest; children=f; } let make (f:'v->('e*'v) sequence): ('v, 'e) t = f
let make_labelled_tuple f =
make ~origin:(fun (x,_,_) -> x) ~dest:(fun (_,_,x) -> x)
(fun v yield -> f v (fun (l,v') -> yield (v,l,v')))
let make_tuple f =
make ~origin:fst ~dest:snd
(fun v yield -> f v (fun v' -> yield (v,v')))
(** Mutable bitset for values of type ['v] *) (** Mutable bitset for values of type ['v] *)
type 'v tag_set = { type 'v tag_set = {
@ -171,7 +141,7 @@ let mk_heap ~leq =
(** {2 Traversals} *) (** {2 Traversals} *)
module Traverse = struct module Traverse = struct
type 'e path = 'e list type ('v, 'e) path = ('v * 'e * 'v) list
let generic_tag ~tags ~bag ~graph seq = let generic_tag ~tags ~bag ~graph seq =
let first = ref true in let first = ref true in
@ -185,8 +155,8 @@ module Traverse = struct
k x; k x;
tags.set_tag x; tags.set_tag x;
Seq.iter Seq.iter
(fun e -> bag.push (graph.dest e)) (fun (_,dest) -> bag.push dest)
(graph.children x) (graph x)
) )
done done
@ -209,11 +179,10 @@ module Traverse = struct
set_tag=(fun (v,_,_) -> tags.set_tag v); set_tag=(fun (v,_,_) -> tags.set_tag v);
} }
and seq' = Seq.map (fun v -> v, 0, []) seq and seq' = Seq.map (fun v -> v, 0, []) seq
and graph' = { and graph' (v,d,p) =
children=(fun (v,d,p) -> Seq.map (fun e -> e, d, p) (graph.children v)); graph v
origin=(fun (e, d, p) -> graph.origin e, d, p); |> Seq.map (fun (e,v') -> e, (v',d+dist e, (v,e,v')::p))
dest=(fun (e, d, p) -> graph.dest e, d + dist e, e :: p); in
} in
let bag = mk_heap ~leq:(fun (_,d1,_) (_,d2,_) -> d1 <= d2) in let bag = mk_heap ~leq:(fun (_,d1,_) (_,d2,_) -> d1 <= d2) in
generic_tag ~tags:tags' ~bag ~graph:graph' seq' generic_tag ~tags:tags' ~bag ~graph:graph' seq'
@ -235,9 +204,9 @@ module Traverse = struct
(** A traversal is a sequence of such events *) (** A traversal is a sequence of such events *)
type ('v,'e) t = type ('v,'e) t =
[ `Enter of 'v * int * 'e path (* unique index in traversal, path from start *) [ `Enter of 'v * int * ('v,'e) path (* unique index in traversal, path from start *)
| `Exit of 'v | `Exit of 'v
| `Edge of 'e * edge_kind | `Edge of 'v * 'e * 'v * edge_kind
] ]
let get_vertex = function let get_vertex = function
@ -256,20 +225,20 @@ module Traverse = struct
| `Edge _ -> None | `Edge _ -> None
let get_edge = function let get_edge = function
| `Edge (e, _) -> Some e | `Edge (v1,e,v2,_) -> Some (v1,e,v2)
| `Enter _ | `Enter _
| `Exit _ -> None | `Exit _ -> None
let get_edge_kind = function let get_edge_kind = function
| `Edge (e, k) -> Some (e, k) | `Edge (v,e,v',k) -> Some (v,e,v',k)
| `Enter _ | `Enter _
| `Exit _ -> None | `Exit _ -> None
(* is [v] the origin of some edge in [path]? *) (* is [v] the origin of some edge in [path]? *)
let rec list_mem_ ~eq ~graph v path = match path with let rec list_mem_ ~eq ~graph v path = match path with
| [] -> false | [] -> false
| e :: path' -> | (v1,_,_) :: path' ->
eq v (graph.origin e) || list_mem_ ~eq ~graph v path' eq v v1 || list_mem_ ~eq ~graph v path'
let dfs_tag ?(eq=(=)) ~tags ~graph seq = let dfs_tag ?(eq=(=)) ~tags ~graph seq =
let first = ref true in let first = ref true in
@ -291,22 +260,22 @@ module Traverse = struct
k (`Enter (x, num, path)); k (`Enter (x, num, path));
bag.push (`Exit x); bag.push (`Exit x);
Seq.iter Seq.iter
(fun e -> bag.push (`Edge (e, e :: path))) (fun (e,v') -> bag.push (`Edge (v,e,v',(v,e,v') :: path)))
(graph.children x); (graph x);
) )
| `Exit x -> k (`Exit x) | `Exit x -> k (`Exit x)
| `Edge (e, path) -> | `Edge (v,e,v', path) ->
let v = graph.dest e in
let edge_kind = let edge_kind =
if tags.get_tag v if tags.get_tag v'
then if list_mem_ ~eq ~graph v path then if list_mem_ ~eq ~graph v' path
then `Back then `Back
else `Cross else `Cross
else ( else (
bag.push (`Enter (v, path)); bag.push (`Enter (v', path));
`Forward `Forward
) in )
k (`Edge (e, edge_kind)) in
k (`Edge (v,e,v', edge_kind))
done done
) seq ) seq
@ -325,7 +294,7 @@ let is_dag ?(tbl=mk_table 128) ~graph vs =
Traverse.Event.dfs ~tbl ~graph vs Traverse.Event.dfs ~tbl ~graph vs
|> Seq.exists_ |> Seq.exists_
(function (function
| `Edge (_, `Back) -> true | `Edge (_, _, _, `Back) -> true
| _ -> false) | _ -> false)
(** {2 Topological Sort} *) (** {2 Topological Sort} *)
@ -339,7 +308,7 @@ let topo_sort_tag ?(eq=(=)) ?(rev=false) ~tags ~graph seq =
|> Seq.filter_map |> Seq.filter_map
(function (function
| `Exit v -> Some v | `Exit v -> Some v
| `Edge (_, `Back) -> raise Has_cycle | `Edge (_, _, _, `Back) -> raise Has_cycle
| `Enter _ | `Enter _
| `Edge _ -> None | `Edge _ -> None
) )
@ -371,16 +340,19 @@ let topo_sort ?eq ?rev ?(tbl=mk_table 128) ~graph seq =
(** {2 Lazy Spanning Tree} *) (** {2 Lazy Spanning Tree} *)
module LazyTree = struct module Lazy_tree = struct
type ('v, 'e) t = type ('v, 'e) t = {
| Vertex of 'v * ('e * ('v, 'e) t) list Lazy.t vertex: 'v;
children: ('e * ('v, 'e) t) list Lazy.t;
}
let rec map_v f (Vertex (v, l)) = let make_ vertex children = {vertex; children}
let rec map_v f {vertex=v; children=l} =
let l' = lazy (List.map (fun (e, child) -> e, map_v f child) (Lazy.force l)) in let l' = lazy (List.map (fun (e, child) -> e, map_v f child) (Lazy.force l)) in
Vertex (f v, l') make_ (f v) l'
let rec fold_v f acc t = match t with let rec fold_v f acc {vertex=v; children=l} =
| Vertex (v, l) ->
let acc = f acc v in let acc = f acc v in
List.fold_left List.fold_left
(fun acc (_, t') -> fold_v f acc t') (fun acc (_, t') -> fold_v f acc t')
@ -392,18 +364,17 @@ let spanning_tree_tag ~tags ~graph v =
let rec mk_node v = let rec mk_node v =
let children = lazy ( let children = lazy (
Seq.fold Seq.fold
(fun acc e -> (fun acc (e,v') ->
let v' = graph.dest e in
if tags.get_tag v' if tags.get_tag v'
then acc then acc
else ( else (
tags.set_tag v'; tags.set_tag v';
(e, mk_node v') :: acc (e, mk_node v') :: acc
) )
) [] (graph.children v) ) [] (graph v)
) )
in in
LazyTree.Vertex (v, children) Lazy_tree.make_ v children
in in
mk_node v mk_node v
@ -469,21 +440,20 @@ module SCC = struct
Stack.push (`Exit (v, cell)) to_explore; Stack.push (`Exit (v, cell)) to_explore;
(* explore children *) (* explore children *)
Seq.iter Seq.iter
(fun e -> Stack.push (`Enter (graph.dest e)) to_explore) (fun (_,v') -> Stack.push (`Enter v') to_explore)
(graph.children v) (graph v)
) )
| `Exit (v, cell) -> | `Exit (v, cell) ->
(* update [min_id] *) (* update [min_id] *)
assert cell.on_stack; assert cell.on_stack;
Seq.iter Seq.iter
(fun e -> (fun (_,dest) ->
let dest = graph.dest e in
(* must not fail, [dest] already explored *) (* must not fail, [dest] already explored *)
let dest_cell = tbl.find dest in let dest_cell = tbl.find dest in
(* same SCC? yes if [dest] points to [cell.v] *) (* same SCC? yes if [dest] points to [cell.v] *)
if dest_cell.on_stack if dest_cell.on_stack
then cell.min_id <- min cell.min_id dest_cell.min_id then cell.min_id <- min cell.min_id dest_cell.min_id
) (graph.children v); ) (graph v);
(* pop from stack if SCC found *) (* pop from stack if SCC found *)
if cell.id = cell.min_id then ( if cell.id = cell.min_id then (
let scc = pop_down_to ~id:cell.id [] stack in let scc = pop_down_to ~id:cell.id [] stack in
@ -602,9 +572,7 @@ module Dot = struct
let attrs = attrs_v v in let attrs = attrs_v v in
Format.fprintf out "@[<h>%a %a;@]@," pp_vertex v (pp_list pp_attr) attrs Format.fprintf out "@[<h>%a %a;@]@," pp_vertex v (pp_list pp_attr) attrs
| `Exit _ -> () | `Exit _ -> ()
| `Edge (e, _) -> | `Edge (v1,e,v2,_) ->
let v1 = graph.origin e in
let v2 = graph.dest e in
let attrs = attrs_e e in let attrs = attrs_e e in
Format.fprintf out "@[<h>%a -> %a %a;@]@," Format.fprintf out "@[<h>%a -> %a %a;@]@,"
pp_vertex v1 pp_vertex v2 pp_vertex v1 pp_vertex v2
@ -633,11 +601,11 @@ end
(** {2 Mutable Graph} *) (** {2 Mutable Graph} *)
type ('v, 'e) mut_graph = < type ('v, 'e) mut_graph = {
graph: ('v, 'e) t; graph: ('v, 'e) t;
add_edge: 'e -> unit; add_edge: 'v -> 'e -> 'v -> unit;
remove : 'v -> unit; remove : 'v -> unit;
> }
let mk_mut_tbl (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size = let mk_mut_tbl (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size =
let module Tbl = Hashtbl.Make(struct let module Tbl = Hashtbl.Make(struct
@ -646,174 +614,158 @@ let mk_mut_tbl (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size =
let equal = eq let equal = eq
end) in end) in
let tbl = Tbl.create size in let tbl = Tbl.create size in
object {
method graph = { graph=(fun v yield ->
origin=(fun (x,_,_) -> x); try List.iter yield (Tbl.find tbl v)
dest=(fun (_,_,x) -> x);
children=(fun v k ->
try List.iter k (Tbl.find tbl v)
with Not_found -> () with Not_found -> ()
); );
} add_edge=(fun v1 e v2 ->
method add_edge (v1,e,v2) =
let l = try Tbl.find tbl v1 with Not_found -> [] in let l = try Tbl.find tbl v1 with Not_found -> [] in
Tbl.replace tbl v1 ((v1,e,v2)::l) Tbl.replace tbl v1 ((e,v2)::l)
method remove v = Tbl.remove tbl v );
end remove = (fun v -> Tbl.remove tbl v);
}
(** {2 Immutable Graph} *) (** {2 Immutable Graph} *)
module type MAP = sig module type MAP = sig
type vertex type vertex
type t type 'a t
val as_graph : t -> (vertex, (vertex * vertex)) graph val as_graph : 'a t -> (vertex, 'a) graph
(** Graph view of the map *) (** Graph view of the map *)
val empty : t val empty : 'a t
val add_edge : vertex -> vertex -> t -> t val add_edge : vertex -> 'a -> vertex -> 'a t -> 'a t
val remove_edge : vertex -> vertex -> t -> t val remove_edge : vertex -> vertex -> 'a t -> 'a t
val add : vertex -> t -> t val add : vertex -> 'a t -> 'a t
(** Add a vertex, possibly with no outgoing edge *) (** Add a vertex, possibly with no outgoing edge *)
val remove : vertex -> t -> t val remove : vertex -> 'a t -> 'a t
(** Remove the vertex and all its outgoing edges. (** Remove the vertex and all its outgoing edges.
Edges that point to the vertex are {b NOT} removed, they must be Edges that point to the vertex are {b NOT} removed, they must be
manually removed with {!remove_edge} *) manually removed with {!remove_edge} *)
val union : t -> t -> t val union : 'a t -> 'a t -> 'a t
val vertices : t -> vertex sequence val vertices : _ t -> vertex sequence
val vertices_l : t -> vertex list val vertices_l : _ t -> vertex list
val of_list : (vertex * vertex) list -> t val of_list : (vertex * 'a * vertex) list -> 'a t
val add_list : (vertex * vertex) list -> t -> t val add_list : (vertex * 'a * vertex) list -> 'a t -> 'a t
val to_list : t -> (vertex * vertex) list val to_list : 'a t -> (vertex * 'a * vertex) list
val of_seq : (vertex * vertex) sequence -> t val of_seq : (vertex * 'a * vertex) sequence -> 'a t
val add_seq : (vertex * vertex) sequence -> t -> t val add_seq : (vertex * 'a * vertex) sequence -> 'a t -> 'a t
val to_seq : t -> (vertex * vertex) sequence val to_seq : 'a t -> (vertex * 'a * vertex) sequence
end end
module Map(O : Map.OrderedType) = struct module Map(O : Map.OrderedType) : MAP with type vertex = O.t = struct
module M = Map.Make(O) module M = Map.Make(O)
module S = Set.Make(O)
type vertex = O.t type vertex = O.t
type t = { type 'a t = 'a M.t M.t
edges: S.t M.t; (* vertex -> set of (vertex * label) *)
vertices: S.t;
}
let as_graph m = { let as_graph m =
origin=fst; (fun v yield ->
dest=snd;
children=(fun v yield ->
try try
let set = M.find v m.edges in let sub = M.find v m in
S.iter (fun v' -> yield (v, v')) set M.iter (fun v' e -> yield (e, v')) sub
with Not_found -> () with Not_found -> ()
); )
}
let empty = {edges=M.empty; vertices=S.empty} let empty = M.empty
let add_edge v1 v2 m = let add_edge v1 e v2 m =
let set = try M.find v1 m.edges with Not_found -> S.empty in let sub = try M.find v1 m with Not_found -> M.empty in
let edges = M.add v1 (S.add v2 set) m.edges in M.add v1 (M.add v2 e sub) m
let vertices = S.add v1 (S.add v2 m.vertices) in
{ edges; vertices; }
let remove_edge v1 v2 m = let remove_edge v1 v2 m =
try try
let set = S.remove v2 (M.find v1 m.edges) in let map = M.remove v2 (M.find v1 m) in
if S.is_empty set if M.is_empty map
then {m with edges=M.remove v1 m.edges} then M.remove v1 m
else {m with edges=M.add v1 set m.edges} else M.add v1 map m
with Not_found -> m with Not_found -> m
let add v m = { m with vertices=S.add v m.vertices } let add v m =
if M.mem v m then m
else M.add v M.empty m
let remove v m = let remove v m = M.remove v m
{ edges=M.remove v m.edges; vertices=S.remove v m.vertices }
let union m1 m2 = let union m1 m2 =
{edges=M.merge M.merge
(fun _ s1 s2 -> match s1, s2 with (fun _ s1 s2 -> match s1, s2 with
| Some s, None | Some s, None
| None, Some s -> Some s | None, Some s -> Some s
| None, None -> assert false | None, None -> assert false
| Some s1, Some s2 -> Some (S.union s1 s2) | Some s1, Some s2 ->
) m1.edges m2.edges; let s =
vertices=S.union m1.vertices m2.vertices M.merge
} (fun _ e1 e2 -> match e1, e2 with
| Some _, _ -> e1
| None, _ -> e2)
s1 s2
in
Some s)
m1 m2
let vertices m yield = S.iter yield m.vertices let vertices m yield = M.iter (fun v _ -> yield v) m
let vertices_l m = S.fold (fun v acc -> v::acc) m.vertices [] let vertices_l m = M.fold (fun v _ acc -> v::acc) m []
let add_list l m = List.fold_left (fun m (v1,v2) -> add_edge v1 v2 m) m l let add_list l m = List.fold_left (fun m (v1,e,v2) -> add_edge v1 e v2 m) m l
let of_list l = add_list l empty let of_list l = add_list l empty
let to_list m = let to_list m =
M.fold M.fold
(fun v set acc -> S.fold (fun v' acc -> (v,v')::acc) set acc) (fun v map acc -> M.fold (fun v' e acc -> (v,e,v')::acc) map acc)
m.edges [] m []
let add_seq seq m = Seq.fold (fun m (v1,v2) -> add_edge v1 v2 m) m seq let add_seq seq m = Seq.fold (fun m (v1,e,v2) -> add_edge v1 e v2 m) m seq
let of_seq seq = add_seq seq empty let of_seq seq = add_seq seq empty
let to_seq m k = M.iter (fun v set -> S.iter (fun v' -> k(v,v')) set) m.edges let to_seq m k = M.iter (fun v map -> M.iter (fun v' e -> k(v,e,v')) map) m
end end
(** {2 Misc} *) (** {2 Misc} *)
let of_list ?(eq=(=)) l = { let of_list ?(eq=(=)) l =
origin=fst; (fun v yield -> List.iter (fun (a,b) -> if eq a v then yield ((),b)) l)
dest=snd;
children=(fun v yield -> List.iter (fun (a,b) -> if eq a v then yield (a,b)) l)
}
let of_fun f = { let of_fun f =
origin=fst; (fun v yield ->
dest=snd;
children=(fun v yield ->
let l = f v in let l = f v in
List.iter (fun v' -> yield (v,v')) l List.iter (fun v' -> yield ((),v')) l
); )
}
let of_hashtbl tbl = { let of_hashtbl tbl =
origin=fst; (fun v yield ->
dest=snd; try List.iter (fun b -> yield ((), b)) (Hashtbl.find tbl v)
children=(fun v yield ->
try List.iter (fun b -> yield (v, b)) (Hashtbl.find tbl v)
with Not_found -> () with Not_found -> ()
) )
}
let divisors_graph = { let divisors_graph =
origin=fst; (fun i ->
dest=snd;
children=(fun i ->
(* divisors of [i] that are [>= j] *) (* divisors of [i] that are [>= j] *)
let rec divisors j i yield = let rec divisors j i yield =
if j < i if j < i
then ( then (
if (i mod j = 0) then yield (i,j); if (i mod j = 0) then yield ((),j);
divisors (j+1) i yield divisors (j+1) i yield
) )
in in
divisors 1 i divisors 1 i
); )
}

136
src/data/CCGraph.mli
View file

@ -1,27 +1,5 @@
(*
copyright (c) 2013-2015, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without (* This file is free software, part of containers. See file "license" for more details. *)
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
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.
*)
(** {1 Simple Graph Interface} (** {1 Simple Graph Interface}
@ -45,6 +23,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@since 0.12 *) @since 0.12 *)
(** {2 Sequence Helpers} *)
type 'a sequence = ('a -> unit) -> unit type 'a sequence = ('a -> unit) -> unit
(** A sequence of items of type ['a], possibly infinite *) (** A sequence of items of type ['a], possibly infinite *)
@ -65,41 +45,29 @@ module Seq : sig
val to_list : 'a t -> 'a list val to_list : 'a t -> 'a list
end end
(** {2 Interfaces for graphs} *) (** {2 Interfaces for graphs}
(** Directed graph with vertices of type ['v] and edges of type [e'] *) This interface is designed for oriented graphs with labels on edges *)
type ('v, 'e) t = {
children: 'v -> 'e sequence; (** Directed graph with vertices of type ['v] and edges labeled with [e'] *)
origin: 'e -> 'v; type ('v, 'e) t = ('v -> ('e * 'v) sequence)
dest: 'e -> 'v;
}
type ('v, 'e) graph = ('v, 'e) t type ('v, 'e) graph = ('v, 'e) t
val make : val make : ('v -> ('e * 'v) sequence) -> ('v, 'e) t
origin:('e -> 'v) -> (** Make a graph by providing the children function *)
dest:('e -> 'v) ->
('v -> 'e sequence) -> ('v, 'e) t
(** Make a graph by providing its fields
@since 0.16 *)
val make_labelled_tuple : (** {2 Tags}
('v -> ('a * 'v) sequence) -> ('v, ('v * 'a * 'v)) t
(** Make a graph with edges being triples [(origin,label,dest)]
@since 0.16 *)
val make_tuple : Mutable tags from values of type ['v] to tags of type [bool] *)
('v -> 'v sequence) -> ('v, ('v * 'v)) t
(** Make a graph with edges being pairs [(origin,dest)]
@since 0.16 *)
(** Mutable tags from values of type ['v] to tags of type [bool] *)
type 'v tag_set = { type 'v tag_set = {
get_tag: 'v -> bool; get_tag: 'v -> bool;
set_tag: 'v -> unit; (** Set tag for the given element *) set_tag: 'v -> unit; (** Set tag for the given element *)
} }
(** Mutable table with keys ['k] and values ['a] *) (** {2 Table}
Mutable table with keys ['k] and values ['a] *)
type ('k, 'a) table = { type ('k, 'a) table = {
mem: 'k -> bool; mem: 'k -> bool;
find: 'k -> 'a; (** @raise Not_found if element not added before *) find: 'k -> 'a; (** @raise Not_found if element not added before *)
@ -134,7 +102,7 @@ val mk_heap: leq:('a -> 'a -> bool) -> 'a bag
(** {2 Traversals} *) (** {2 Traversals} *)
module Traverse : sig module Traverse : sig
type 'e path = 'e list type ('v, 'e) path = ('v * 'e * 'v) list
val generic: ?tbl:'v set -> val generic: ?tbl:'v set ->
bag:'v bag -> bag:'v bag ->
@ -176,7 +144,7 @@ module Traverse : sig
?dist:('e -> int) -> ?dist:('e -> int) ->
graph:('v, 'e) t -> graph:('v, 'e) t ->
'v sequence -> 'v sequence ->
('v * int * 'e path) sequence_once ('v * int * ('v,'e) path) sequence_once
(** Dijkstra algorithm, traverses a graph in increasing distance order. (** Dijkstra algorithm, traverses a graph in increasing distance order.
Yields each vertex paired with its distance to the set of initial vertices Yields each vertex paired with its distance to the set of initial vertices
(the smallest distance needed to reach the node from the initial vertices) (the smallest distance needed to reach the node from the initial vertices)
@ -187,7 +155,7 @@ module Traverse : sig
tags:'v tag_set -> tags:'v tag_set ->
graph:('v, 'e) t -> graph:('v, 'e) t ->
'v sequence -> 'v sequence ->
('v * int * 'e path) sequence_once ('v * int * ('v,'e) path) sequence_once
(** {2 More detailed interface} *) (** {2 More detailed interface} *)
module Event : sig module Event : sig
@ -195,16 +163,16 @@ module Traverse : sig
(** A traversal is a sequence of such events *) (** A traversal is a sequence of such events *)
type ('v,'e) t = type ('v,'e) t =
[ `Enter of 'v * int * 'e path (* unique index in traversal, path from start *) [ `Enter of 'v * int * ('v,'e) path (* unique index in traversal, path from start *)
| `Exit of 'v | `Exit of 'v
| `Edge of 'e * edge_kind | `Edge of 'v * 'e * 'v * edge_kind
] ]
val get_vertex : ('v, 'e) t -> ('v * [`Enter | `Exit]) option val get_vertex : ('v, 'e) t -> ('v * [`Enter | `Exit]) option
val get_enter : ('v, 'e) t -> 'v option val get_enter : ('v, 'e) t -> 'v option
val get_exit : ('v, 'e) t -> 'v option val get_exit : ('v, 'e) t -> 'v option
val get_edge : ('v, 'e) t -> 'e option val get_edge : ('v, 'e) t -> ('v * 'e * 'v) option
val get_edge_kind : ('v, 'e) t -> ('e * edge_kind) option val get_edge_kind : ('v, 'e) t -> ('v * 'e * 'v * edge_kind) option
val dfs: ?tbl:'v set -> val dfs: ?tbl:'v set ->
?eq:('v -> 'v -> bool) -> ?eq:('v -> 'v -> bool) ->
@ -266,9 +234,11 @@ val topo_sort_tag : ?eq:('v -> 'v -> bool) ->
(** {2 Lazy Spanning Tree} *) (** {2 Lazy Spanning Tree} *)
module LazyTree : sig module Lazy_tree : sig
type ('v, 'e) t = type ('v, 'e) t = {
| Vertex of 'v * ('e * ('v, 'e) t) list Lazy.t vertex: 'v;
children: ('e * ('v, 'e) t) list Lazy.t;
}
val map_v : ('a -> 'b) -> ('a, 'e) t -> ('b, 'e) t val map_v : ('a -> 'b) -> ('a, 'e) t -> ('b, 'e) t
@ -278,14 +248,14 @@ end
val spanning_tree : ?tbl:'v set -> val spanning_tree : ?tbl:'v set ->
graph:('v, 'e) t -> graph:('v, 'e) t ->
'v -> 'v ->
('v, 'e) LazyTree.t ('v, 'e) Lazy_tree.t
(** [spanning_tree ~graph v] computes a lazy spanning tree that has [v] (** [spanning_tree ~graph v] computes a lazy spanning tree that has [v]
as a root. The table [tbl] is used for the memoization part *) as a root. The table [tbl] is used for the memoization part *)
val spanning_tree_tag : tags:'v tag_set -> val spanning_tree_tag : tags:'v tag_set ->
graph:('v, 'e) t -> graph:('v, 'e) t ->
'v -> 'v ->
('v, 'e) LazyTree.t ('v, 'e) Lazy_tree.t
(** {2 Strongly Connected Components} *) (** {2 Strongly Connected Components} *)
@ -364,16 +334,16 @@ end
(** {2 Mutable Graph} *) (** {2 Mutable Graph} *)
type ('v, 'e) mut_graph = < type ('v, 'e) mut_graph = {
graph: ('v, 'e) t; graph: ('v, 'e) t;
add_edge: 'e -> unit; add_edge: 'v -> 'e -> 'v -> unit;
remove : 'v -> unit; remove : 'v -> unit;
> }
val mk_mut_tbl : ?eq:('v -> 'v -> bool) -> val mk_mut_tbl : ?eq:('v -> 'v -> bool) ->
?hash:('v -> int) -> ?hash:('v -> int) ->
int -> int ->
('v, ('v * 'a * 'v)) mut_graph ('v, 'a) mut_graph
(** Make a new mutable graph from a Hashtbl. Edges are labelled with type ['a] *) (** Make a new mutable graph from a Hashtbl. Edges are labelled with type ['a] *)
(** {2 Immutable Graph} (** {2 Immutable Graph}
@ -385,60 +355,60 @@ val mk_mut_tbl : ?eq:('v -> 'v -> bool) ->
module type MAP = sig module type MAP = sig
type vertex type vertex
type t type 'a t
val as_graph : t -> (vertex, (vertex * vertex)) graph val as_graph : 'a t -> (vertex, 'a) graph
(** Graph view of the map *) (** Graph view of the map *)
val empty : t val empty : 'a t
val add_edge : vertex -> vertex -> t -> t val add_edge : vertex -> 'a -> vertex -> 'a t -> 'a t
val remove_edge : vertex -> vertex -> t -> t val remove_edge : vertex -> vertex -> 'a t -> 'a t
val add : vertex -> t -> t val add : vertex -> 'a t -> 'a t
(** Add a vertex, possibly with no outgoing edge *) (** Add a vertex, possibly with no outgoing edge *)
val remove : vertex -> t -> t val remove : vertex -> 'a t -> 'a t
(** Remove the vertex and all its outgoing edges. (** Remove the vertex and all its outgoing edges.
Edges that point to the vertex are {b NOT} removed, they must be Edges that point to the vertex are {b NOT} removed, they must be
manually removed with {!remove_edge} *) manually removed with {!remove_edge} *)
val union : t -> t -> t val union : 'a t -> 'a t -> 'a t
val vertices : t -> vertex sequence val vertices : _ t -> vertex sequence
val vertices_l : t -> vertex list val vertices_l : _ t -> vertex list
val of_list : (vertex * vertex) list -> t val of_list : (vertex * 'a * vertex) list -> 'a t
val add_list : (vertex * vertex) list -> t -> t val add_list : (vertex * 'a * vertex) list -> 'a t -> 'a t
val to_list : t -> (vertex * vertex) list val to_list : 'a t -> (vertex * 'a * vertex) list
val of_seq : (vertex * vertex) sequence -> t val of_seq : (vertex * 'a * vertex) sequence -> 'a t
val add_seq : (vertex * vertex) sequence -> t -> t val add_seq : (vertex * 'a * vertex) sequence -> 'a t -> 'a t
val to_seq : t -> (vertex * vertex) sequence val to_seq : 'a t -> (vertex * 'a * vertex) sequence
end end
module Map(O : Map.OrderedType) : MAP with type vertex = O.t module Map(O : Map.OrderedType) : MAP with type vertex = O.t
(** {2 Misc} *) (** {2 Misc} *)
val of_list : ?eq:('v -> 'v -> bool) -> ('v * 'v) list -> ('v, ('v * 'v)) t val of_list : ?eq:('v -> 'v -> bool) -> ('v * 'v) list -> ('v, unit) t
(** [of_list l] makes a graph from a list of pairs of vertices. (** [of_list l] makes a graph from a list of pairs of vertices.
Each pair [(a,b)] is an edge from [a] to [b]. Each pair [(a,b)] is an edge from [a] to [b].
@param eq equality used to compare vertices *) @param eq equality used to compare vertices *)
val of_hashtbl : ('v, 'v list) Hashtbl.t -> ('v, ('v * 'v)) t val of_hashtbl : ('v, 'v list) Hashtbl.t -> ('v, unit) t
(** [of_hashtbl tbl] makes a graph from a hashtable that maps vertices (** [of_hashtbl tbl] makes a graph from a hashtable that maps vertices
to lists of children *) to lists of children *)
val of_fun : ('v -> 'v list) -> ('v, ('v * 'v)) t val of_fun : ('v -> 'v list) -> ('v, unit) t
(** [of_fun f] makes a graph out of a function that maps a vertex to (** [of_fun f] makes a graph out of a function that maps a vertex to
the list of its children. The function is assumed to be deterministic. *) the list of its children. The function is assumed to be deterministic. *)
val divisors_graph : (int, (int * int)) t val divisors_graph : (int, unit) t
(** [n] points to all its strict divisors *) (** [n] points to all its strict divisors *)