diff --git a/src/Constrained/Graph.hs b/src/Constrained/Graph.hs index d8a9018..232d4bd 100644 --- a/src/Constrained/Graph.hs +++ b/src/Constrained/Graph.hs @@ -25,7 +25,7 @@ module Constrained.Graph ( import Control.Monad import Data.Foldable -import Data.List (sortOn, nub) +import Data.List (nub) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe @@ -33,6 +33,8 @@ import Data.Set (Set) import Data.Set qualified as Set import Prettyprinter import Test.QuickCheck +-- TODO: consider using more of this +import Data.Graph qualified as G -- | A graph with unlabeled edges for keeping track of dependencies data Graph node = Graph @@ -166,21 +168,22 @@ topsort gr@(Graph e _) = go [] e removeNode n ds = Set.difference ds noDeps <$ guard (not $ n `Set.member` noDeps) if not $ null noDeps then go (Set.toList noDeps ++ order) (Map.mapMaybeWithKey removeNode g) - else Left . concat . take 1 . sortOn length . filter (not . null) . map (findCycle gr) $ Map.keys e + else Left $ findCycle gr -- | Simple DFS cycle finding -findCycle :: Ord node => Graph node -> node -> [node] -findCycle g@(Graph e _) node = concat . take 1 $ filter loopy $ go mempty node +findCycle :: Ord node => Graph node -> [node] +findCycle g@(Graph e _) = mkCycle . concat . take 1 . filter isCyclic . map (map tr) . concatMap cycles . G.scc $ gr where - loopy [] = False - loopy c@(x:_) = dependsOn (last c) x g - go seen n - | n `Set.member` seen = [[]] - | otherwise = do - n' <- neighbours - (n :) <$> go (Set.insert n seen) n' - where - neighbours = maybe [] Set.toList $ Map.lookup n e + edgeList = [ (n, n, Set.toList es) | (n, es) <- Map.toList e ] + (gr, tr0, _) = G.graphFromEdges edgeList + tr x = let (n, _, _) = tr0 x in n + cycles (G.Node a []) = [[a]] + cycles (G.Node a as) = (a:) <$> concatMap cycles as + isCyclic [] = False + isCyclic [a] = dependsOn a a g + isCyclic _ = True + -- Removes a non-dependent stem from the start of the dependencies + mkCycle ns = let l = last ns in dropWhile (\ n -> not $ dependsOn l n g) ns -- | Get the dependencies of a node in the graph, `mempty` if the node is not -- in the graph diff --git a/test/Constrained/GraphSpec.hs b/test/Constrained/GraphSpec.hs index 9c88a7a..efd236a 100644 --- a/test/Constrained/GraphSpec.hs +++ b/test/Constrained/GraphSpec.hs @@ -91,25 +91,20 @@ prop_topsort_sound g = prop_topsort_complete :: Graph Node -> Property prop_topsort_complete g = - isLeft (topsort g) === any (\ n -> not . null $ findCycle g n) (nodes g) + isLeft (topsort g) === not (null $ findCycle g) prop_find_cycle_sound :: Property prop_find_cycle_sound = forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g -> - and [ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 c)) - | n <- Set.toList $ nodes g - , let c = findCycle g n - ] + let c = findCycle g + in counterexample (show c) $ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 $ cycle c)) prop_find_cycle_loops :: Property prop_find_cycle_loops = forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \ g -> - conjoin - [ case findCycle g n of - [] -> property True - c@(x:_) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g - | n <- Set.toList $ nodes g - ] + case findCycle g of + [] -> property True + c@(x:_) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g return []