From bae8c709b2c3f15eb6f656880bbde119cc9060a0 Mon Sep 17 00:00:00 2001 From: Jean-Christophe Filliatre Date: Sat, 12 May 2012 08:45:58 +0000 Subject: [PATCH] integrated patchs from Markus Weissmann --- CHANGES | 5 ++- Makefile.in | 2 +- src/contraction.ml | 79 +++++++++++++++++++++++++++++++++++++++++++++ src/contraction.mli | 49 ++++++++++++++++++++++++++++ src/gmap.ml | 13 ++++++++ src/gmap.mli | 10 ++++++ 6 files changed, 156 insertions(+), 2 deletions(-) create mode 100644 src/contraction.ml create mode 100644 src/contraction.mli diff --git a/CHANGES b/CHANGES index fd0ed0b3..8e019e54 100644 --- a/CHANGES +++ b/CHANGES @@ -1,6 +1,9 @@ + o new module Contraction implementing edge contraction + (contributed by Markus W. Weissmann) + o Gmap: new function [filter_map] (contributed by Markus W. Weissmann) o Topological: fix bug when a cycle depends on another cycle. That breaks - compatibility: the input graph must implement Sig.COMPARABLE instead of + compatibility: the input graph must implement Sig.COMPARABLE instead of Sig.HASHABLE o new module Topological.Make_stable to iterate over a graph in a **stable** topological order. Stable means that the provided ordering only depends on diff --git a/Makefile.in b/Makefile.in index f406562b..f44da7b9 100644 --- a/Makefile.in +++ b/Makefile.in @@ -71,7 +71,7 @@ CMO = version util blocks persistent imperative \ delaunay builder classic rand oper \ components path nonnegative traverse coloring topological kruskal flow \ graphviz gml dot_parser dot_lexer dot pack \ - gmap minsep cliquetree mcs_m md strat fixpoint leaderlist + gmap minsep cliquetree mcs_m md strat fixpoint leaderlist contraction CMO := $(LIB) $(patsubst %, $(SRCDIR)/%.cmo, $(CMO)) CMX = $(CMO:.cmo=.cmx) diff --git a/src/contraction.ml b/src/contraction.ml new file mode 100644 index 00000000..1f170a74 --- /dev/null +++ b/src/contraction.ml @@ -0,0 +1,79 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* Copyright (c) 2012 Technische Universitaet Muenchen + * Markus W. Weissmann + * All rights reserved. *) + +(* Edge contraction for directed, edge-labeled graphs *) + +module type G = sig + type t + module V : Sig.COMPARABLE + type vertex = V.t + module E : Sig.EDGE with type vertex = vertex + type edge = E.t + + val empty : t + val add_edge_e : t -> edge -> t + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Make + (G : G) = +struct + module M = Map.Make(G.V) + module S = Set.Make(G.V) + + let contract prop g = + (* if the edge is to be removed (property = true): + * make a union of the two union-sets of start and end node; + * put this set in the map for all nodes in this set *) + let f edge m = + if prop edge then + let s_src, s_dst = M.find (G.E.src edge) m, M.find (G.E.dst edge) m in + let s = S.union s_src s_dst in + S.fold (fun vertex m -> M.add vertex s m) s m + else + m + in + (* if the edge is to be kept, add it to the new graph, exchanging + * the start and end node with the minimum element from the set of + * to-be-unified nodes; 'minimum is an arbitrary choice: any + * deterministic choice will do *) + let add m edge g = + if prop edge then + g + else + let lookup n = S.min_elt (M.find n m) in + G.add_edge_e g + (G.E.create (lookup (G.E.src edge)) (G.E.label edge) + (lookup (G.E.dst edge))) + in + (* initialize map with singleton-sets for every node (of itself) *) + let m = + G.fold_vertex (fun vertex m -> M.add vertex (S.singleton vertex) m) + g M.empty + in + (* find all closures *) + let m = G.fold_edges_e f g m in + (* rewrite the node numbers to close the gaps *) + G.fold_edges_e (add m) g G.empty + +end + diff --git a/src/contraction.mli b/src/contraction.mli new file mode 100644 index 00000000..156d66fa --- /dev/null +++ b/src/contraction.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* Ocamlgraph: a generic graph library for OCaml *) +(* Copyright (C) 2004-2010 *) +(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software is distributed in the hope that it will be useful, *) +(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) +(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) +(* *) +(**************************************************************************) + +(* Copyright (c) 2012 Technische Universitaet Muenchen + * Markus W. Weissmann + * All rights reserved. *) + +(** Edge contraction for directed, edge-labeled graphs *) + +(* This algorithm should be extensible to undirected, unlabeled graphs! *) + +(** Minimal graph signature for edge contraction algorithm *) +module type G = sig + type t + module V : Sig.COMPARABLE + type vertex = V.t + module E : Sig.EDGE with type vertex = vertex + type edge = E.t + + val empty : t + val add_edge_e : t -> edge -> t + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a +end + +module Make + (G : G) : +sig + val contract : (G.E.t -> bool) -> G.t -> G.t + (** [contract p g] will perform edge contraction on the graph [g]. + The edges for which the property [p] holds/is true will get contracted: + The resulting graph will not have these edges; the start- and end-node + of these edges will get united. *) +end + diff --git a/src/gmap.ml b/src/gmap.ml index 8048266f..2e353488 100644 --- a/src/gmap.ml +++ b/src/gmap.ml @@ -51,6 +51,12 @@ module Vertex(G_Src : V_SRC)(G_Dst : V_DST ) = struct (fun x g -> G_Dst.add_vertex g (convert_vertex f x)) g (G_Dst.empty ()) + let filter_map f g = + G_Src.fold_vertex + (fun x g -> match f x with + | Some e -> G_Dst.add_vertex g e + | None -> g + ) g (G_Dst.empty ()) end (** {2 Mapping of edges} *) @@ -85,6 +91,13 @@ module Edge(G_Src: E_SRC)(G_Dst: E_DST) = struct G_Src.fold_edges_e (fun x g -> G_Dst.add_edge_e g (convert_edge f x)) g (G_Dst.empty ()) + + let filter_map f g = + G_Src.fold_edges_e + (fun x g -> match f x with + | Some e -> G_Dst.add_edge_e g e + | None -> g + ) g (G_Dst.empty ()) end (* diff --git a/src/gmap.mli b/src/gmap.mli index 9f9f6018..89a161ef 100644 --- a/src/gmap.mli +++ b/src/gmap.mli @@ -43,6 +43,11 @@ module Vertex(G_Src : V_SRC)(G_Dst : V_DST) : sig (** [map f g] applies [f] to each vertex of [g] and so builds a new graph based on [g] *) + val filter_map : (G_Src.V.t -> G_Dst.vertex option) -> G_Src.t -> G_Dst.t + (** [filter_map f g] applies [f] to each vertex of [g] and so + builds a new graph based on [g]; if [None] is returned by [f] + the vertex is omitted in the new graph. *) + end (** {2 Mapping of edges} *) @@ -69,4 +74,9 @@ module Edge(G_Src: E_SRC)(G_Dst: E_DST) : sig (** [map f g] applies [f] to each edge of [g] and so builds a new graph based on [g] *) + val filter_map : (G_Src.E.t -> G_Dst.edge option) -> G_Src.t -> G_Dst.t + (** [filter_map f g] applies [f] to each edge of [g] and so builds + a new graph based on [g]; if [None] is returned by [f] the + edge is omitted in the new graph. *) + end