integrated patchs from Markus Weissmann

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

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)

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 <[email protected]>
+ * 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
+

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 <[email protected]>
+ * 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
+

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
 
 (*

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