Added component-graph

2 files changed, 37 insertions, 1 deletions

diff --git a/src/clojure/contrib/graph.clj b/src/clojure/contrib/graph.clj
index 1979c0db..94199893 100644
--- a/src/clojure/contrib/graph.clj
+++ b/src/clojure/contrib/graph.clj
@@ -13,7 +13,8 @@
 ;;  straszheimjeffrey (gmail)
 ;;  Created 23 June 2009
 
-(ns clojure.contrib.graph)
+(ns clojure.contrib.graph
+  (use [clojure.set :only (union)]))
 
 
 (defstruct directed-graph
@@ -77,6 +78,23 @@
                    (recur ns nv (conj acc comp)))))]
     (step po #{} [])))
 
+(defn component-graph
+  "Given a graph, perhaps with cycles, return a reduced graph that is acyclic.
+   Each node in the new graph will be a set of nodes from the old.
+   These sets are the strongly connected components.  Each edge will
+   be the union of all the edges of the prior graph."
+  [g]
+  (let [sccs (scc g)
+        find-node-set (fn [n]
+                        (some #(if (% n) % nil) sccs))
+        find-neighbors (fn [ns]
+                         (let [nbs1 (map (partial get-neighbors g) ns)
+                               nbs2 (map set nbs1)
+                               nbs3 (apply union nbs2)]
+                           (set (map find-node-set nbs3))))
+        nm (into {} (map (fn [ns] [ns (find-neighbors ns)]) sccs))]
+    (struct directed-graph (set sccs) nm)))
+
 (defn self-recursive-sets
   "Returns, as a sequence of sets, the components of a graph that are
    self-recursive."
diff --git a/src/clojure/contrib/test_contrib/test_graph.clj b/src/clojure/contrib/test_contrib/test_graph.clj
index 248203fd..6638fa4c 100644
--- a/src/clojure/contrib/test_contrib/test_graph.clj
+++ b/src/clojure/contrib/test_contrib/test_graph.clj
@@ -67,6 +67,24 @@
          #{#{:h} #{:g} #{:i :j} #{:b :c :a :d :e} #{:f}}))
   (is (empty? (scc empty-graph))))
 
+(deftest test-component-graph
+  (let [cg (component-graph test-graph-2)
+        ecg (component-graph empty-graph)]
+    (is (= (:nodes cg) (set (scc test-graph-2))))
+    (is (= (get-neighbors cg #{:a :b :c :d :e})
+           #{#{:a :b :c :d :e}}))
+    (is (= (get-neighbors cg #{:g})
+           #{#{:a :b :c :d :e} #{:f}}))
+    (is (= (get-neighbors cg #{:i :j})
+           #{#{:i :j}}))
+    (is (= (get-neighbors cg #{:h})
+           #{}))
+    (is (= ecg empty-graph))))
+
+(comment
+  (run-tests)
+)
+
 
 (deftest test-self-recursive-sets
   (is (= (set (self-recursive-sets test-graph-2))