topsortable graphs a lot of the time

Author: MaximilianAlgehed

src/Constrained/Graph.hs

@@ -25,7 +25,7 @@ module Constrained.Graph (
 
 import Control.Monad
 import Data.Foldable
-import Data.List (sortOn)
+import Data.List (sortOn, nub)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe
@@ -72,8 +72,17 @@ mkGraph e0 = Graph e $ Map.unionsWith (<>)
                                                 ])
 
 instance (Arbitrary node, Ord node) => Arbitrary (Graph node) where
-  -- TODO: very high % of these graphs don't topsort nicely
-  arbitrary = mkGraph <$> arbitrary
+  arbitrary =
+    frequency [ (1, mkGraph <$> arbitrary)
+              , (3, do order <- nub <$> arbitrary
+                       mkGraph <$> buildGraph order
+                )
+              ]
+    where buildGraph [] = return mempty
+          buildGraph [n] = return (Map.singleton n mempty)
+          buildGraph (n:ns) = do
+            deps <- listOf (elements ns)
+            Map.insert n (Set.fromList deps) <$> buildGraph ns
   shrink g =
     [ mkGraph e'
     | e <- shrink (edges g)

test/Constrained/GraphSpec.hs

@@ -40,18 +40,18 @@ prop_op_topsort g =
 
 prop_trC_topsort :: Graph Node -> Property
 prop_trC_topsort g =
-  within 1_000_000 $ isRight (topsort g) === isRight (topsort $ transitiveClosure g)
+  isRight (topsort g) === isRight (topsort $ transitiveClosure g)
 
 prop_trC_opgraph_commute :: Graph Node -> Property
 prop_trC_opgraph_commute g =
-  within 1_000_000 $ transitiveClosure (opGraph g) === opGraph (transitiveClosure g)
+  transitiveClosure (opGraph g) === opGraph (transitiveClosure g)
 
 prop_depends_grows :: Graph Node -> Graph Node -> Node -> Property
 prop_depends_grows g g' n = property $ dependencies n g `Set.isSubsetOf` dependencies n (g <> g')
 
 prop_transitive_dependencies :: Graph Node -> Node -> Property
 prop_transitive_dependencies g n =
-  within 1_000_000 $ transitiveDependencies n g === dependencies n (transitiveClosure g)
+  transitiveDependencies n g === dependencies n (transitiveClosure g)
 
 prop_topsort_all_nodes :: Graph Node -> Property
 prop_topsort_all_nodes g =
@@ -71,12 +71,12 @@ prop_topsort_sound g =
 tests :: Bool -> Spec
 tests _nightly =
   describe "Graph tests" $ do
-    prop "prop_no_dependencies_topsort" prop_no_dependencies_topsort
-    prop "prop_subtract_topsort"        prop_subtract_topsort
-    prop "prop_delete_topsort"          prop_delete_topsort
-    prop "prop_op_topsort"              prop_op_topsort
-    prop "prop_trC_topsort"             prop_trC_topsort
-    prop "prop_trC_opgraph_commute"     prop_trC_opgraph_commute
-    prop "prop_depends_grows"           prop_depends_grows
-    prop "prop_topsort_all_nodes"       prop_topsort_all_nodes
-    prop "prop_topsort_sound"           prop_topsort_sound
+    prop "prop_no_dependencies_topsort" $ withMaxSuccess 10000 prop_no_dependencies_topsort
+    prop "prop_subtract_topsort"        $ withMaxSuccess 10000 prop_subtract_topsort
+    prop "prop_delete_topsort"          $ withMaxSuccess 10000 prop_delete_topsort
+    prop "prop_op_topsort"              $ withMaxSuccess 10000 prop_op_topsort
+    prop "prop_trC_topsort"             $ withMaxSuccess 10000 prop_trC_topsort
+    prop "prop_trC_opgraph_commute"     $ withMaxSuccess 10000 prop_trC_opgraph_commute
+    prop "prop_depends_grows"           $ withMaxSuccess 10000 prop_depends_grows
+    prop "prop_topsort_all_nodes"       $ withMaxSuccess 10000 prop_topsort_all_nodes
+    prop "prop_topsort_sound"           $ withMaxSuccess 10000 prop_topsort_sound