Mercurial > lasercutter

annotate src/clojure/contrib/test_contrib/test_graph.clj @ 10:ef7dbbd6452c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
added clojure source goodness
author Robert McIntyre <rlm@mit.edu>
date Sat, 21 Aug 2010 06:25:44 -0400
parents
children
rev   line source
rlm@10 1 ;; Copyright (c) Jeffrey Straszheim. All rights reserved. The use and
rlm@10 2 ;; distribution terms for this software are covered by the Eclipse Public
rlm@10 3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
rlm@10 4 ;; be found in the file epl-v10.html at the root of this distribution. By
rlm@10 5 ;; using this software in any fashion, you are agreeing to be bound by the
rlm@10 6 ;; terms of this license. You must not remove this notice, or any other,
rlm@10 7 ;; from this software.
rlm@10 8 ;;
rlm@10 9 ;; test-graph
rlm@10 10 ;;
rlm@10 11 ;; Basic Graph Theory Algorithms Tests
rlm@10 12 ;;
rlm@10 13 ;; straszheimjeffrey (gmail)
rlm@10 14 ;; Created 23 June 2009
rlm@10 15
rlm@10 16 (ns clojure.contrib.test-graph
rlm@10 17 (use clojure.test
rlm@10 18 clojure.contrib.graph))
rlm@10 19
rlm@10 20
rlm@10 21 (def empty-graph (struct directed-graph #{} {}))
rlm@10 22
rlm@10 23 (def test-graph-1
rlm@10 24 (struct directed-graph
rlm@10 25 #{:a :b :c :d :e}
rlm@10 26 {:a #{:b :c}
rlm@10 27 :b #{:a :c}
rlm@10 28 :c #{:d :e}
rlm@10 29 :d #{:a :b}
rlm@10 30 :e #{:d}}))
rlm@10 31
rlm@10 32 (deftest test-reverse-graph
rlm@10 33 (is (= (reverse-graph test-graph-1)
rlm@10 34 (struct directed-graph
rlm@10 35 #{:a :b :c :d :e}
rlm@10 36 {:c #{:b :a}
rlm@10 37 :e #{:c}
rlm@10 38 :d #{:c :e}
rlm@10 39 :b #{:d :a}
rlm@10 40 :a #{:d :b}})))
rlm@10 41 (is (= (reverse-graph (reverse-graph test-graph-1))
rlm@10 42 test-graph-1))
rlm@10 43 (is (= (reverse-graph empty-graph) empty-graph)))
rlm@10 44
rlm@10 45 (deftest test-add-loops
rlm@10 46 (let [tg1 (add-loops test-graph-1)]
rlm@10 47 (is (every? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1))))
rlm@10 48 (is (= (add-loops empty-graph) empty-graph)))
rlm@10 49
rlm@10 50 (deftest test-remove-loops
rlm@10 51 (let [tg1 (remove-loops (add-loops test-graph-1))]
rlm@10 52 (is (not-any? (fn [n] (contains? (get-neighbors tg1 n) n)) (:nodes tg1))))
rlm@10 53 (is (= (remove-loops empty-graph) empty-graph)))
rlm@10 54
rlm@10 55
rlm@10 56 (def test-graph-2
rlm@10 57 (struct directed-graph
rlm@10 58 #{:a :b :c :d :e :f :g :h :i :j}
rlm@10 59 {:a #{:b :c}
rlm@10 60 :b #{:a :c}
rlm@10 61 :c #{:d :e}
rlm@10 62 :d #{:a :b}
rlm@10 63 :e #{:d}
rlm@10 64 :f #{:f}
rlm@10 65 :g #{:a :f}
rlm@10 66 :h #{}
rlm@10 67 :i #{:j}
rlm@10 68 :j #{:i}}))
rlm@10 69
rlm@10 70
rlm@10 71 (deftest test-lazy-walk
rlm@10 72 (is (= (lazy-walk test-graph-2 :h) [:h]))
rlm@10 73 (is (= (lazy-walk test-graph-2 :j) [:j :i])))
rlm@10 74
rlm@10 75 (deftest test-transitive-closure
rlm@10 76 (let [tc-1 (transitive-closure test-graph-1)
rlm@10 77 tc-2 (transitive-closure test-graph-2)
rlm@10 78 get (fn [n] (set (get-neighbors tc-2 n)))]
rlm@10 79 (is (every? #(= #{:a :b :c :d :e} (set %))
rlm@10 80 (map (partial get-neighbors tc-1) (:nodes tc-1))))
rlm@10 81 (is (= (get :a) #{:a :b :c :d :e}))
rlm@10 82 (is (= (get :h) #{}))
rlm@10 83 (is (= (get :j) #{:i :j}))
rlm@10 84 (is (= (get :g) #{:a :b :c :d :e :f}))))
rlm@10 85
rlm@10 86
rlm@10 87 (deftest test-post-ordered-nodes
rlm@10 88 (is (= (set (post-ordered-nodes test-graph-2))
rlm@10 89 #{:a :b :c :d :e :f :g :h :i :j}))
rlm@10 90 (is (empty? (post-ordered-nodes empty-graph))))
rlm@10 91
rlm@10 92
rlm@10 93 (deftest test-scc
rlm@10 94 (is (= (set (scc test-graph-2))
rlm@10 95 #{#{:h} #{:g} #{:i :j} #{:b :c :a :d :e} #{:f}}))
rlm@10 96 (is (empty? (scc empty-graph))))
rlm@10 97
rlm@10 98 (deftest test-component-graph
rlm@10 99 (let [cg (component-graph test-graph-2)
rlm@10 100 ecg (component-graph empty-graph)]
rlm@10 101 (is (= (:nodes cg) (set (scc test-graph-2))))
rlm@10 102 (is (= (get-neighbors cg #{:a :b :c :d :e})
rlm@10 103 #{#{:a :b :c :d :e}}))
rlm@10 104 (is (= (get-neighbors cg #{:g})
rlm@10 105 #{#{:a :b :c :d :e} #{:f}}))
rlm@10 106 (is (= (get-neighbors cg #{:i :j})
rlm@10 107 #{#{:i :j}}))
rlm@10 108 (is (= (get-neighbors cg #{:h})
rlm@10 109 #{}))
rlm@10 110 (is (= (apply max (map count (self-recursive-sets cg))) 1))
rlm@10 111 (is (= ecg empty-graph))))
rlm@10 112
rlm@10 113
rlm@10 114 (deftest test-recursive-component?
rlm@10 115 (let [sccs (scc test-graph-2)]
rlm@10 116 (is (= (set (filter (partial recursive-component? test-graph-2) sccs))
rlm@10 117 #{#{:i :j} #{:b :c :a :d :e} #{:f}}))))
rlm@10 118
rlm@10 119
rlm@10 120 (deftest test-self-recursive-sets
rlm@10 121 (is (= (set (self-recursive-sets test-graph-2))
rlm@10 122 (set (filter
rlm@10 123 (partial recursive-component? test-graph-2)
rlm@10 124 (scc test-graph-2)))))
rlm@10 125 (is (empty? (self-recursive-sets empty-graph))))
rlm@10 126
rlm@10 127
rlm@10 128 (def test-graph-3
rlm@10 129 (struct directed-graph
rlm@10 130 #{:a :b :c :d :e :f}
rlm@10 131 {:a #{:b}
rlm@10 132 :b #{:c}
rlm@10 133 :c #{:d}
rlm@10 134 :d #{:e}
rlm@10 135 :e #{:f}
rlm@10 136 :f #{}}))
rlm@10 137
rlm@10 138 (def test-graph-4
rlm@10 139 (struct directed-graph
rlm@10 140 #{:a :b :c :d :e :f :g :h}
rlm@10 141 {:a #{}
rlm@10 142 :b #{:a}
rlm@10 143 :c #{:a}
rlm@10 144 :d #{:a :b}
rlm@10 145 :e #{:d :c}
rlm@10 146 :f #{:e}
rlm@10 147 :g #{:d}
rlm@10 148 :h #{:f}}))
rlm@10 149
rlm@10 150 (def test-graph-5
rlm@10 151 (struct directed-graph
rlm@10 152 #{:a :b :c :d :e :f :g :h}
rlm@10 153 {:a #{}
rlm@10 154 :b #{}
rlm@10 155 :c #{:b}
rlm@10 156 :d #{}
rlm@10 157 :e #{}
rlm@10 158 :f #{}
rlm@10 159 :g #{:f}
rlm@10 160 :h #{}}))
rlm@10 161
rlm@10 162 (deftest test-dependency-list
rlm@10 163 (is (thrown-with-msg? Exception #".*Fixed point overflow.*"
rlm@10 164 (dependency-list test-graph-2)))
rlm@10 165 (is (= (dependency-list test-graph-3)
rlm@10 166 [#{:f} #{:e} #{:d} #{:c} #{:b} #{:a}]))
rlm@10 167 (is (= (dependency-list test-graph-4)
rlm@10 168 [#{:a} #{:b :c} #{:d} #{:g :e} #{:f} #{:h}]))
rlm@10 169 (is (= (dependency-list test-graph-5)
rlm@10 170 [#{:f :b :a :d :h :e} #{:g :c}]))
rlm@10 171 (is (= (dependency-list empty-graph)
rlm@10 172 [#{}])))
rlm@10 173
rlm@10 174 (deftest test-stratification-list
rlm@10 175 (is (thrown-with-msg? Exception #".*Fixed point overflow.*"
rlm@10 176 (stratification-list test-graph-2 test-graph-2)))
rlm@10 177 (is (= (stratification-list test-graph-4 test-graph-5)
rlm@10 178 [#{:a} #{:b :c} #{:d} #{:e} #{:f :g} #{:h}]))
rlm@10 179 (is (= (stratification-list empty-graph empty-graph)
rlm@10 180 [#{}])))
rlm@10 181
rlm@10 182 (comment
rlm@10 183 (run-tests)
rlm@10 184 )
rlm@10 185
rlm@10 186
rlm@10 187 ;; End of file