simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 03:05:28 -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

25
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 =
if Obj.is_block x let force x =
then if Obj.is_block x
let children = Enum.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in then
G.Node (x, Obj.tag x, children) let children = Enum.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in
else LazyGraph.Node (x, Obj.tag x, children)
G.Node (x, Obj.obj x, Enum.empty) else
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

743
lazyGraph.ml
View file

@ -25,431 +25,368 @@ 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;
} (** 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.
A graph is a function that maps each identifier to a label and some edges to
other vertices, or to Empty if the identifier is not part of the graph. *)
and ('id, 'v, 'e) node =
| Empty
| Node of 'id * 'v * ('e * 'id) Enum.t
(** A single node of the graph, with outgoing edges *)
and ('id, 'e) path = ('id * 'e * 'id) list
(** A reverse path (from the last element of the path to the first). *)
module H : Hashtbl.S with type key = vertex (** {2 Basic constructors} *)
type ('v, 'e) t = vertex -> ('v, 'e) node let empty =
(** Lazy graph structure. Vertices are annotated with values of type 'v, { eq=(==);
and edges are of type 'e. A graph is a function that maps vertices hash=Hashtbl.hash;
to a label and some edges to other vertices. *) force = (fun _ -> Empty);
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} *) let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label =
let force v' =
if eq v v' then Node (v, label, Enum.empty) else Empty in
{ force; eq; hash; }
(** It is difficult to provide generic combinators to build graphs. The problem let make ?(eq=(=)) ?(hash=Hashtbl.hash) force =
is that if one wants to "update" a node, it's still very hard to update { eq; hash; force; }
how other nodes re-generate the current node at the same time. *)
val empty : ('v, 'e) t let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges =
(** Empty graph *) failwith "from_enum: not implemented"
val singleton : vertex -> 'v -> ('v, 'e) t let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f =
(** Trivial graph, composed of one node *) let force v =
match f v with
| None -> Empty
| Some (l, edges) -> Node (v, l, Enum.of_list edges) in
{ eq; hash; force; }
val from_enum : vertices:(vertex * 'v) Enum.t -> (** {2 Polymorphic utils} *)
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 (** A set of vertices *)
(** Convenient semi-lazy implementation of graphs *) type 'id set =
<
mem : 'id -> bool;
add : 'id -> unit;
iter : ('id -> unit) -> unit;
>
(** {2 Traversals} *) (** Make a set based on hashtables *)
let mk_hset (type id) ?(eq=(=)) ~hash =
(** {3 Full interface to traversals} *) let module H = Hashtbl.Make(struct type t = id let equal = eq let hash = hash end) in
module Full : sig let set = H.create 5 in
type ('v, 'e) traverse_event = object
| EnterVertex of vertex * 'v * int * 'e path (* unique ID, trail *) method mem x = H.mem set x
| ExitVertex of vertex (* trail *) method add x = H.replace set x ()
| MeetEdge of vertex * 'e * vertex * edge_type (* edge *) method iter f = H.iter (fun x () -> f x) set
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 end
(** The traversal functions assign a unique ID to every traversed node *) (** Make a set based on balanced trees *)
let mk_tset (type id) ~cmp =
val bfs : ?id:int ref -> ?explored:unit H.t -> let module S = Set.Make(struct type t = id let compare = cmp end) in
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t let set = ref S.empty in
(** Lazy traversal in breadth first *) object
method mem x = S.mem x !set
val dfs : ?id:int ref -> ?explored:unit H.t -> method add x = set := S.add x !set
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t method iter f = S.iter f !set
(** 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 end
(** {2 Pretty printing in the DOT (graphviz) format *) type ('id,'a) map =
module Dot : sig <
type attribute = [ mem : 'id -> bool;
| `Color of string get : 'id -> 'a; (* or Not_found *)
| `Shape of string add : 'id -> 'a -> unit;
| `Weight of int iter : ('id -> 'a -> unit) -> unit;
| `Style of string >
| `Label of string
| `Other of string * string
] (** Dot attribute *)
val pp_enum : name:string -> Format.formatter -> (** Make a map based on hashtables *)
(attribute list,attribute list) Full.traverse_event Enum.t -> let mk_hmap (type id) ?(eq=(=)) ~hash =
unit let module H = Hashtbl.Make(struct type t = id let equal = eq let hash = hash end) in
let m = H.create 5 in
val pp : name:string -> (attribute list, attribute list) t -> object
Format.formatter -> method mem k = H.mem m k
vertex Enum.t -> unit method add k v = H.replace m k v
(** Pretty print the given graph (starting from the given set of vertices) method get k = H.find m k
to the channel in DOT format *) method iter f = H.iter f m
end 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} *)
(** {3 Full interface to traversals} *)
module Full = struct
type ('id, 'v, 'e) traverse_event =
| EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *)
| ExitVertex of 'id (* trail *)
| MeetEdge of 'id * 'e * 'id * 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 *)
(* helper type *)
type ('id,'e) todo_item =
| FullEnter of 'id * ('id, 'e) path
| FullExit of 'id
| FullFollowEdge of ('id, 'e) path
(** Is [v] part of the [path]? *)
let rec mem_path ~eq path v =
match path with
| (v',_,v'')::path' ->
(eq v v') || (eq v v'') || (mem_path ~eq path' v)
| [] -> false
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 () ->
let explored = explored () in
let id = ref id in
let q = Queue.create () in (* queue of nodes to explore *)
Enum.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices;
let rec next () =
if Queue.is_empty q then raise Enum.EOG else
match Queue.pop q with
| FullEnter (v', path) ->
if explored#mem v' then next ()
else begin match graph.force v' with
| Empty -> next ()
| Node (_, label, edges) ->
explored#add v';
(* explore neighbors *)
Enum.iter
(fun (e,v'') ->
let path' = (v'',e,v') :: path in
Queue.push (FullFollowEdge path') q)
edges;
(* exit node afterward *)
Queue.push (FullExit v') q;
(* return this vertex *)
let i = !id in
incr id;
EnterVertex (v', label, i, path)
end
| FullExit v' -> ExitVertex v'
| FullFollowEdge [] -> assert false
| FullFollowEdge (((v'', e, v') :: path) as path') ->
(* edge path .... v' --e--> v'' *)
if explored#mem v''
then if mem_path ~eq:graph.eq path v''
then MeetEdge (v'', e, v', EdgeBackward)
else MeetEdge (v'', e, v', EdgeTransverse)
else begin
(* explore this edge *)
Queue.push (FullEnter (v'', path')) q;
MeetEdge (v'', e, v', EdgeForward)
end
in next
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 () ->
let explored = explored () in
let id = ref id in
let s = Stack.create () in (* stack of nodes to explore *)
Enum.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices;
let rec next () =
if Stack.is_empty s then raise Enum.EOG else
match Stack.pop s with
| FullExit v' -> ExitVertex v'
| FullEnter (v', path) ->
if explored#mem v' then next ()
(* explore the node now *)
else begin match graph.force v' with
| Empty -> next ()
| Node (_, label, edges) ->
explored#add v';
(* prepare to exit later *)
Stack.push (FullExit v') s;
(* explore neighbors *)
Enum.iter
(fun (e,v'') ->
Stack.push (FullFollowEdge ((v'', e, v') :: path)) s)
edges;
(* return this vertex *)
let i = !id in
incr id;
EnterVertex (v', label, i, path)
end
| FullFollowEdge [] -> assert false
| FullFollowEdge (((v'', e, v') :: path) as path') ->
(* edge path .... v' --e--> v'' *)
if explored#mem v''
then if mem_path ~eq:graph.eq path v''
then MeetEdge (v'', e, v', EdgeBackward)
else MeetEdge (v'', e, v', EdgeTransverse)
else begin
(* explore this edge *)
Stack.push (FullEnter (v'', path')) s;
MeetEdge (v'', e, v', EdgeForward)
end
in next
end end
(** {2 Module type for hashable types} *) let bfs ?id ?explored graph v =
module type HASHABLE = sig Enum.filterMap
type t (function
val equal : t -> t -> bool | Full.EnterVertex (v, l, i, _) -> Some (v, l, i)
val hash : t -> int | _ -> None)
(Full.bfs_full ?id ?explored graph (Enum.singleton v))
let dfs ?id ?explored graph v =
Enum.filterMap
(function
| Full.EnterVertex (v, l, i, _) -> Some (v, l, i)
| _ -> None)
(Full.dfs_full ?id ?explored graph (Enum.singleton v))
let enum graph v = (Enum.empty, Enum.empty) (* TODO *)
let depth graph v =
failwith "not implemented" (* TODO *)
(** Minimal path from the given Graph from the first vertex to
the second. It returns both the distance and the path *)
let min_path ?(distance=fun v1 e v2 -> 1) ?explored graph v1 v2 =
failwith "not implemented"
(** {2 Lazy transformations} *)
let union ?(combine=fun x y -> x) g1 g2 =
let force v =
match g1.force v, g2.force v with
| Empty, Empty -> Empty
| ((Node _) as n), Empty -> n
| Empty, ((Node _) as n) -> n
| Node (_, l1, e1), Node (_, l2, e2) ->
Node (v, combine l1 l2, Enum.append e1 e2)
in { eq=g1.eq; hash=g1.hash; force; }
let map ~vertices ~edges g =
let force v =
match g.force v with
| Empty -> Empty
| Node (_, l, edges_enum) ->
let edges_enum' = Enum.map (fun (e,v') -> (edges e), v') edges_enum in
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 force v =
match g.force v with
| Empty -> Empty
| Node (_, l, edges_enum) when vertices v l ->
(* filter out edges *)
let edges_enum' = Enum.filter (fun (e,v') -> edges v e v') edges_enum in
Node (v, l, edges_enum')
| 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 =
(* TODO; this should be eager (compute depth by BFS) *)
failwith "not implemented"
module Infix = struct
let (++) g1 g2 = union ?combine:None g1 g2
end end
(** {2 Implementation of HASHABLE with physical equality and hash} *) module Dot = struct
module PhysicalHash(X : sig type t end) : HASHABLE with type t = X.t type attribute = [
= struct | `Color of string
type t = X.t | `Shape of string
let equal a b = a == b | `Weight of int
let hash a = Hashtbl.hash a | `Style of string
end | `Label of string
| `Other of string * string
] (** Dot attribute *)
(** {2 Build a graph} *) (** Print an enum of Full.traverse_event *)
module Make(X : HASHABLE) : S with type vertex = X.t = struct let pp_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~name formatter events =
(** {2 Type definitions} *) (* print an attribute *)
let print_attribute formatter attr =
type vertex = X.t match attr with
(** The concrete type of a vertex. Vertices are considered unique within | `Color c -> Format.fprintf formatter "color=%s" c
the graph. *) | `Shape s -> Format.fprintf formatter "shape=%s" s
| `Weight w -> Format.fprintf formatter "weight=%d" w
module H = Hashtbl.Make(X) | `Style s -> Format.fprintf formatter "style=%s" s
| `Label l -> Format.fprintf formatter "label=\"%s\"" l
type ('v, 'e) t = vertex -> ('v, 'e) node | `Other (name, value) -> Format.fprintf formatter "%s=\"%s\"" name value
(** Lazy graph structure. Vertices are annotated with values of type 'v, (* map from vertices to integers *)
and edges are of type 'e. A graph is a function that maps vertices and get_id =
to a label and some edges to other vertices. *) let count = ref 0 in
and ('v, 'e) node = let m = mk_hmap ~eq ~hash in
| Empty fun vertex ->
| Node of vertex * 'v * ('e * vertex) Enum.t try m#get vertex
(** A single node of the graph, with outgoing edges *) with Not_found ->
and 'e path = (vertex * 'e * vertex) list let n = !count in
incr count;
(** {2 Basic constructors} *) m#add vertex n;
n
let empty = in
fun _ -> Empty (* the unique name of a vertex *)
let pp_vertex formatter v =
let singleton v label = Format.fprintf formatter "vertex_%d" (get_id v) in
fun v' -> (* print preamble *)
if X.equal v v' then Node (v, label, Enum.empty) else Empty Format.fprintf formatter "@[<v2>digraph %s {@;" name;
(* traverse *)
let from_enum ~vertices ~edges = failwith "from_enum: not implemented" Enum.iter
let from_fun f =
fun v ->
match f v with
| None -> Empty
| Some (l, edges) -> Node (v, l, Enum.of_list edges)
(** {2 Traversals} *)
(** {3 Full interface to traversals} *)
module Full = struct
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 *)
(* helper type *)
type 'e todo_item =
| FullEnter of vertex * 'e path
| FullExit of vertex
| FullFollowEdge of 'e path
(** Is [v] part of the [path]? *)
let rec mem_path path v =
match path with
| (v',_,v'')::path' ->
(X.equal v v') || (X.equal v v'') || (mem_path path' v)
| [] -> false
let bfs_full ?(id=ref 0) ?(explored=H.create 5) graph vertices =
fun () ->
let q = Queue.create () in (* queue of nodes to explore *)
Enum.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices;
let rec next () =
if Queue.is_empty q then raise Enum.EOG else
match Queue.pop q with
| FullEnter (v', path) ->
if H.mem explored v' then next ()
else begin match graph v' with
| Empty -> next ()
| Node (_, label, edges) ->
H.add explored v' ();
(* explore neighbors *)
Enum.iter
(fun (e,v'') ->
let path' = (v'',e,v') :: path in
Queue.push (FullFollowEdge path') q)
edges;
(* exit node afterward *)
Queue.push (FullExit v') q;
(* return this vertex *)
let i = !id in
incr id;
EnterVertex (v', label, i, path)
end
| FullExit v' -> ExitVertex v'
| FullFollowEdge [] -> assert false
| FullFollowEdge (((v'', e, v') :: path) as path') ->
(* edge path .... v' --e--> v'' *)
if H.mem explored v''
then if mem_path path v''
then MeetEdge (v'', e, v', EdgeBackward)
else MeetEdge (v'', e, v', EdgeTransverse)
else begin
(* explore this edge *)
Queue.push (FullEnter (v'', path')) q;
MeetEdge (v'', e, v', EdgeForward)
end
in next
let dfs_full ?(id=ref 0) ?(explored=H.create 5) graph vertices =
fun () ->
let s = Stack.create () in (* stack of nodes to explore *)
Enum.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices;
let rec next () =
if Stack.is_empty s then raise Enum.EOG else
match Stack.pop s with
| FullExit v' -> ExitVertex v'
| FullEnter (v', path) ->
if H.mem explored v' then next ()
(* explore the node now *)
else begin match graph v' with
| Empty -> next ()
| Node (_, label, edges) ->
H.add explored v' ();
(* prepare to exit later *)
Stack.push (FullExit v') s;
(* explore neighbors *)
Enum.iter
(fun (e,v'') ->
Stack.push (FullFollowEdge ((v'', e, v') :: path)) s)
edges;
(* return this vertex *)
let i = !id in
incr id;
EnterVertex (v', label, i, path)
end
| FullFollowEdge [] -> assert false
| FullFollowEdge (((v'', e, v') :: path) as path') ->
(* edge path .... v' --e--> v'' *)
if H.mem explored v''
then if mem_path path v''
then MeetEdge (v'', e, v', EdgeBackward)
else MeetEdge (v'', e, v', EdgeTransverse)
else begin
(* explore this edge *)
Stack.push (FullEnter (v'', path')) s;
MeetEdge (v'', e, v', EdgeForward)
end
in next
end
let bfs ?id ?explored graph v =
Enum.filterMap
(function (function
| Full.EnterVertex (v, l, i, _) -> Some (v, l, i) | Full.EnterVertex (v, attrs, _, _) ->
| _ -> None) Format.fprintf formatter " @[<h>%a [%a];@]@." pp_vertex v
(Full.bfs_full ?id ?explored graph (Enum.singleton v)) (Enum.pp ~sep:"," print_attribute) (Enum.of_list attrs)
| Full.ExitVertex _ -> ()
| Full.MeetEdge (v2, attrs, v1, _) ->
Format.fprintf formatter " @[<h>%a -> %a [%a];@]@."
pp_vertex v1 pp_vertex v2
(Enum.pp ~sep:"," print_attribute)
(Enum.of_list attrs))
events;
(* close *)
Format.fprintf formatter "}@]@;@?";
()
let dfs ?id ?explored graph v = let pp ~name graph formatter vertices =
Enum.filterMap let enum = Full.bfs_full graph vertices in
(function pp_enum ~eq:graph.eq ~hash:graph.hash ~name formatter enum
| Full.EnterVertex (v, l, i, _) -> Some (v, l, i)
| _ -> None)
(Full.dfs_full ?id ?explored graph (Enum.singleton v))
let enum graph v = (Enum.empty, Enum.empty) (* TODO *)
let depth graph v =
failwith "not implemented" (* TODO *)
(** Minimal path from the given Graph from the first vertex to
the second. It returns both the distance and the path *)
let min_path ?(distance=fun v1 e v2 -> 1) graph v1 v2 =
failwith "not implemented"
(** {2 Lazy transformations} *)
let union ?(combine=fun x y -> x) g1 g2 =
fun v ->
match g1 v, g2 v with
| Empty, Empty -> Empty
| ((Node _) as n), Empty -> n
| Empty, ((Node _) as n) -> n
| Node (_, l1, e1), Node (_, l2, e2) ->
Node (v, combine l1 l2, Enum.append e1 e2)
let map ~vertices ~edges g =
fun vertex ->
match g vertex with
| Empty -> Empty
| Node (_, l, edges_enum) ->
let edges_enum' = Enum.map (fun (e,v') -> (edges e), v') edges_enum in
Node (vertex, vertices l, edges_enum')
let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g =
fun vertex ->
match g vertex with
| Empty -> Empty
| Node (_, l, edges_enum) when vertices vertex l ->
(* filter out edges *)
let edges_enum' = Enum.filter (fun (e,v') -> edges vertex e v') edges_enum in
Node (vertex, l, edges_enum')
| Node _ -> Empty (* filter out this vertex *)
let limit_depth ~max g =
(* TODO; this should be eager (compute depth by BFS) *)
failwith "not implemented"
module Infix = struct
let (++) g1 g2 = union ?combine:None g1 g2
end
module Dot = struct
type attribute = [
| `Color of string
| `Shape of string
| `Weight of int
| `Style of string
| `Label of string
| `Other of string * string
] (** Dot attribute *)
(** Print an enum of Full.traverse_event *)
let pp_enum ~name formatter events =
(* print an attribute *)
let 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
(* map from vertices to integers *)
and get_id =
let count = ref 0 in
let m = H.create 5 in
fun vertex ->
try H.find m vertex
with Not_found ->
let n = !count in
incr count;
H.replace m vertex n;
n
in
(* the unique 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;
(* traverse *)
Enum.iter
(function
| Full.EnterVertex (v, attrs, _, _) ->
Format.fprintf formatter " @[<h>%a [%a];@]@." pp_vertex v
(Enum.pp ~sep:"," print_attribute) (Enum.of_list attrs)
| Full.ExitVertex _ -> ()
| Full.MeetEdge (v2, attrs, v1, _) ->
Format.fprintf formatter " @[<h>%a -> %a [%a];@]@."
pp_vertex v1 pp_vertex v2
(Enum.pp ~sep:"," print_attribute)
(Enum.of_list attrs))
events;
(* close *)
Format.fprintf formatter "}@]@;@?";
()
let pp ~name graph formatter vertices =
let enum = Full.bfs_full graph vertices in
pp_enum ~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)

289
lazyGraph.mli
View file

@ -23,162 +23,187 @@ 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;
} (** 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.
A graph is a function that maps each identifier to a label and some edges to
other vertices, or to Empty if the identifier is not part of the graph. *)
and ('id, 'v, 'e) node =
| Empty
| Node of 'id * 'v * ('e * 'id) Enum.t
(** A single node of the graph, with outgoing edges *)
and ('id, 'e) path = ('id * 'e * 'id) list
(** A reverse path (from the last element of the path to the first). *)
module H : Hashtbl.S with type key = vertex (** {2 Basic constructors} *)
type ('v, 'e) t = vertex -> ('v, 'e) node (** It is difficult to provide generic combinators to build graphs. The problem
(** Lazy graph structure. Vertices are annotated with values of type 'v, is that if one wants to "update" a node, it's still very hard to update
and edges are of type 'e. A graph is a function that maps vertices how other nodes re-generate the current node at the same time.
to a label and some edges to other vertices. *) The best way to do it is to build one function that maps the
and ('v, 'e) node = underlying structure of the type vertex to a graph (for instance,
| Empty a concrete data structure, or an URL...). *)
| Node of vertex * 'v * ('e * vertex) Enum.t
(** A single node of the graph, with outgoing edges *)
and 'e path = (vertex * 'e * vertex) list
(** A reverse path (from the last element of the path to the first). *)
(** {2 Basic constructors} *) val empty : ('id, 'v, 'e) t
(** Empty graph *)
(** It is difficult to provide generic combinators to build graphs. The problem val singleton : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
is that if one wants to "update" a node, it's still very hard to update 'id -> 'v -> ('id, 'v, 'e) t
how other nodes re-generate the current node at the same time. (** Trivial graph, composed of one node *)
The best way to do it is to build one function that maps the
underlying structure of the type vertex to a graph (for instance,
a concrete data structure, or an URL...). *)
val empty : ('v, 'e) t val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
(** Empty graph *) ('id -> ('id,'v,'e) node) -> ('id,'v,'e) t
(** Build a graph from the [force] function *)
val singleton : vertex -> 'v -> ('v, 'e) t val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
(** Trivial graph, composed of one node *) vertices:('id * 'v) Enum.t ->
edges:('id * 'e * 'id) Enum.t ->
('id, 'v, 'e) t
(** Concrete (eager) representation of a Graph (XXX not implemented)*)
val from_enum : vertices:(vertex * 'v) Enum.t -> val from_fun : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
edges:(vertex * 'e * vertex) Enum.t -> ('id -> ('v * ('e * 'id) list) option) -> ('id, 'v, 'e) t
('v, 'e) t (** Convenient semi-lazy implementation of graphs *)
(** Concrete (eager) representation of a Graph (XXX not implemented)*)
val from_fun : (vertex -> ('v * ('e * vertex) list) option) -> ('v, 'e) t (** {2 Polymorphic utils} *)
(** Convenient semi-lazy implementation of graphs *)
(** {2 Traversals} *) (** A set of vertices *)
type 'id set =
<
mem : 'id -> bool;
add : 'id -> unit;
iter : ('id -> unit) -> unit;
>
(** {3 Full interface to traversals} *) val mk_hset : ?eq:('id -> 'id -> bool) -> hash:('id -> int) -> 'id set
module Full : sig (** Make a set based on hashtables *)
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 -> val mk_tset : cmp:('id -> 'id -> int) -> 'id set
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t (** Make a set based on balanced trees *)
(** Lazy traversal in breadth first from a finite set of vertices *)
val dfs_full : ?id:int ref -> ?explored:unit H.t -> type ('id,'a) map =
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t <
(** Lazy traversal in depth first from a finite set of vertices *) mem : 'id -> bool;
end get : 'id -> 'a; (* or Not_found *)
add : 'id -> 'a -> unit;
iter : ('id -> 'a -> unit) -> unit;
>
(** The traversal functions assign a unique ID to every traversed node *) val mk_hmap : ?eq:('id -> 'id -> bool) -> hash:('id -> int) -> ('id,'a) map
val bfs : ?id:int ref -> ?explored:unit H.t -> val mk_tmap : cmp:('id -> 'id -> int) -> ('id,'a) map
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t
(** Lazy traversal in breadth first *)
val dfs : ?id:int ref -> ?explored:unit H.t -> (** {2 Traversals} *)
('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 (** {3 Full interface to traversals} *)
(** Convert to an enumeration. The traversal order is undefined. *) module Full : sig
type ('id, 'v, 'e) traverse_event =
| EnterVertex of 'id * 'v * int * ('id, 'e) path (* unique ID, trail *)
| ExitVertex of 'id (* trail *)
| MeetEdge of 'id * 'e * 'id * 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 depth : (_, 'e) t -> vertex -> (int, 'e) t val bfs_full : ?id:int -> ?explored:(unit -> 'id set) ->
(** Map vertices to their depth, ie their distance from the initial point *) ('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 *)
val min_path : ?distance:(vertex -> 'e -> vertex -> int) -> val dfs_full : ?id:int -> ?explored:(unit -> 'id set) ->
('v, 'e) t -> vertex -> vertex -> ('id, 'v, 'e) t -> 'id Enum.t ->
int * 'e path ('id, 'v, 'e) traverse_event Enum.t
(** Minimal path from the given Graph from the first vertex to (** Lazy traversal in depth first from a finite set of vertices *)
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 end
(** {2 Module type for hashable types} *) (** The traversal functions assign a unique ID to every traversed node *)
module type HASHABLE = sig
type t val bfs : ?id:int -> ?explored:(unit -> 'id set) ->
val equal : t -> t -> bool ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Enum.t
val hash : t -> int (** Lazy traversal in breadth first *)
val dfs : ?id:int -> ?explored:(unit -> 'id set) ->
('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Enum.t
(** Lazy traversal in depth first *)
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. *)
val depth : ('id, _, 'e) t -> 'id -> ('id, int, 'e) t
(** Map vertices to their depth, ie their distance from the initial point *)
val min_path : ?distance:('id -> 'e -> 'id -> int) ->
?explored:(unit -> ('id, int * ('id,'e) path) map) ->
('id, 'v, 'e) t -> 'id -> 'id ->
int * ('id, '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) ->
('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, '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) ->
('id, 'v, 'e) t -> ('id, 'v2, 'e2) t
(** Map vertice and edge labels *)
val filter : ?vertices:('id -> 'v -> bool) ->
?edges:('id -> 'e -> 'id -> bool) ->
('id, 'v, 'e) t -> ('id, 'v, 'e) t
(** Filter out vertices and edges that do not satisfy the given
predicates. The default predicates always return true. *)
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
depth is too high will be replaced by Empty *)
module Infix : sig
val (++) : ('id, 'v, 'e) t -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t
(** Union of graphs (alias for {! union}) *)
end end
(** {2 Implementation of HASHABLE with physical equality and hash} *) (** {2 Pretty printing in the DOT (graphviz) format *)
module PhysicalHash(X : sig type t end) : HASHABLE with type t = X.t 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 *)
(** {2 Build a graph} *) val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) ->
module Make(X : HASHABLE) : S with type vertex = X.t name:string -> Format.formatter ->
('id,attribute list,attribute list) Full.traverse_event Enum.t ->
unit
(** {2 Build a graph based on physical equality} *) val pp : name:string -> ('id, attribute list, attribute list) t ->
module PhysicalMake(X : sig type t end) : S with type vertex = X.t Format.formatter ->
'id Enum.t -> unit
module IntGraph : S with type vertex = int (** Pretty print the given graph (starting from the given set of vertices)
to the channel in DOT format *)
end