Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add algorithm for simple cycles in a directed graph #126

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Add algorithm for simple cycles in a directed graph #126

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
76 changes: 76 additions & 0 deletions src/loom/alg.cljc
View file
Open in desktop
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
Open in desktop
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))))