From 66200bb3dd3a5296da219a553dd699dcf8148633 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Rey?= Date: Tue, 3 Jun 2014 14:14:48 +0200 Subject: [PATCH 1/4] Added pre-edge-traverse and post-edge-traverse functions. --- src/loom/alg_generic.clj | 48 ++++++++++++++++++++++++++++++ test/loom/test/alg_generic.clj | 53 ++++++++++++++++++++++++++++++++++ 2 files changed, 101 insertions(+) diff --git a/src/loom/alg_generic.clj b/src/loom/alg_generic.clj index 99140c3..7b1e5b2 100644 --- a/src/loom/alg_generic.clj +++ b/src/loom/alg_generic.clj @@ -62,6 +62,29 @@ (step [start] (conj seen start)))) +(defn pre-edge-traverse + "Traverses a graph depth-first preorder from start, successors being + a function that returns direct successors for the node. Returns a + lazy seq of edges, each edge being a vector [source-node dest-node]. + Note that for undirected graphs each edge will be returned twice, + once for each direction." + [successors start & {:keys [seen] :or {seen #{}}}] + (letfn [(step [successors start nbrs stack nbrstack seen] + (if-let [nbr (first nbrs)] + (cons + [start nbr] + (lazy-seq + (let [seen (conj seen start)] + (if (seen nbr) + (step successors start (next nbrs) stack nbrstack seen) + (step successors nbr (successors nbr) + (conj stack start) (conj nbrstack (next nbrs)) + seen))))) + (when-let [parent (peek stack)] + (recur successors parent (peek nbrstack) + (pop stack) (pop nbrstack) (conj seen start)))))] + (step successors start (successors start) [] [] (conj seen start)))) + ;; TODO: graph-seq, analog of tree-seq (defn pre-span @@ -100,6 +123,31 @@ (recur seen (conj result v) (pop stack)) (recur seen result (conj stack (first nbrs)))))))) +(defn post-edge-traverse + "Traverses a graph depth-first postorder from start, successors being + a function that returns direct successors for the node. Returns a + seq of edges, each edge being a vector [source-node dest-node]. + Note that for undirected graphs each edge will be returned twice, + once for each direction." + [successors start & {:keys [seen] :or {seen #{}}}] + (loop [start start + nbrs (successors start) + stack [] + nbrstack [] + seen seen + edges ()] + (let [seen (conj seen start)] + (if-let [nbr (first nbrs)] + (if (seen nbr) + (recur start (next nbrs) stack nbrstack seen (conj edges [start nbr])) + (recur nbr (successors nbr) + (conj stack start) (conj nbrstack (next nbrs)) + seen (conj edges [start nbr]))) + (if-let [parent (peek stack)] + (recur parent (peek nbrstack) + (pop stack) (pop nbrstack) seen edges) + edges))))) + (defn topsort-component "Topological sort of a component of a (presumably) directed graph. Returns nil if the graph contains any cycles. See loom.alg/topsort diff --git a/test/loom/test/alg_generic.clj b/test/loom/test/alg_generic.clj index a3ff4e5..a06d6b9 100644 --- a/test/loom/test/alg_generic.clj +++ b/test/loom/test/alg_generic.clj @@ -114,6 +114,20 @@ :e [:c :d :f] :f []}) +(def g4 ; like g3 with some loops + {:a [:b] + :b [:a :c :d] + :c [:b :c :e] + :d [:b :c :e] + :e [:c :d :f] + :f [:f]}) + +(def g5 ; like g1 but as an undirected graph + {:a [:b :c] + :b [:d :a] + :c [:a :d] + :d [:c :b]}) + (deftest tracing-paths (are [g n p] (= (sort (lag/trace-paths g n)) p) {:a nil} :a @@ -135,3 +149,42 @@ g3 :a :e [[:a :b :c :e] [:a :b :d :e]])) + +(deftest edge-traverse + (are [g start f expected] (= expected (f g start)) + g1 :a lag/pre-edge-traverse + '([:a :b] [:b :d] [:a :c] [:c :d]) + + g1 :a lag/post-edge-traverse + '([:c :d] [:a :c] [:b :d] [:a :b]) + + g1 :d lag/pre-edge-traverse + nil + + g1 :d lag/post-edge-traverse + () + + g4 :a lag/pre-edge-traverse + '([:a :b] [:b :a] [:b :c] [:c :b] [:c :c] [:c :e] [:e :c] [:e :d] [:d :b] [:d :c] [:d :e] [:e :f] [:f :f] [:b :d]) + + g4 :a lag/post-edge-traverse + '([:b :d] [:f :f] [:e :f] [:d :e] [:d :c] [:d :b] [:e :d] [:e :c] [:c :e] [:c :c] [:c :b] [:b :c] [:b :a] [:a :b]) + + g4 :c lag/pre-edge-traverse + '([:c :b] [:b :a] [:a :b] [:b :c] [:b :d] [:d :b] [:d :c] [:d :e] [:e :c] [:e :d] [:e :f] [:f :f] [:c :c] [:c :e]) + + g4 :c lag/post-edge-traverse + '([:c :e] [:c :c] [:f :f] [:e :f] [:e :d] [:e :c] [:d :e] [:d :c] [:d :b] [:b :d] [:b :c] [:a :b] [:b :a] [:c :b]) + + g4 :f lag/pre-edge-traverse + '([:f :f]) + + g4 :f lag/post-edge-traverse + '([:f :f]) + + g5 :a lag/pre-edge-traverse + '([:a :b] [:b :d] [:d :c] [:c :a] [:c :d] [:d :b] [:b :a] [:a :c]) + + g5 :a lag/post-edge-traverse + '([:a :c] [:b :a] [:d :b] [:c :d] [:c :a] [:d :c] [:b :d] [:a :b]) + )) From 004f5a0743004faefeb62db5ac63ffb069871482 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Rey?= Date: Tue, 3 Jun 2014 21:52:17 +0200 Subject: [PATCH 2/4] Improved edge-traverse test cases. --- test/loom/test/alg_generic.clj | 41 ++++++++-------------------------- 1 file changed, 9 insertions(+), 32 deletions(-) diff --git a/test/loom/test/alg_generic.clj b/test/loom/test/alg_generic.clj index a06d6b9..7599d59 100644 --- a/test/loom/test/alg_generic.clj +++ b/test/loom/test/alg_generic.clj @@ -151,40 +151,17 @@ [[:a :b :c :e] [:a :b :d :e]])) (deftest edge-traverse - (are [g start f expected] (= expected (f g start)) - g1 :a lag/pre-edge-traverse - '([:a :b] [:b :d] [:a :c] [:c :d]) + (are [g start expected] (= expected + (lag/pre-edge-traverse g start) + (seq (reverse (lag/post-edge-traverse g start)))) + g1 :a '([:a :b] [:b :d] [:a :c] [:c :d]) - g1 :a lag/post-edge-traverse - '([:c :d] [:a :c] [:b :d] [:a :b]) + g1 :d nil - g1 :d lag/pre-edge-traverse - nil + g4 :a '([:a :b] [:b :a] [:b :c] [:c :b] [:c :c] [:c :e] [:e :c] [:e :d] [:d :b] [:d :c] [:d :e] [:e :f] [:f :f] [:b :d]) - g1 :d lag/post-edge-traverse - () + g4 :c '([:c :b] [:b :a] [:a :b] [:b :c] [:b :d] [:d :b] [:d :c] [:d :e] [:e :c] [:e :d] [:e :f] [:f :f] [:c :c] [:c :e]) - g4 :a lag/pre-edge-traverse - '([:a :b] [:b :a] [:b :c] [:c :b] [:c :c] [:c :e] [:e :c] [:e :d] [:d :b] [:d :c] [:d :e] [:e :f] [:f :f] [:b :d]) + g4 :f '([:f :f]) - g4 :a lag/post-edge-traverse - '([:b :d] [:f :f] [:e :f] [:d :e] [:d :c] [:d :b] [:e :d] [:e :c] [:c :e] [:c :c] [:c :b] [:b :c] [:b :a] [:a :b]) - - g4 :c lag/pre-edge-traverse - '([:c :b] [:b :a] [:a :b] [:b :c] [:b :d] [:d :b] [:d :c] [:d :e] [:e :c] [:e :d] [:e :f] [:f :f] [:c :c] [:c :e]) - - g4 :c lag/post-edge-traverse - '([:c :e] [:c :c] [:f :f] [:e :f] [:e :d] [:e :c] [:d :e] [:d :c] [:d :b] [:b :d] [:b :c] [:a :b] [:b :a] [:c :b]) - - g4 :f lag/pre-edge-traverse - '([:f :f]) - - g4 :f lag/post-edge-traverse - '([:f :f]) - - g5 :a lag/pre-edge-traverse - '([:a :b] [:b :d] [:d :c] [:c :a] [:c :d] [:d :b] [:b :a] [:a :c]) - - g5 :a lag/post-edge-traverse - '([:a :c] [:b :a] [:d :b] [:c :d] [:c :a] [:d :c] [:b :d] [:a :b]) - )) + g5 :a '([:a :b] [:b :d] [:d :c] [:c :a] [:c :d] [:d :b] [:b :a] [:a :c]))) From b8a986727aa11db3a1cb46d2d1c40c2f6df66199 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Rey?= Date: Fri, 6 Jun 2014 14:41:09 +0200 Subject: [PATCH 3/4] post-edge-traverse can return seen nodes. --- src/loom/alg_generic.clj | 51 ++++++++++++++++------------ test/loom/test/alg_generic.clj | 62 +++++++++++++++++++++++++++++----- 2 files changed, 82 insertions(+), 31 deletions(-) diff --git a/src/loom/alg_generic.clj b/src/loom/alg_generic.clj index 7b1e5b2..e51f5ce 100644 --- a/src/loom/alg_generic.clj +++ b/src/loom/alg_generic.clj @@ -80,10 +80,11 @@ (step successors nbr (successors nbr) (conj stack start) (conj nbrstack (next nbrs)) seen))))) - (when-let [parent (peek stack)] - (recur successors parent (peek nbrstack) - (pop stack) (pop nbrstack) (conj seen start)))))] - (step successors start (successors start) [] [] (conj seen start)))) + (when-let [parent (peek stack)] + (recur successors parent (peek nbrstack) + (pop stack) (pop nbrstack) (conj seen start)))))] + (when-not (seen start) + (step successors start (successors start) [] [] (conj seen start))))) ;; TODO: graph-seq, analog of tree-seq @@ -129,24 +130,30 @@ seq of edges, each edge being a vector [source-node dest-node]. Note that for undirected graphs each edge will be returned twice, once for each direction." - [successors start & {:keys [seen] :or {seen #{}}}] - (loop [start start - nbrs (successors start) - stack [] - nbrstack [] - seen seen - edges ()] - (let [seen (conj seen start)] - (if-let [nbr (first nbrs)] - (if (seen nbr) - (recur start (next nbrs) stack nbrstack seen (conj edges [start nbr])) - (recur nbr (successors nbr) - (conj stack start) (conj nbrstack (next nbrs)) - seen (conj edges [start nbr]))) - (if-let [parent (peek stack)] - (recur parent (peek nbrstack) - (pop stack) (pop nbrstack) seen edges) - edges))))) + [successors start & {:keys [seen return-seen] :or {seen #{}}}] + (if (seen start) + (if return-seen + [nil seen] + nil) + (loop [start start + nbrs (successors start) + stack [] + nbrstack [] + seen seen + edges ()] + (let [seen (conj seen start)] + (if-let [nbr (first nbrs)] + (if (seen nbr) + (recur start (next nbrs) stack nbrstack seen (conj edges [start nbr])) + (recur nbr (successors nbr) + (conj stack start) (conj nbrstack (next nbrs)) + seen (conj edges [start nbr]))) + (if-let [parent (peek stack)] + (recur parent (peek nbrstack) + (pop stack) (pop nbrstack) seen edges) + (if return-seen + [edges seen] + edges))))))) (defn topsort-component "Topological sort of a component of a (presumably) directed graph. diff --git a/test/loom/test/alg_generic.clj b/test/loom/test/alg_generic.clj index 7599d59..6ca8657 100644 --- a/test/loom/test/alg_generic.clj +++ b/test/loom/test/alg_generic.clj @@ -1,5 +1,6 @@ (ns loom.test.alg-generic (:require [loom.alg-generic :as lag] + [loom.graph :as g] [clojure.set :as set] [clojure.test :refer [deftest are]] [clojure.test.check :as tc] @@ -128,6 +129,14 @@ :c [:a :d] :d [:c :b]}) +(def g6 ; unconnected with some loops + {:a [:a] + :b [:a :c] + :c [:b :c] + :d [:e] + :e [:d :f] + :f [:f]}) + (deftest tracing-paths (are [g n p] (= (sort (lag/trace-paths g n)) p) {:a nil} :a @@ -151,17 +160,52 @@ [[:a :b :c :e] [:a :b :d :e]])) (deftest edge-traverse - (are [g start expected] (= expected - (lag/pre-edge-traverse g start) - (seq (reverse (lag/post-edge-traverse g start)))) - g1 :a '([:a :b] [:b :d] [:a :c] [:c :d]) - + ; works with nodes without outgoing edges or just a loop to iself + (are [g start expected] (let [pre (lag/pre-edge-traverse g start) + post (lag/post-edge-traverse g start)] + (= expected pre (seq (reverse post)))) g1 :d nil - g4 :a '([:a :b] [:b :a] [:b :c] [:c :b] [:c :c] [:c :e] [:e :c] [:e :d] [:d :b] [:d :c] [:d :e] [:e :f] [:f :f] [:b :d]) + g4 :f '([:f :f])) + ; covers the whole graph when it's totally connected from start + (are [g start expected] (let [pre (lag/pre-edge-traverse g start) + post (lag/post-edge-traverse g start) + dg (g/digraph g) + edges (g/edges dg)] + (and + (= expected pre (seq (reverse post))) + (= (count edges) (count post)) + (= (set edges) (set post)))) + g1 :a '([:a :b] [:b :d] [:a :c] [:c :d]) - g4 :c '([:c :b] [:b :a] [:a :b] [:b :c] [:b :d] [:d :b] [:d :c] [:d :e] [:e :c] [:e :d] [:e :f] [:f :f] [:c :c] [:c :e]) + g4 :a '([:a :b] [:b :a] [:b :c] [:c :b] [:c :c] [:c :e] [:e :c] + [:e :d] [:d :b] [:d :c] [:d :e] [:e :f] [:f :f] [:b :d]) - g4 :f '([:f :f]) + g4 :c '([:c :b] [:b :a] [:a :b] [:b :c] [:b :d] [:d :b] [:d :c] + [:d :e] [:e :c] [:e :d] [:e :f] [:f :f] [:c :c] [:c :e]) - g5 :a '([:a :b] [:b :d] [:d :c] [:c :a] [:c :d] [:d :b] [:b :a] [:a :c]))) + g5 :a '([:a :b] [:b :d] [:d :c] [:c :a] + [:c :d] [:d :b] [:b :a] [:a :c])) + ; post traversal returning seen nodes allows complete graph coverage + ; without duplicates when iterating on all nodes of the graph + (are [g] (let [dg (g/digraph g) + edges (g/edges dg) + loop-post-traverse + (loop [nodes (g/nodes dg) + seen #{} + acc ()] + (if-let [node (first nodes)] + (let [[edges seen] + (lag/post-edge-traverse + g + node + :seen seen + :return-seen true)] + (recur (next nodes) + seen + (concat acc edges))) + acc))] + (and + (= (count edges) (count loop-post-traverse)) + (= (set edges) (set loop-post-traverse)))) + g1 g2 g3 g4 g5 g6)) \ No newline at end of file From 0ce45ac2da930a708259d714b7b4810fdc018397 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Rey?= Date: Fri, 6 Jun 2014 19:18:42 +0200 Subject: [PATCH 4/4] Made post-edge-reverse test a bit more interesting. --- test/loom/test/alg_generic.clj | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/test/loom/test/alg_generic.clj b/test/loom/test/alg_generic.clj index 6ca8657..e9f0d82 100644 --- a/test/loom/test/alg_generic.clj +++ b/test/loom/test/alg_generic.clj @@ -191,7 +191,9 @@ (are [g] (let [dg (g/digraph g) edges (g/edges dg) loop-post-traverse - (loop [nodes (g/nodes dg) + (loop [nodes (reverse (g/nodes dg)) + ; reverse makes this more interesting as graphs + ; are often specified in the forward direction seen #{} acc ()] (if-let [node (first nodes)]