From e0b6b8be5b3fa6b36da90b77dca7c8869a0c3975 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 21 Mar 2013 11:22:41 +0100 Subject: [PATCH] LazyGraph is now fully polymorphic (plan to implement LazyGraph.product, which cannot be expressed with functors), with optional eq/hash functions --- examples/mem_size.ml | 25 +- lazyGraph.ml | 743 ++++++++++++++++++++----------------------- lazyGraph.mli | 289 +++++++++-------- 3 files changed, 509 insertions(+), 548 deletions(-) diff --git a/examples/mem_size.ml b/examples/mem_size.ml index 65d8b534..618d851f 100644 --- a/examples/mem_size.ml +++ b/examples/mem_size.ml @@ -1,19 +1,18 @@ (** 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/ *) -module G = LazyGraph.PhysicalMake(struct type t = Obj.t end) - (** Graph on memory values *) - open Enum.Infix (** A graph vertex is an Obj.t value *) -let graph x = - if Obj.is_block x - then - let children = Enum.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in - G.Node (x, Obj.tag x, children) - else - G.Node (x, Obj.obj x, Enum.empty) +let graph = + let force x = + if Obj.is_block x + then + let children = Enum.map (fun i -> i, Obj.field x i) (0--(Obj.size x - 1)) in + LazyGraph.Node (x, Obj.tag x, children) + else + LazyGraph.Node (x, Obj.obj x, Enum.empty) + in LazyGraph.make ~eq:(==) force let word_size = Sys.word_size / 8 @@ -24,14 +23,14 @@ let size x = let compute_size x = 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 let print_val fmt x = 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 - 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 out = open_out filename in diff --git a/lazyGraph.ml b/lazyGraph.ml index 7c95d511..6d81470d 100644 --- a/lazyGraph.ml +++ b/lazyGraph.ml @@ -25,431 +25,368 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Lazy graph data structure} *) -module type S = sig - (** 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 - components can be represented by a single value of type ('v,'e) t). *) +(** 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 + components can be represented by a single value of type ('v,'e) t). *) - (** {2 Type definitions} *) +(** {2 Type definitions} *) - type vertex - (** The concrete type of a vertex. Vertices are considered unique within - the graph. *) +type ('id, 'v, 'e) t = { + eq : 'id -> 'id -> bool; + 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 - (** 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 +let empty = + { eq=(==); + hash=Hashtbl.hash; + force = (fun _ -> Empty); + } - (** {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 - 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. *) +let make ?(eq=(=)) ?(hash=Hashtbl.hash) force = + { eq; hash; force; } - val empty : ('v, 'e) t - (** Empty graph *) +let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges = + failwith "from_enum: not implemented" - val singleton : vertex -> 'v -> ('v, 'e) t - (** Trivial graph, composed of one node *) +let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f = + 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 -> - edges:(vertex * 'e * vertex) Enum.t -> - ('v, 'e) t - (** Concrete (eager) representation of a Graph *) +(** {2 Polymorphic utils} *) - val from_fun : (vertex -> ('v * ('e * vertex) list) option) -> ('v, 'e) t - (** Convenient semi-lazy implementation of graphs *) +(** A set of vertices *) +type 'id set = + < + mem : 'id -> bool; + add : 'id -> unit; + iter : ('id -> unit) -> unit; + > - (** {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 *) +(** 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 - (** 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}) *) +(** 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 - (** {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 *) +type ('id,'a) map = + < + mem : 'id -> bool; + get : 'id -> 'a; (* or Not_found *) + add : 'id -> 'a -> unit; + iter : ('id -> 'a -> unit) -> unit; + > - 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 *) +(** 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} *) + +(** {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 -(** {2 Module type for hashable types} *) -module type HASHABLE = sig - type t - val equal : t -> t -> bool - val hash : t -> int +let bfs ?id ?explored graph v = + Enum.filterMap + (function + | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) + | _ -> 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 -(** {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 +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 *) -(** {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} *) - - let empty = - fun _ -> Empty - - let singleton v label = - fun v' -> - if X.equal v v' then Node (v, label, Enum.empty) else Empty - - let from_enum ~vertices ~edges = failwith "from_enum: not implemented" - - 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 + (** Print an enum of Full.traverse_event *) + let pp_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~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 = mk_hmap ~eq ~hash in + fun vertex -> + try m#get vertex + with Not_found -> + let n = !count in + incr count; + m#add 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 "@[digraph %s {@;" name; + (* traverse *) + Enum.iter (function - | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) - | _ -> None) - (Full.bfs_full ?id ?explored graph (Enum.singleton v)) + | Full.EnterVertex (v, attrs, _, _) -> + Format.fprintf formatter " @[%a [%a];@]@." pp_vertex v + (Enum.pp ~sep:"," print_attribute) (Enum.of_list attrs) + | Full.ExitVertex _ -> () + | Full.MeetEdge (v2, attrs, v1, _) -> + Format.fprintf formatter " @[%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 = - 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) 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 "@[digraph %s {@;" name; - (* traverse *) - Enum.iter - (function - | Full.EnterVertex (v, attrs, _, _) -> - Format.fprintf formatter " @[%a [%a];@]@." pp_vertex v - (Enum.pp ~sep:"," print_attribute) (Enum.of_list attrs) - | Full.ExitVertex _ -> () - | Full.MeetEdge (v2, attrs, v1, _) -> - Format.fprintf formatter " @[%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 + let pp ~name graph formatter vertices = + let enum = Full.bfs_full graph vertices in + pp_enum ~eq:graph.eq ~hash:graph.hash ~name formatter enum 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) diff --git a/lazyGraph.mli b/lazyGraph.mli index 133ce87e..893999b7 100644 --- a/lazyGraph.mli +++ b/lazyGraph.mli @@ -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. *) -(** {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 - 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). *) +(** 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 + 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 - (** The concrete type of a vertex. Vertices are considered unique within - the graph. *) +type ('id, 'v, 'e) t = { + eq : 'id -> 'id -> bool; + 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 - (** 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 - (** A reverse path (from the last element of the path to the first). *) +(** 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. + 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...). *) - (** {2 Basic constructors} *) +val empty : ('id, 'v, 'e) t + (** Empty graph *) - (** 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. - 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 singleton : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> + 'id -> 'v -> ('id, 'v, 'e) t + (** Trivial graph, composed of one node *) - val empty : ('v, 'e) t - (** Empty graph *) +val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> + ('id -> ('id,'v,'e) node) -> ('id,'v,'e) t + (** Build a graph from the [force] function *) - val singleton : vertex -> 'v -> ('v, 'e) t - (** Trivial graph, composed of one node *) +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)*) - val from_enum : vertices:(vertex * 'v) Enum.t -> - edges:(vertex * 'e * vertex) Enum.t -> - ('v, 'e) t - (** Concrete (eager) representation of a Graph (XXX not implemented)*) +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 *) - val from_fun : (vertex -> ('v * ('e * vertex) list) option) -> ('v, 'e) t - (** Convenient semi-lazy implementation of graphs *) +(** {2 Polymorphic utils} *) - (** {2 Traversals} *) +(** A set of vertices *) +type 'id set = + < + mem : 'id -> bool; + add : 'id -> unit; + iter : ('id -> unit) -> unit; + > - (** {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 mk_hset : ?eq:('id -> 'id -> bool) -> hash:('id -> int) -> 'id set + (** Make a set based on hashtables *) - 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 mk_tset : cmp:('id -> 'id -> int) -> 'id set + (** Make a set based on balanced trees *) - 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 +type ('id,'a) map = + < + mem : 'id -> bool; + 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 -> - ('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t - (** Lazy traversal in breadth first *) +val mk_tmap : cmp:('id -> 'id -> int) -> ('id,'a) map - val dfs : ?id:int ref -> ?explored:unit H.t -> - ('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t - (** Lazy traversal in depth first *) +(** {2 Traversals} *) - val enum : ('v, 'e) t -> vertex -> (vertex * 'v) Enum.t * (vertex * 'e * vertex) Enum.t - (** Convert to an enumeration. The traversal order is undefined. *) +(** {3 Full interface to traversals} *) +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 - (** Map vertices to their depth, ie their distance from the initial point *) + val bfs_full : ?id:int -> ?explored:(unit -> 'id set) -> + ('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) -> - ('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 + val dfs_full : ?id:int -> ?explored:(unit -> 'id set) -> + ('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 *) end -(** {2 Module type for hashable types} *) -module type HASHABLE = sig - type t - val equal : t -> t -> bool - val hash : t -> int +(** The traversal functions assign a unique ID to every traversed node *) + +val bfs : ?id:int -> ?explored:(unit -> 'id set) -> + ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) Enum.t + (** 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 -(** {2 Implementation of HASHABLE with physical equality and hash} *) -module PhysicalHash(X : sig type t end) : HASHABLE with type t = X.t +(** {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 *) -(** {2 Build a graph} *) -module Make(X : HASHABLE) : S with type vertex = X.t + val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> + name:string -> Format.formatter -> + ('id,attribute list,attribute list) Full.traverse_event Enum.t -> + unit -(** {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 + val pp : name:string -> ('id, attribute list, attribute list) t -> + Format.formatter -> + 'id Enum.t -> unit + (** Pretty print the given graph (starting from the given set of vertices) + to the channel in DOT format *) +end