Stoer-Wagner Algorithm in Clojure

Description of the problem

Today I am going to implement the Stoer-Wagner algorithm that finds minimum cuts in a weighted graph.

The algorithm

The algorithm is split into two functions

Function MinimumCut
Input: A graph G
Output: A pair of vertices a and b
Begin
  Let V be the set of vertices of G
  Let x be the either end of the edge with highest weight
  Let A 
  While V \ A is non-empty
    Find the edge e with the highest weight that is incident
         to A and V \ A
    Add the vertex of e that lies in V \ A to A
  End While
  Return the last two vertices in A
End

Function StoerWagner
Input: A graph G
       A weight w
       A subset X of vertices in G
Output: Optimal cut and its weight
Begin
  If G contains only one edge then
     Return w, X and the complement of X
  Else
     Let a and b be MinimumCut(G)
     If the cut-weight of a is less than w then
        Let w be cut-weight of a
        Let X be a 
     End If
     Merge a and b on G and adjust the weights of 
           the graph G accordingly
     Call StoerWagner(G,w,X)
End

An implementation in clojure

I am going to use a hashmap of edges with their weights. I am going to use sets of size 2 to represent edges. Here is an example:

(def G {#{1 2} 2 #{1 5} 3
        #{2 5} 2 #{2 3} 3 #{2 6} 2
        #{3 4} 4 #{3 7} 2
        #{4 7} 2 #{4 8} 2
        #{5 6} 3
        #{6 7} 1
        #{7 8} 3})

#'stoer-wagner/G

I am going to need to utility functions. So here they are:

(defn helper [a b]
  (union (if (set? a) a #{a})
         (if (set? b) b #{b})))

(defn calculate-cut-weight [G v]
  (->> (keys G)
       (map #(if (contains? % v) (G %) 0))
       (reduce +)))

#'stoer-wagner/helper
#'stoer-wagner/calculate-cut-weight

Next is the function that implements the MimimumCut part of the algorithm:

(defn find-minimum-cut [G]
  (let [V (reduce union (keys G))]
    (loop [A [(rand-nth (into [] V))]]
      (let [C (difference V A)]
        (if (empty? C)
          (->> A reverse (take 2) (into []))
          (->> (for [c C] [c (reduce + (for [a A] (get G #{c a} 0)))])
               (sort-by second)
               last
               first
               (conj A)
               recur))))))

#'stoer-wagner/find-minimum-cut

Let us try on G:

(find-minimum-cut G)

[8 7]

Next is the function that does the merging of vertices:

(defn shrink-graph [G a b]
  (let [H (filter #(empty? (intersection #{a b} %))
                  (keys G))
        K (for [e (remove #{#{a b}} (keys G))
                :when (not (empty? (intersection e #{a b})))
                :let [c (->> e (remove #{a b}) first)]]
            {#{(helper a b) c} (+ (get G #{c a} 0) (get G #{c b} 0))})]
    (merge-with + (into {} K) (select-keys G H))))

#'stoer-wagner/shrink-graph

Let us test again:

(apply shrink-graph G (find-minimum-cut G))

{#{4 3} 4, #{7 6} 1, #{7 3} 2, #{4 8} 2, #{6 #{1 5}} 3, #{#{1 5} 2} 4, #{7 4} 2, #{6 2} 2, #{7 8} 3, #{3 2} 3}

And finally, the main engine of the algorithm:

(defn stoer-wagner [G]
  (loop [x #{}
         w (reduce + (vals G))
         H G]
    (if (= 1 (count H))
      (let [A (helper x #{})
            V (reduce union (keys G))]
        [w A (difference V A)])
      (let [[a b] (find-minimum-cut H)
            wn (calculate-cut-weight H a)
            Hn (shrink-graph H a b)]
        (if (< wn w)
          (recur a wn Hn)
          (recur x  w Hn))))))