From a9345d8e87cfdc1737b306ba0b2e326d25c448bc Mon Sep 17 00:00:00 2001 From: np Date: Tue, 21 Jan 2020 15:47:28 +0530 Subject: [PATCH] Add algorithm for simple cycles in a directed graph Test: - Add test for the algorithm --- src/loom/alg.cljc | 76 +++++++++++++++++++++++++++++++++++ test/loom/test/alg.cljc | 89 ++++++++++++++++++++++++++++++++++++++--- 2 files changed, 160 insertions(+), 5 deletions(-) diff --git a/src/loom/alg.cljc b/src/loom/alg.cljc index b3008b1..52abe0c 100644 --- a/src/loom/alg.cljc +++ b/src/loom/alg.cljc @@ -791,4 +791,80 @@ can use these functions." (graph/add-edges* (map (fn [[x y]] [(phi x) (phi y)]) (edges g1)))))) +(defn- insert-in-blocked-map + "Helper function for digraph-all-cycles. + When cycle is not found insert current node in + blocked-map of all of it's children" + [cycle-data curr children] + (reduce (fn [{:keys [bmap] :as acc} child] + (if (contains? bmap child) + (update-in acc [:bmap child] conj curr) + (assoc-in acc [:bmap child] #{curr}))) + cycle-data children)) + +(defn- unblock-nodes + "Helper function for digraph-all-cycles. + Unblock nodes from bset and bmap." + [{:keys [bmap] :as cycle-data} curr unblocked] + (if (contains? unblocked curr) + cycle-data + (as-> cycle-data cd + (update cd :bset disj curr) + (reduce (fn [acc node-to-unblock] + (unblock-nodes acc node-to-unblock (conj unblocked curr))) + cd (get bmap curr)) + (update cd :bmap dissoc curr)))) + +(defn- find-all-cycles + "Helper function for digraph-all-cycles. + Returns all cycles originating from a point 'start'" + [g start curr cycle path rset bset bmap] + (as-> {:cycle? cycle + :all-cycles [] + :bset (conj bset curr) + :rset rset + :bmap bmap} cycle-data + (reduce + (fn [{:keys [bset rset bmap]:as acc} child] + (cond + (= child start) (-> acc + (assoc :cycle? true) + (update :all-cycles conj path)) + + ;; Since cycle is found + (or (contains? rset child) + (contains? bset child)) acc + + :else + (let [new-acc (find-all-cycles g start child false (conj path child) + rset bset bmap)] + (-> new-acc + (update :cycle? #(or %1 %2) (:cycle? acc)) + (update :all-cycles concat (:all-cycles acc)))))) + ;; Function end + cycle-data (successors g curr)) + (if (:cycle? cycle-data) + ;; Last argument is unblocked set to avoid + ;; unblock-nodes function going into infinite loop + (unblock-nodes cycle-data curr #{}) + (insert-in-blocked-map cycle-data curr (successors g curr))))) + +(defn digraph-all-cycles + "This function returns all simple cycles present in a directed graph. + Implemented algorithm as mentioned in + https://www.cs.tufts.edu/comp/150GA/homeworks/hw1/Johnson%2075.PDF + " + [g] + (if (directed? g) + (as-> {:ans [] :rset #{}} cycle-data + (reduce (fn [{:keys [ans rset]} curr] + (let [{:keys [all-cycles rset]} + (find-all-cycles g curr curr false [curr] rset #{} {}) + updated-rset (conj rset curr)] + {:ans (concat ans all-cycles) + :rset updated-rset})) + + cycle-data (nodes g)) + (:ans cycle-data)) + ::not-a-directed-graph)) ;; ;; Todo: MST, coloring, matching, etc etc diff --git a/test/loom/test/alg.cljc b/test/loom/test/alg.cljc index 25d9565..e5e4794 100644 --- a/test/loom/test/alg.cljc +++ b/test/loom/test/alg.cljc @@ -13,7 +13,7 @@ coloring? greedy-coloring prim-mst-edges prim-mst-edges prim-mst astar-path astar-dist degeneracy-ordering maximal-cliques - subgraph? eql? isomorphism?]] + subgraph? eql? isomorphism? digraph-all-cycles]] [loom.derived :refer [mapped-by]] clojure.walk #?@(:clj [[clojure.test :refer :all]] @@ -190,6 +190,45 @@ :g :h )) +(def directed-graph1 (digraph [1 2] + [2 3] + [2 4] + [3 1] + [4 3])) + +(def directed-graph2 (digraph {1 [2 5 8] + 2 [3 7 9] + 3 [1 2 4 6] + 4 [5] + 5 [2] + 6 [4] + 8 [9] + 9 [8]})) + +(def directed-graph3 (digraph [1 2] + [1 5] + [2 4] + [2 5] + [2 7] + [3 2] + [3 7] + [4 1] + [4 3] + [4 7] + [5 6] + [5 7] + [6 1] + [6 2] + [6 4] + [7 1])) + +;; No cycles present here +(def directed-graph4 (digraph {1 [2 3] + 2 [4 5] + 3 [4 5] + 6 [1]})) + + (deftest depth-first-test (are [expected got] (= expected got) #{1 2 3 5 6 7} (set (pre-traverse g7)) @@ -214,7 +253,7 @@ [:g :a :b :c :f :e :d] (topsort g5) nil (topsort g7) [5 6 7] (topsort g7 5) - + [1 2 4] (topsort g15 1))) (deftest depth-first-test-2 @@ -234,7 +273,7 @@ #{:r :o :b :g :p} (set (bf-traverse g2 :r :when #(< %3 3))) [:a :e :j] (bf-path g4 :a :j) [:a :c :h :j] (bf-path g4 :a :j :when (fn [n p d] (not= :e n))) - + #?@(:clj [[:a :e :j] (bf-path-bi g4 :a :j) true (some #(= % (bf-path-bi g5 :g :d)) [[:g :a :b :d] [:g :f :e :d]])]))) @@ -464,13 +503,13 @@ [[:c :a 2] [:c :b 2]] (prim-mst-edges mst_wt_g5) [[:b :a 4] [:c :b 8] [:c :i 2] [:c :f 4] [:f :g 2] [:g :h 1] [:d :c 7] [:e :d 9]] (prim-mst-edges mst_wt_g6)) - + (are [solutions result] (contains? solutions result) #{(edge-sets [[:d :a 1] [:b :d 2] [:c :b 1] [:e :f 1]]) (edge-sets [[:d :a 1] [:a :b 2] [:c :b 1] [:e :f 1]])} (edge-sets (prim-mst-edges mst_wt_g2)) - + #{(edge-sets [[:c :a] [:d :b] [:c :d]]) (edge-sets [[:a :b] [:a :c] [:a :d]])} (edge-sets (prim-mst-edges mst_unweighted_g3))))) @@ -627,3 +666,43 @@ false (isomorphism? g7 (mapped-by inc g7) dec) false (isomorphism? (digraph) (graph) identity) false(isomorphism? (digraph [1 2]) (graph [1 2]) identity))) + +(deftest digraph-all-cycles-test + (testing "Check for Simple Cycle in directed graph" + (is (= (sort (map (comp vec sort) (digraph-all-cycles directed-graph1))) + (sort (map (comp vec sort) [[1 2 3] [1 2 4 3]])))) + (is (= (sort (map (comp vec sort) (digraph-all-cycles directed-graph2))) + (sort (map (comp vec sort) [[1 5 2 3] + [1 2 3] + [4 5 2 3 6] + [4 5 2 3] + [3 2] + [9 8]])))) + (is (= (sort (map (comp vec sort) (digraph-all-cycles directed-graph3))) + (sort (map (comp vec sort) [[7 1 5 6 2 4 3] + [7 1 5 6 2 4] + [7 1 5 6 2] + [7 1 5 6 4 3 2] + [7 1 5 6 4 3] + [7 1 5 6 4] + [7 1 5] + [7 1 2 5 6 4 3] + [7 1 2 5 6 4] + [7 1 2 5] + [7 1 2 4 3] + [7 1 2 4] + [7 1 2] + [1 5 6 2 4] + [1 5 6 4] + [1 5 6] + [1 2 5 6 4] + [1 2 5 6] + [1 2 4] + [4 3 2 5 6] + [4 3 2] + [6 2 5]]))))) + (testing "Check for no cycles present in directed graphs" + (is (= (digraph-all-cycles directed-graph4) + '()))) + (testing "Check for not a directed graph" + (is (= (digraph-all-cycles g6) :loom.alg/not-a-directed-graph))))