2 files changed, 176 insertions, 2 deletions

diff --git a/src/clojure/contrib/graph.clj b/src/clojure/contrib/graph.clj
index 34a3454e..07b02bee 100644
--- a/src/clojure/contrib/graph.clj
+++ b/src/clojure/contrib/graph.clj
@@ -13,7 +13,9 @@
 ;;  straszheimjeffrey (gmail)
 ;;  Created 23 June 2009
 
-(ns clojure.contrib.graph)
+(ns clojure.contrib.graph
+  (use [clojure.contrib.macros :only (letfn)])
+  (use [clojure.contrib.seq-utils :only (flatten indexed)]))
 
 
 
@@ -87,7 +89,15 @@
                        ns (remove nv stack)]
                    (recur ns nv (conj acc comp)))))]
     (step po #{} [])))
-  
+
+(defn self-recursive-sets
+  "Returns, as a sequence of sets, the components of a graph that are
+   self-recursive."
+  [g]
+  (letfn [recursive? [n]
+            (or (> (count n) 1)
+                (some n (get-neighbors g (first n))))]
+     (filter recursive? (scc g))))
                           
 (comment
 
@@ -108,6 +118,112 @@
   (post-ordered-visit test-graph-2 0 [#{} []])
   (post-ordered-nodes test-graph-2)
   (scc test-graph-2)
+  (self-recursive-sets test-graph-2)
+
+)
+
+
+(defn fixed-point
+  "Repeatedly apply fun to data until (equal old-data new-data)
+   returns true.  If max iterations occur, it will throw an
+   exception.  Set max to nil for unlimited iterations."
+  [data fun max equal]
+  (let [step (fn step [data idx]
+               (when (and idx (= 0 idx))
+                 (throw (Exception. "Fixed point overflow")))
+               (let [new-data (fun data)]
+                 (if (equal data new-data)
+                   new-data
+                   (recur new-data (and idx (dec idx))))))]
+    (step data max)))
+                  
+(defn- fold-into-sets
+  [priorities]
+  (let [step (fn [acc [idx dep]]
+               (assoc acc dep (conj (acc dep) idx)))]
+    (reduce step
+            (vec (replicate (inc (apply max 0 priorities)) #{}))
+            (indexed priorities))))
+            
+(defn dependency-list
+  "Similar to a topological sort, this returns a vector of sets, each
+   a set of nodes that depend on the earlier nodes in the vector.
+   Assume the input graph (which much be acyclic) has an edge a->b
+   when a depend on b."
+  [g]
+  (let [step (fn [d]
+               (let [update (fn [n]
+                              (inc (apply max -1 (map d (get-neighbors g n)))))]
+                 (vec (map update (range (:count g))))))
+        counts (fixed-point (vec (replicate (:count g) 0))
+                            step
+                            (inc (:count g))
+                            =)]
+    (fold-into-sets counts)))
+    
+(defn stratification-list
+  "Similar to dependency-list (see doc), except two graphs are
+   provided.  The first is as dependency-list.  The second (which may
+   have cycles) provides a partial-dependency relation.  If node a
+   depends on node b (meaning an edge a->b exists) in the second
+   graph, node a must be equal or later in the sequence."
+  [g1 g2]
+  (assert (= (:count g1) (:count g2)))
+  (let [step (fn [d]
+               (letfn [update [n]
+                       (max (inc (apply max -1
+                                        (map d (get-neighbors g1 n))))
+                            (apply max -1 (map d (get-neighbors g2 n))))]
+                  (vec (map update (range (:count g1))))))
+        counts (fixed-point (vec (replicate (:count g1) 0))
+                            step
+                            (inc (:count g1))
+                            =)]
+    (fold-into-sets counts)))
+        
+    
+
+(comment
+
+  (dependency-list test-graph-2)
+
+  (def test-graph-3
+       (struct directed-graph 6
+               {0 [1]
+                1 [2]
+                2 [3]
+                3 [4]
+                4 [5]
+                5 []}))
+
+  (dependency-list test-graph-3)
+
+  (def test-graph-4
+       (struct directed-graph 8
+               {0 []
+                1 [0]
+                2 [0]
+                3 [0 1]
+                4 [3 2]
+                5 [4]
+                6 [3]
+                7 [5]}))
+
+  (dependency-list test-graph-4)
+
+  (def test-graph-5
+       (struct directed-graph 8
+               {0 []
+                1 []
+                2 [1]
+                3 []
+                4 []
+                5 []
+                6 [5]
+                7 []}))
+
+  (dependency-list test-graph-5)
+  (stratification-list test-graph-4 test-graph-5)
 
 )
 
diff --git a/src/clojure/contrib/test_contrib/test_graph.clj b/src/clojure/contrib/test_contrib/test_graph.clj
index 093462b8..94daeccd 100644
--- a/src/clojure/contrib/test_contrib/test_graph.clj
+++ b/src/clojure/contrib/test_contrib/test_graph.clj
@@ -64,6 +64,64 @@
          [#{8 9} #{7} #{6} #{5} #{0 1 2 3 4}]))
   (is (empty? (scc empty-graph))))
 
+
+(deftest test-self-recursive-sets
+  (is (= (self-recursive-sets test-graph-2)
+         [#{8 9} #{5} #{0 1 2 3 4}]))
+  (is (empty? (self-recursive-sets empty-graph))))
+
+
+(def test-graph-3
+     (struct directed-graph 6
+             {0 [1]
+              1 [2]
+              2 [3]
+              3 [4]
+              4 [5]
+              5 []}))
+
+(def test-graph-4
+     (struct directed-graph 8
+             {0 []
+              1 [0]
+              2 [0]
+              3 [0 1]
+              4 [3 2]
+              5 [4]
+              6 [3]
+              7 [5]}))
+
+  (def test-graph-5
+       (struct directed-graph 8
+               {0 []
+                1 []
+                2 [1]
+                3 []
+                4 []
+                5 []
+                6 [5]
+                7 []}))
+
+(deftest test-dependency-list
+  (is (thrown-with-msg? Exception #".*Fixed point overflow.*"
+                        (dependency-list test-graph-2)))
+  (is (= (dependency-list test-graph-3)
+         [#{5} #{4} #{3} #{2} #{1} #{0}]))
+  (is (= (dependency-list test-graph-4)
+         [#{0} #{1 2} #{3} #{4 6} #{5} #{7}]))
+  (is (= (dependency-list test-graph-5)
+         [#{0 1 3 4 5 7} #{2 6}]))
+  (is (= (dependency-list empty-graph)
+         [#{}])))
+
+(deftest test-stratification-list
+  (is (thrown-with-msg? Exception #".*Fixed point overflow.*"
+                        (stratification-list test-graph-2 test-graph-2)))
+  (is (= (stratification-list test-graph-4 test-graph-5)
+         [#{0} #{1 2} #{3} #{4} #{5 6} #{7}]))
+  (is (= (stratification-list empty-graph empty-graph)
+         [#{}])))
+
 (comment
   (run-tests)
 )