mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
LazyGraph is now fully polymorphic (plan to implement LazyGraph.product, which
cannot be expressed with functors), with optional eq/hash functions
This commit is contained in:
Simon Cruanes
parent
e6eb9a79eb
commit
e0b6b8be5b
3 changed files with 509 additions and 548 deletions
|
|
@ -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 =
|
||||
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
|
||||
G.Node (x, Obj.tag x, children)
|
||||
LazyGraph.Node (x, Obj.tag x, children)
|
||||
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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
415
lazyGraph.ml
415
lazyGraph.ml
|
|
@ -25,233 +25,157 @@ 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
|
||||
(** 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. *)
|
||||
|
||||
module H : Hashtbl.S with type key = vertex
|
||||
|
||||
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 =
|
||||
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 vertex * 'v * ('e * vertex) Enum.t
|
||||
| Node of 'id * 'v * ('e * 'id) Enum.t
|
||||
(** 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} *)
|
||||
(** {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. *)
|
||||
let empty =
|
||||
{ eq=(==);
|
||||
hash=Hashtbl.hash;
|
||||
force = (fun _ -> Empty);
|
||||
}
|
||||
|
||||
val empty : ('v, 'e) t
|
||||
(** Empty graph *)
|
||||
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; }
|
||||
|
||||
val singleton : vertex -> 'v -> ('v, 'e) t
|
||||
(** Trivial graph, composed of one node *)
|
||||
let make ?(eq=(=)) ?(hash=Hashtbl.hash) force =
|
||||
{ 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 *)
|
||||
let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges =
|
||||
failwith "from_enum: not implemented"
|
||||
|
||||
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} *)
|
||||
|
||||
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 ->
|
||||
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)
|
||||
| Some (l, edges) -> Node (v, l, Enum.of_list edges) in
|
||||
{ eq; hash; force; }
|
||||
|
||||
(** {2 Traversals} *)
|
||||
(** {2 Polymorphic utils} *)
|
||||
|
||||
(** {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 *)
|
||||
(** 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} *)
|
||||
|
||||
(** {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 'e todo_item =
|
||||
| FullEnter of vertex * 'e path
|
||||
| FullExit of vertex
|
||||
| FullFollowEdge of 'e path
|
||||
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 path v =
|
||||
let rec mem_path ~eq path v =
|
||||
match path with
|
||||
| (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
|
||||
|
||||
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 () ->
|
||||
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 H.mem explored v' then next ()
|
||||
else begin match graph v' with
|
||||
if explored#mem v' then next ()
|
||||
else begin match graph.force v' with
|
||||
| Empty -> next ()
|
||||
| Node (_, label, edges) ->
|
||||
H.add explored v' ();
|
||||
explored#add v';
|
||||
(* explore neighbors *)
|
||||
Enum.iter
|
||||
(fun (e,v'') ->
|
||||
|
|
@ -269,8 +193,8 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
| 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''
|
||||
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
|
||||
|
|
@ -280,8 +204,13 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
end
|
||||
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 () ->
|
||||
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 () =
|
||||
|
|
@ -289,12 +218,12 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
match Stack.pop s with
|
||||
| FullExit v' -> ExitVertex v'
|
||||
| FullEnter (v', path) ->
|
||||
if H.mem explored v' then next ()
|
||||
if explored#mem v' then next ()
|
||||
(* explore the node now *)
|
||||
else begin match graph v' with
|
||||
else begin match graph.force v' with
|
||||
| Empty -> next ()
|
||||
| Node (_, label, edges) ->
|
||||
H.add explored v' ();
|
||||
explored#add v';
|
||||
(* prepare to exit later *)
|
||||
Stack.push (FullExit v') s;
|
||||
(* explore neighbors *)
|
||||
|
|
@ -310,8 +239,8 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
| 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''
|
||||
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
|
||||
|
|
@ -320,70 +249,89 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
MeetEdge (v'', e, v', EdgeForward)
|
||||
end
|
||||
in next
|
||||
end
|
||||
end
|
||||
|
||||
let bfs ?id ?explored graph v =
|
||||
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 =
|
||||
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 enum graph v = (Enum.empty, Enum.empty) (* TODO *)
|
||||
|
||||
let depth graph v =
|
||||
let depth graph v =
|
||||
failwith "not implemented" (* TODO *)
|
||||
|
||||
(** 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 *)
|
||||
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"
|
||||
|
||||
(** {2 Lazy transformations} *)
|
||||
(** {2 Lazy transformations} *)
|
||||
|
||||
let union ?(combine=fun x y -> x) g1 g2 =
|
||||
fun v ->
|
||||
match g1 v, g2 v with
|
||||
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 =
|
||||
fun vertex ->
|
||||
match g vertex with
|
||||
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 (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 =
|
||||
fun vertex ->
|
||||
match g vertex with
|
||||
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 vertex l ->
|
||||
| Node (_, l, edges_enum) when vertices v l ->
|
||||
(* filter out edges *)
|
||||
let edges_enum' = Enum.filter (fun (e,v') -> edges vertex e v') edges_enum in
|
||||
Node (vertex, l, edges_enum')
|
||||
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 limit_depth ~max g =
|
||||
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
|
||||
module Infix = struct
|
||||
let (++) g1 g2 = union ?combine:None g1 g2
|
||||
end
|
||||
end
|
||||
|
||||
module Dot = struct
|
||||
module Dot = struct
|
||||
type attribute = [
|
||||
| `Color of string
|
||||
| `Shape of string
|
||||
|
|
@ -394,7 +342,7 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
] (** Dot attribute *)
|
||||
|
||||
(** 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 *)
|
||||
let print_attribute formatter attr =
|
||||
match attr with
|
||||
|
|
@ -407,13 +355,13 @@ module Make(X : HASHABLE) : S with type vertex = X.t = struct
|
|||
(* map from vertices to integers *)
|
||||
and get_id =
|
||||
let count = ref 0 in
|
||||
let m = H.create 5 in
|
||||
let m = mk_hmap ~eq ~hash in
|
||||
fun vertex ->
|
||||
try H.find m vertex
|
||||
try m#get vertex
|
||||
with Not_found ->
|
||||
let n = !count in
|
||||
incr count;
|
||||
H.replace m vertex n;
|
||||
m#add vertex n;
|
||||
n
|
||||
in
|
||||
(* 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 enum = Full.bfs_full graph vertices in
|
||||
pp_enum ~name formatter enum
|
||||
end
|
||||
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)
|
||||
|
|
|
|||
191
lazyGraph.mli
191
lazyGraph.mli
|
|
@ -23,127 +23,170 @@ 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
|
||||
(** 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). *)
|
||||
components can be represented by a single value of type ('v,'e) t).
|
||||
|
||||
(** {2 Type definitions} *)
|
||||
The default equality considered here is [(=)], and the default hash
|
||||
function is {! Hashtbl.hash}. *)
|
||||
|
||||
type vertex
|
||||
(** The concrete type of a vertex. Vertices are considered unique within
|
||||
the graph. *)
|
||||
(** {2 Type definitions} *)
|
||||
|
||||
module H : Hashtbl.S with type key = vertex
|
||||
|
||||
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 =
|
||||
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 vertex * 'v * ('e * vertex) Enum.t
|
||||
| Node of 'id * 'v * ('e * 'id) Enum.t
|
||||
(** 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} *)
|
||||
(** {2 Basic constructors} *)
|
||||
|
||||
(** It is difficult to provide generic combinators to build graphs. The problem
|
||||
(** 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 empty : ('v, 'e) t
|
||||
val empty : ('id, 'v, 'e) t
|
||||
(** 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 *)
|
||||
|
||||
val from_enum : vertices:(vertex * 'v) Enum.t ->
|
||||
edges:(vertex * 'e * vertex) Enum.t ->
|
||||
('v, 'e) t
|
||||
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 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_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 *)
|
||||
|
||||
(** {2 Traversals} *)
|
||||
(** {2 Polymorphic utils} *)
|
||||
|
||||
(** {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 *)
|
||||
(** 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} *)
|
||||
|
||||
(** {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 bfs_full : ?id:int ref -> ?explored:unit H.t ->
|
||||
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t
|
||||
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 dfs_full : ?id:int ref -> ?explored:unit H.t ->
|
||||
('v, 'e) t -> vertex Enum.t -> ('v, 'e) traverse_event Enum.t
|
||||
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
|
||||
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 ->
|
||||
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t
|
||||
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 ref -> ?explored:unit H.t ->
|
||||
('v, 'e) t -> vertex -> (vertex * 'v * int) Enum.t
|
||||
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 : ('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. *)
|
||||
|
||||
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 *)
|
||||
|
||||
val min_path : ?distance:(vertex -> 'e -> vertex -> int) ->
|
||||
('v, 'e) t -> vertex -> vertex ->
|
||||
int * 'e path
|
||||
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} *)
|
||||
(** {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,
|
||||
[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
|
||||
val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) ->
|
||||
('id, 'v, 'e) t -> ('id, '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
|
||||
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 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
|
||||
depth is too high will be replaced by Empty *)
|
||||
|
||||
module Infix : sig
|
||||
val (++) : ('v, 'e) t -> ('v, 'e) t -> ('v, 'e) t
|
||||
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 Pretty printing in the DOT (graphviz) format *)
|
||||
module Dot : sig
|
||||
(** {2 Pretty printing in the DOT (graphviz) format *)
|
||||
module Dot : sig
|
||||
type attribute = [
|
||||
| `Color of string
|
||||
| `Shape of string
|
||||
|
|
@ -153,32 +196,14 @@ module type S = sig
|
|||
| `Other of string * string
|
||||
] (** Dot attribute *)
|
||||
|
||||
val pp_enum : name:string -> Format.formatter ->
|
||||
(attribute list,attribute list) Full.traverse_event Enum.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
|
||||
|
||||
val pp : name:string -> (attribute list, attribute list) t ->
|
||||
val pp : name:string -> ('id, attribute list, attribute list) t ->
|
||||
Format.formatter ->
|
||||
vertex Enum.t -> unit
|
||||
'id 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
|
||||
|
||||
(** {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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue