Skip to content

Commit

Permalink
Add algorithm for simple cycles in a directed graph
Browse files Browse the repository at this point in the history 
Test:
- Add test for the algorithm
  • Loading branch information
np committed Jan 21, 2020
1 parent bb9068c commit a9345d8
Show file tree
Hide file tree
Showing 2 changed files with 160 additions and 5 deletions.
76 changes: 76 additions & 0 deletions src/loom/alg.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
89 changes: 84 additions & 5 deletions test/loom/test/alg.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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]]
Expand Down Expand Up @@ -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))
Expand All @@ -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
Expand All @@ -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]])])))

Expand Down Expand Up @@ -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)))))
Expand Down Expand Up @@ -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))))

0 comments on commit a9345d8

Please sign in to comment.