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

LazyGraph is now fully polymorphic (plan to implement LazyGraph.product, which

Browse source 
cannot be expressed with functors), with optional eq/hash functions
This commit is contained in:
Simon Cruanes 2013-03-21 11:22:41 +01:00
parent e6eb9a79eb
commit e0b6b8be5b
3 changed files with 509 additions and 548 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
examples/mem_size.ml
View file

@ -1,19 +1,18 @@
(** Compute the memory footprint of a value (and its subvalues). Reference is (** Compute the memory footprint of a value (and its subvalues). Reference is
http://rwmj.wordpress.com/2009/08/05/ocaml-internals-part-2-strings-and-other-types/ *) http://rwmj.wordpress.com/2009/08/05/ocaml-internals-part-2-strings-and-other-types/ *)
module G = LazyGraph.PhysicalMake(struct type t = Obj.t end)
(** Graph on memory values *)
open Enum.Infix open Enum.Infix
(** A graph vertex is an Obj.t value *) (** A graph vertex is an Obj.t value *)
let graph x = let graph =
let force x =
if Obj.is_block x if Obj.is_block x
then then
let children = Enum.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in let children = Enum.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in
G.Node (x, Obj.tag x, children) LazyGraph.Node (x, Obj.tag x, children)
else else
G.Node (x, Obj.obj x, Enum.empty) LazyGraph.Node (x, Obj.obj x, Enum.empty)
in LazyGraph.make ~eq:(==) force
let word_size = Sys.word_size / 8 let word_size = Sys.word_size / 8
@ -24,14 +23,14 @@ let size x =
let compute_size x = let compute_size x =
let o = Obj.repr x in let o = Obj.repr x in
let vertices = G.bfs graph o in let vertices = LazyGraph.bfs graph o in
Enum.fold (fun sum (o',_,_) -> size o' + sum) 0 vertices Enum.fold (fun sum (o',_,_) -> size o' + sum) 0 vertices
let print_val fmt x = let print_val fmt x =
let o = Obj.repr x in let o = Obj.repr x in
let graph' = G.map ~edges:(fun i -> [`Label (string_of_int i)]) let graph' = LazyGraph.map ~edges:(fun i -> [`Label (string_of_int i)])
~vertices:(fun v -> [`Label (string_of_int v); `Shape "box"]) graph in ~vertices:(fun v -> [`Label (string_of_int v); `Shape "box"]) graph in
G.Dot.pp ~name:"value" graph' fmt (Enum.singleton o) LazyGraph.Dot.pp ~name:"value" graph' fmt (Enum.singleton o)
let print_val_file filename x = let print_val_file filename x =
let out = open_out filename in let out = open_out filename in

375
lazyGraph.ml
View file

@ -25,233 +25,157 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(** {1 Lazy graph data structure} *) (** {1 Lazy graph data structure} *)
module type S = sig
(** This module serves to represent directed graphs in a lazy fashion. Such (** This module serves to represent directed graphs in a lazy fashion. Such
a graph is always accessed from a given initial node (so only connected a graph is always accessed from a given initial node (so only connected
components can be represented by a single value of type ('v,'e) t). *) components can be represented by a single value of type ('v,'e) t). *)
(** {2 Type definitions} *) (** {2 Type definitions} *)
type vertex type ('id, 'v, 'e) t = {
(** The concrete type of a vertex. Vertices are considered unique within eq : 'id -> 'id -> bool;
the graph. *) hash : 'id -> int;
force : 'id -> ('id, 'v, 'e) node;
module H : Hashtbl.S with type key = vertex } (** Lazy graph structure. Vertices, that have unique identifiers of type 'id,
are annotated with values of type 'v, and edges are annotated by type 'e.
type ('v, 'e) t = vertex -> ('v, 'e) node A graph is a function that maps each identifier to a label and some edges to
(** Lazy graph structure. Vertices are annotated with values of type 'v, other vertices, or to Empty if the identifier is not part of the graph. *)
and edges are of type 'e. A graph is a function that maps vertices and ('id, 'v, 'e) node =
to a label and some edges to other vertices. *)
and ('v, 'e) node =
| Empty | Empty
| Node of vertex * 'v * ('e * vertex) Enum.t | Node of 'id * 'v * ('e * 'id) Enum.t
(** A single node of the graph, with outgoing edges *) (** A single node of the graph, with outgoing edges *)
and 'e path = (vertex * 'e * vertex) list and ('id, 'e) path = ('id * 'e * 'id) list
(** A reverse path (from the last element of the path to the first). *)
(** {2 Basic constructors} *)
(** It is difficult to provide generic combinators to build graphs. The problem
is that if one wants to "update" a node, it's still very hard to update
how other nodes re-generate the current node at the same time. *)
val empty : ('v, 'e) t
(** Empty graph *)
val singleton : vertex -> 'v -> ('v, 'e) t
(** Trivial graph, composed of one node *)
val from_enum : vertices:(vertex * 'v) Enum.t ->
edges:(vertex * 'e * vertex) Enum.t ->
('v, 'e) t
(** Concrete (eager) representation of a Graph *)
val from_fun : (vertex -> ('v * ('e * vertex) list) option) -> ('v, 'e) t
(** Convenient semi-lazy implementation of graphs *)
(** {2 Traversals} *)
(** {3 Full interface to traversals} *)
module Full : sig
type ('v, 'e) traverse_event =
| EnterVertex of vertex * 'v * int * 'e path (* unique ID, trail *)
| ExitVertex of vertex (* trail *)
| MeetEdge of vertex * 'e * vertex * edge_type (* edge *)
and edge_type =
| EdgeForward (* toward non explored vertex *)
| EdgeBackward (* toward the current trail *)
| EdgeTransverse (* toward a totally explored part of the graph *)
val bfs_full : ?id:int ref -> ?explored:unit H.t ->
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t
(** Lazy traversal in breadth first from a finite set of vertices *)
val dfs_full : ?id:int ref -> ?explored:unit H.t ->
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t
(** Lazy traversal in depth first from a finite set of vertices *)
end
(** The traversal functions assign a unique ID to every traversed node *)
val bfs : ?id:int ref -> ?explored:unit H.t ->
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t
(** Lazy traversal in breadth first *)
val dfs : ?id:int ref -> ?explored:unit H.t ->
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t
(** Lazy traversal in depth first *)
val enum : ('v, 'e) t -> vertex -> (vertex * 'v) Enum.t * (vertex * 'e * vertex) Enum.t
(** Convert to an enumeration. The traversal order is undefined. *)
val depth : (_, 'e) t -> vertex -> (int, 'e) t
(** Map vertices to their depth, ie their distance from the initial point *)
val min_path : ?distance:(vertex -> 'e -> vertex -> int) ->
('v, 'e) t -> vertex -> vertex ->
int * 'e path
(** Minimal path from the given Graph from the first vertex to
the second. It returns both the distance and the path *)
(** {2 Lazy transformations} *)
val union : ?combine:('v -> 'v -> 'v) -> ('v, 'e) t -> ('v, 'e) t -> ('v, 'e) t
(** Lazy union of the two graphs. If they have common vertices,
[combine] is used to combine the labels. By default, the second
label is dropped and only the first is kept *)
val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) ->
('v, 'e) t -> ('v2, 'e2) t
(** Map vertice and edge labels *)
val filter : ?vertices:(vertex -> 'v -> bool) ->
?edges:(vertex -> 'e -> vertex -> bool) ->
('v, 'e) t -> ('v, 'e) t
(** Filter out vertices and edges that do not satisfy the given
predicates. The default predicates always return true. *)
val limit_depth : max:int -> ('v, 'e) t -> ('v, 'e) t
(** Return the same graph, but with a bounded depth. Vertices whose
depth is too high will be replaced by Empty *)
module Infix : sig
val (++) : ('v, 'e) t -> ('v, 'e) t -> ('v, 'e) t
(** Union of graphs (alias for {! union}) *)
end
(** {2 Pretty printing in the DOT (graphviz) format *)
module Dot : sig
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
val pp_enum : name:string -> Format.formatter ->
(attribute list,attribute list) Full.traverse_event Enum.t ->
unit
val pp : name:string -> (attribute list, attribute list) t ->
Format.formatter ->
vertex Enum.t -> unit
(** Pretty print the given graph (starting from the given set of vertices)
to the channel in DOT format *)
end
end
(** {2 Module type for hashable types} *)
module type HASHABLE = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end
(** {2 Implementation of HASHABLE with physical equality and hash} *)
module PhysicalHash(X : sig type t end) : HASHABLE with type t = X.t
= struct
type t = X.t
let equal a b = a == b
let hash a = Hashtbl.hash a
end
(** {2 Build a graph} *)
module Make(X : HASHABLE) : S with type vertex = X.t = struct
(** {2 Type definitions} *)
type vertex = X.t
(** The concrete type of a vertex. Vertices are considered unique within
the graph. *)
module H = Hashtbl.Make(X)
type ('v, 'e) t = vertex -> ('v, 'e) node
(** Lazy graph structure. Vertices are annotated with values of type 'v,
and edges are of type 'e. A graph is a function that maps vertices
to a label and some edges to other vertices. *)
and ('v, 'e) node =
| Empty
| Node of vertex * 'v * ('e * vertex) Enum.t
(** A single node of the graph, with outgoing edges *)
and 'e path = (vertex * 'e * vertex) list
(** {2 Basic constructors} *) (** {2 Basic constructors} *)
let empty = let empty =
fun _ -> Empty { eq=(==);
hash=Hashtbl.hash;
force = (fun _ -> Empty);
}
let singleton v label = let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label =
fun v' -> let force v' =
if X.equal v v' then Node (v, label, Enum.empty) else Empty if eq v v' then Node (v, label, Enum.empty) else Empty in
{ force; eq; hash; }
let from_enum ~vertices ~edges = failwith "from_enum: not implemented" let make ?(eq=(=)) ?(hash=Hashtbl.hash) force =
{ eq; hash; force; }
let from_fun f = let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges =
fun v -> failwith "from_enum: not implemented"
let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f =
let force v =
match f v with match f v with
| None -> Empty | None -> Empty
| Some (l, edges) -> Node (v, l, Enum.of_list edges) | Some (l, edges) -> Node (v, l, Enum.of_list edges) in
{ eq; hash; force; }
(** {2 Polymorphic utils} *)
(** A set of vertices *)
type 'id set =
<
mem : 'id -> bool;
add : 'id -> unit;
iter : ('id -> unit) -> unit;
>
(** Make a set based on hashtables *)
let mk_hset (type id) ?(eq=(=)) ~hash =
let module H = Hashtbl.Make(struct type t = id let equal = eq let hash = hash end) in
let set = H.create 5 in
object
method mem x = H.mem set x
method add x = H.replace set x ()
method iter f = H.iter (fun x () -> f x) set
end
(** Make a set based on balanced trees *)
let mk_tset (type id) ~cmp =
let module S = Set.Make(struct type t = id let compare = cmp end) in
let set = ref S.empty in
object
method mem x = S.mem x !set
method add x = set := S.add x !set
method iter f = S.iter f !set
end
type ('id,'a) map =
<
mem : 'id -> bool;
get : 'id -> 'a; (* or Not_found *)
add : 'id -> 'a -> unit;
iter : ('id -> 'a -> unit) -> unit;
>
(** Make a map based on hashtables *)
let mk_hmap (type id) ?(eq=(=)) ~hash =
let module H = Hashtbl.Make(struct type t = id let equal = eq let hash = hash end) in
let m = H.create 5 in
object
method mem k = H.mem m k
method add k v = H.replace m k v
method get k = H.find m k
method iter f = H.iter f m
end
(** Make a map based on balanced trees *)
let mk_tmap (type id) ~cmp =
let module M = Map.Make(struct type t = id let compare = cmp end) in
let m = ref M.empty in
object
method mem k = M.mem k !m
method add k v = m := M.add k v !m
method get k = M.find k !m
method iter f = M.iter f !m
end
(** {2 Traversals} *) (** {2 Traversals} *)
(** {3 Full interface to traversals} *) (** {3 Full interface to traversals} *)
module Full = struct module Full = struct
type ('v, 'e) traverse_event = type ('id, 'v, 'e) traverse_event =
| EnterVertex of vertex * 'v * int * 'e path (* unique ID, trail *) | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *)
| ExitVertex of vertex (* trail *) | ExitVertex of 'id (* trail *)
| MeetEdge of vertex * 'e * vertex * edge_type (* edge *) | MeetEdge of 'id * 'e * 'id * edge_type (* edge *)
and edge_type = and edge_type =
| EdgeForward (* toward non explored vertex *) | EdgeForward (* toward non explored vertex *)
| EdgeBackward (* toward the current trail *) | EdgeBackward (* toward the current trail *)
| EdgeTransverse (* toward a totally explored part of the graph *) | EdgeTransverse (* toward a totally explored part of the graph *)
(* helper type *) (* helper type *)
type 'e todo_item = type ('id,'e) todo_item =
| FullEnter of vertex * 'e path | FullEnter of 'id * ('id, 'e) path
| FullExit of vertex | FullExit of 'id
| FullFollowEdge of 'e path | FullFollowEdge of ('id, 'e) path
(** Is [v] part of the [path]? *) (** Is [v] part of the [path]? *)
let rec mem_path path v = let rec mem_path ~eq path v =
match path with match path with
| (v',_,v'')::path' -> | (v',_,v'')::path' ->
(X.equal v v') || (X.equal v v'') || (mem_path path' v) (eq v v') || (eq v v'') || (mem_path ~eq path' v)
| [] -> false | [] -> false
let bfs_full ?(id=ref 0) ?(explored=H.create 5) graph vertices = let bfs_full ?(id=0) ?explored graph vertices =
let explored = match explored with
| Some e -> e
| None -> fun () -> mk_hset ~eq:graph.eq ~hash:graph.hash in
fun () -> fun () ->
let explored = explored () in
let id = ref id in
let q = Queue.create () in (* queue of nodes to explore *) let q = Queue.create () in (* queue of nodes to explore *)
Enum.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices; Enum.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices;
let rec next () = let rec next () =
if Queue.is_empty q then raise Enum.EOG else if Queue.is_empty q then raise Enum.EOG else
match Queue.pop q with match Queue.pop q with
| FullEnter (v', path) -> | FullEnter (v', path) ->
if H.mem explored v' then next () if explored#mem v' then next ()
else begin match graph v' with else begin match graph.force v' with
| Empty -> next () | Empty -> next ()
| Node (_, label, edges) -> | Node (_, label, edges) ->
H.add explored v' (); explored#add v';
(* explore neighbors *) (* explore neighbors *)
Enum.iter Enum.iter
(fun (e,v'') -> (fun (e,v'') ->
@ -269,8 +193,8 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
| FullFollowEdge [] -> assert false | FullFollowEdge [] -> assert false
| FullFollowEdge (((v'', e, v') :: path) as path') -> | FullFollowEdge (((v'', e, v') :: path) as path') ->
(* edge path .... v' --e--> v'' *) (* edge path .... v' --e--> v'' *)
if H.mem explored v'' if explored#mem v''
then if mem_path path v'' then if mem_path ~eq:graph.eq path v''
then MeetEdge (v'', e, v', EdgeBackward) then MeetEdge (v'', e, v', EdgeBackward)
else MeetEdge (v'', e, v', EdgeTransverse) else MeetEdge (v'', e, v', EdgeTransverse)
else begin else begin
@ -280,8 +204,13 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
end end
in next in next
let dfs_full ?(id=ref 0) ?(explored=H.create 5) graph vertices = let dfs_full ?(id=0) ?explored graph vertices =
let explored = match explored with
| Some e -> e
| None -> (fun () -> mk_hset ~eq:graph.eq ~hash:graph.hash) in
fun () -> fun () ->
let explored = explored () in
let id = ref id in
let s = Stack.create () in (* stack of nodes to explore *) let s = Stack.create () in (* stack of nodes to explore *)
Enum.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices; Enum.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices;
let rec next () = let rec next () =
@ -289,12 +218,12 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
match Stack.pop s with match Stack.pop s with
| FullExit v' -> ExitVertex v' | FullExit v' -> ExitVertex v'
| FullEnter (v', path) -> | FullEnter (v', path) ->
if H.mem explored v' then next () if explored#mem v' then next ()
(* explore the node now *) (* explore the node now *)
else begin match graph v' with else begin match graph.force v' with
| Empty -> next () | Empty -> next ()
| Node (_, label, edges) -> | Node (_, label, edges) ->
H.add explored v' (); explored#add v';
(* prepare to exit later *) (* prepare to exit later *)
Stack.push (FullExit v') s; Stack.push (FullExit v') s;
(* explore neighbors *) (* explore neighbors *)
@ -310,8 +239,8 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
| FullFollowEdge [] -> assert false | FullFollowEdge [] -> assert false
| FullFollowEdge (((v'', e, v') :: path) as path') -> | FullFollowEdge (((v'', e, v') :: path) as path') ->
(* edge path .... v' --e--> v'' *) (* edge path .... v' --e--> v'' *)
if H.mem explored v'' if explored#mem v''
then if mem_path path v'' then if mem_path ~eq:graph.eq path v''
then MeetEdge (v'', e, v', EdgeBackward) then MeetEdge (v'', e, v', EdgeBackward)
else MeetEdge (v'', e, v', EdgeTransverse) else MeetEdge (v'', e, v', EdgeTransverse)
else begin else begin
@ -343,37 +272,56 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
(** Minimal path from the given Graph from the first vertex to (** Minimal path from the given Graph from the first vertex to
the second. It returns both the distance and the path *) the second. It returns both the distance and the path *)
let min_path ?(distance=fun v1 e v2 -> 1) graph v1 v2 = let min_path ?(distance=fun v1 e v2 -> 1) ?explored graph v1 v2 =
failwith "not implemented" failwith "not implemented"
(** {2 Lazy transformations} *) (** {2 Lazy transformations} *)
let union ?(combine=fun x y -> x) g1 g2 = let union ?(combine=fun x y -> x) g1 g2 =
fun v -> let force v =
match g1 v, g2 v with match g1.force v, g2.force v with
| Empty, Empty -> Empty | Empty, Empty -> Empty
| ((Node _) as n), Empty -> n | ((Node _) as n), Empty -> n
| Empty, ((Node _) as n) -> n | Empty, ((Node _) as n) -> n
| Node (_, l1, e1), Node (_, l2, e2) -> | Node (_, l1, e1), Node (_, l2, e2) ->
Node (v, combine l1 l2, Enum.append e1 e2) Node (v, combine l1 l2, Enum.append e1 e2)
in { eq=g1.eq; hash=g1.hash; force; }
let map ~vertices ~edges g = let map ~vertices ~edges g =
fun vertex -> let force v =
match g vertex with match g.force v with
| Empty -> Empty | Empty -> Empty
| Node (_, l, edges_enum) -> | Node (_, l, edges_enum) ->
let edges_enum' = Enum.map (fun (e,v') -> (edges e), v') edges_enum in let edges_enum' = Enum.map (fun (e,v') -> (edges e), v') edges_enum in
Node (vertex, vertices l, edges_enum') Node (v, vertices l, edges_enum')
in { eq=g.eq; hash=g.hash; force; }
let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g = let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g =
fun vertex -> let force v =
match g vertex with match g.force v with
| Empty -> Empty | Empty -> Empty
| Node (_, l, edges_enum) when vertices vertex l -> | Node (_, l, edges_enum) when vertices v l ->
(* filter out edges *) (* filter out edges *)
let edges_enum' = Enum.filter (fun (e,v') -> edges vertex e v') edges_enum in let edges_enum' = Enum.filter (fun (e,v') -> edges v e v') edges_enum in
Node (vertex, l, edges_enum') Node (v, l, edges_enum')
| Node _ -> Empty (* filter out this vertex *) | Node _ -> Empty (* filter out this vertex *)
in { eq=g.eq; hash=g.hash; force; }
let product g1 g2 =
let force (v1,v2) =
match g1.force v1, g2.force v2 with
| Empty, _
| _, Empty -> Empty
| Node (_, l1, edges1), Node (_, l2, edges2) ->
(* product of edges *)
let edges = Enum.product edges1 edges2 in
let edges = Enum.map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in
Node ((v1,v2), (l1,l2), edges)
and eq (v1,v2) (v1',v2') =
g1.eq v1 v1' && g2.eq v2 v2'
and hash (v1,v2) = ((g1.hash v1) * 65599) + g2.hash v2
in
{ eq; hash; force; }
let limit_depth ~max g = let limit_depth ~max g =
(* TODO; this should be eager (compute depth by BFS) *) (* TODO; this should be eager (compute depth by BFS) *)
@ -394,7 +342,7 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
] (** Dot attribute *) ] (** Dot attribute *)
(** Print an enum of Full.traverse_event *) (** Print an enum of Full.traverse_event *)
let pp_enum ~name formatter events = let pp_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~name formatter events =
(* print an attribute *) (* print an attribute *)
let print_attribute formatter attr = let print_attribute formatter attr =
match attr with match attr with
@ -407,13 +355,13 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
(* map from vertices to integers *) (* map from vertices to integers *)
and get_id = and get_id =
let count = ref 0 in let count = ref 0 in
let m = H.create 5 in let m = mk_hmap ~eq ~hash in
fun vertex -> fun vertex ->
try H.find m vertex try m#get vertex
with Not_found -> with Not_found ->
let n = !count in let n = !count in
incr count; incr count;
H.replace m vertex n; m#add vertex n;
n n
in in
(* the unique name of a vertex *) (* the unique name of a vertex *)
@ -440,16 +388,5 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
let pp ~name graph formatter vertices = let pp ~name graph formatter vertices =
let enum = Full.bfs_full graph vertices in let enum = Full.bfs_full graph vertices in
pp_enum ~name formatter enum pp_enum ~eq:graph.eq ~hash:graph.hash ~name formatter enum
end end
end
(** {2 Build a graph based on physical equality} *)
module PhysicalMake(X : sig type t end) : S with type vertex = X.t
= Make(PhysicalHash(X))
module IntGraph = Make(struct
type t = int
let equal i j = i = j
let hash i = i
end)

163
lazyGraph.mli
View file

@ -23,30 +23,30 @@ 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 Lazy graph data structure} *) (** {1 Lazy graph polymorphic data structure} *)
module type S = sig
(** This module serves to represent directed graphs in a lazy fashion. Such (** This module serves to represent directed graphs in a lazy fashion. Such
a graph is always accessed from a given initial node (so only connected a graph is always accessed from a given initial node (so only connected
components can be represented by a single value of type ('v,'e) t). *) components can be represented by a single value of type ('v,'e) t).
The default equality considered here is [(=)], and the default hash
function is {! Hashtbl.hash}. *)
(** {2 Type definitions} *) (** {2 Type definitions} *)
type vertex type ('id, 'v, 'e) t = {
(** The concrete type of a vertex. Vertices are considered unique within eq : 'id -> 'id -> bool;
the graph. *) hash : 'id -> int;
force : 'id -> ('id, 'v, 'e) node;
module H : Hashtbl.S with type key = vertex } (** Lazy graph structure. Vertices, that have unique identifiers of type 'id,
are annotated with values of type 'v, and edges are annotated by type 'e.
type ('v, 'e) t = vertex -> ('v, 'e) node A graph is a function that maps each identifier to a label and some edges to
(** Lazy graph structure. Vertices are annotated with values of type 'v, other vertices, or to Empty if the identifier is not part of the graph. *)
and edges are of type 'e. A graph is a function that maps vertices and ('id, 'v, 'e) node =
to a label and some edges to other vertices. *)
and ('v, 'e) node =
| Empty | Empty
| Node of vertex * 'v * ('e * vertex) Enum.t | Node of 'id * 'v * ('e * 'id) Enum.t
(** A single node of the graph, with outgoing edges *) (** A single node of the graph, with outgoing edges *)
and 'e path = (vertex * 'e * vertex) list and ('id, 'e) path = ('id * 'e * 'id) list
(** A reverse path (from the last element of the path to the first). *) (** A reverse path (from the last element of the path to the first). *)
(** {2 Basic constructors} *) (** {2 Basic constructors} *)
@ -58,87 +58,130 @@ module type S = sig
underlying structure of the type vertex to a graph (for instance, underlying structure of the type vertex to a graph (for instance,
a concrete data structure, or an URL...). *) a concrete data structure, or an URL...). *)
val empty : ('v, 'e) t val empty : ('id, 'v, 'e) t
(** Empty graph *) (** Empty graph *)
val singleton : vertex -> 'v -> ('v, 'e) t val singleton : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
'id -> 'v -> ('id, 'v, 'e) t
(** Trivial graph, composed of one node *) (** Trivial graph, composed of one node *)
val from_enum : vertices:(vertex * 'v) Enum.t -> val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
edges:(vertex * 'e * vertex) Enum.t -> ('id -> ('id,'v,'e) node) -> ('id,'v,'e) t
('v, 'e) t (** Build a graph from the [force] function *)
val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
vertices:('id * 'v) Enum.t ->
edges:('id * 'e * 'id) Enum.t ->
('id, 'v, 'e) t
(** Concrete (eager) representation of a Graph (XXX not implemented)*) (** Concrete (eager) representation of a Graph (XXX not implemented)*)
val from_fun : (vertex -> ('v * ('e * vertex) list) option) -> ('v, 'e) t val from_fun : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
('id -> ('v * ('e * 'id) list) option) -> ('id, 'v, 'e) t
(** Convenient semi-lazy implementation of graphs *) (** Convenient semi-lazy implementation of graphs *)
(** {2 Polymorphic utils} *)
(** A set of vertices *)
type 'id set =
<
mem : 'id -> bool;
add : 'id -> unit;
iter : ('id -> unit) -> unit;
>
val mk_hset : ?eq:('id -> 'id -> bool) -> hash:('id -> int) -> 'id set
(** Make a set based on hashtables *)
val mk_tset : cmp:('id -> 'id -> int) -> 'id set
(** Make a set based on balanced trees *)
type ('id,'a) map =
<
mem : 'id -> bool;
get : 'id -> 'a; (* or Not_found *)
add : 'id -> 'a -> unit;
iter : ('id -> 'a -> unit) -> unit;
>
val mk_hmap : ?eq:('id -> 'id -> bool) -> hash:('id -> int) -> ('id,'a) map
val mk_tmap : cmp:('id -> 'id -> int) -> ('id,'a) map
(** {2 Traversals} *) (** {2 Traversals} *)
(** {3 Full interface to traversals} *) (** {3 Full interface to traversals} *)
module Full : sig module Full : sig
type ('v, 'e) traverse_event = type ('id, 'v, 'e) traverse_event =
| EnterVertex of vertex * 'v * int * 'e path (* unique ID, trail *) | EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *)
| ExitVertex of vertex (* trail *) | ExitVertex of 'id (* trail *)
| MeetEdge of vertex * 'e * vertex * edge_type (* edge *) | MeetEdge of 'id * 'e * 'id * edge_type (* edge *)
and edge_type = and edge_type =
| EdgeForward (* toward non explored vertex *) | EdgeForward (* toward non explored vertex *)
| EdgeBackward (* toward the current trail *) | EdgeBackward (* toward the current trail *)
| EdgeTransverse (* toward a totally explored part of the graph *) | EdgeTransverse (* toward a totally explored part of the graph *)
val bfs_full : ?id:int ref -> ?explored:unit H.t -> val bfs_full : ?id:int -> ?explored:(unit -> 'id set) ->
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t ('id, 'v, 'e) t -> 'id Enum.t ->
('id, 'v, 'e) traverse_event Enum.t
(** Lazy traversal in breadth first from a finite set of vertices *) (** Lazy traversal in breadth first from a finite set of vertices *)
val dfs_full : ?id:int ref -> ?explored:unit H.t -> val dfs_full : ?id:int -> ?explored:(unit -> 'id set) ->
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t ('id, 'v, 'e) t -> 'id Enum.t ->
('id, 'v, 'e) traverse_event Enum.t
(** Lazy traversal in depth first from a finite set of vertices *) (** Lazy traversal in depth first from a finite set of vertices *)
end end
(** The traversal functions assign a unique ID to every traversed node *) (** The traversal functions assign a unique ID to every traversed node *)
val bfs : ?id:int ref -> ?explored:unit H.t -> val bfs : ?id:int -> ?explored:(unit -> 'id set) ->
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Enum.t
(** Lazy traversal in breadth first *) (** Lazy traversal in breadth first *)
val dfs : ?id:int ref -> ?explored:unit H.t -> val dfs : ?id:int -> ?explored:(unit -> 'id set) ->
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Enum.t
(** Lazy traversal in depth first *) (** Lazy traversal in depth first *)
val enum : ('v, 'e) t -> vertex -> (vertex * 'v) Enum.t * (vertex * 'e * vertex) Enum.t val enum : ('id, 'v, 'e) t -> 'id -> ('id * 'v) Enum.t * ('id * 'e * 'id) Enum.t
(** Convert to an enumeration. The traversal order is undefined. *) (** Convert to an enumeration. The traversal order is undefined. *)
val depth : (_, 'e) t -> vertex -> (int, 'e) t val depth : ('id, _, 'e) t -> 'id -> ('id, int, 'e) t
(** Map vertices to their depth, ie their distance from the initial point *) (** Map vertices to their depth, ie their distance from the initial point *)
val min_path : ?distance:(vertex -> 'e -> vertex -> int) -> val min_path : ?distance:('id -> 'e -> 'id -> int) ->
('v, 'e) t -> vertex -> vertex -> ?explored:(unit -> ('id, int * ('id,'e) path) map) ->
int * 'e path ('id, 'v, 'e) t -> 'id -> 'id ->
int * ('id, 'e) path
(** Minimal path from the given Graph from the first vertex to (** Minimal path from the given Graph from the first vertex to
the second. It returns both the distance and the path *) the second. It returns both the distance and the path *)
(** {2 Lazy transformations} *) (** {2 Lazy transformations} *)
val union : ?combine:('v -> 'v -> 'v) -> ('v, 'e) t -> ('v, 'e) t -> ('v, 'e) t val union : ?combine:('v -> 'v -> 'v) ->
('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t
(** Lazy union of the two graphs. If they have common vertices, (** Lazy union of the two graphs. If they have common vertices,
[combine] is used to combine the labels. By default, the second [combine] is used to combine the labels. By default, the second
label is dropped and only the first is kept *) label is dropped and only the first is kept *)
val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) -> val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) ->
('v, 'e) t -> ('v2, 'e2) t ('id, 'v, 'e) t -> ('id, 'v2, 'e2) t
(** Map vertice and edge labels *) (** Map vertice and edge labels *)
val filter : ?vertices:(vertex -> 'v -> bool) -> val filter : ?vertices:('id -> 'v -> bool) ->
?edges:(vertex -> 'e -> vertex -> bool) -> ?edges:('id -> 'e -> 'id -> bool) ->
('v, 'e) t -> ('v, 'e) t ('id, 'v, 'e) t -> ('id, 'v, 'e) t
(** Filter out vertices and edges that do not satisfy the given (** Filter out vertices and edges that do not satisfy the given
predicates. The default predicates always return true. *) predicates. The default predicates always return true. *)
val limit_depth : max:int -> ('v, 'e) t -> ('v, 'e) t val product : ('id1, 'v1, 'e1) t -> ('id2, 'v2, 'e2) t ->
('id1 * 'id2, 'v1 * 'v2, 'e1 * 'e2) t
(** Cartesian product of the two graphs *)
val limit_depth : max:int -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t
(** Return the same graph, but with a bounded depth. Vertices whose (** Return the same graph, but with a bounded depth. Vertices whose
depth is too high will be replaced by Empty *) depth is too high will be replaced by Empty *)
module Infix : sig module Infix : sig
val (++) : ('v, 'e) t -> ('v, 'e) t -> ('v, 'e) t val (++) : ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t
(** Union of graphs (alias for {! union}) *) (** Union of graphs (alias for {! union}) *)
end end
@ -153,32 +196,14 @@ module type S = sig
| `Other of string * string | `Other of string * string
] (** Dot attribute *) ] (** Dot attribute *)
val pp_enum : name:string -> Format.formatter -> val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
(attribute list,attribute list) Full.traverse_event Enum.t -> name:string -> Format.formatter ->
('id,attribute list,attribute list) Full.traverse_event Enum.t ->
unit unit
val pp : name:string -> (attribute list, attribute list) t -> val pp : name:string -> ('id, attribute list, attribute list) t ->
Format.formatter -> Format.formatter ->
vertex Enum.t -> unit 'id Enum.t -> unit
(** Pretty print the given graph (starting from the given set of vertices) (** Pretty print the given graph (starting from the given set of vertices)
to the channel in DOT format *) to the channel in DOT format *)
end end
end
(** {2 Module type for hashable types} *)
module type HASHABLE = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end
(** {2 Implementation of HASHABLE with physical equality and hash} *)
module PhysicalHash(X : sig type t end) : HASHABLE with type t = X.t
(** {2 Build a graph} *)
module Make(X : HASHABLE) : S with type vertex = X.t
(** {2 Build a graph based on physical equality} *)
module PhysicalMake(X : sig type t end) : S with type vertex = X.t
module IntGraph : S with type vertex = int