diff options
Diffstat (limited to 'tests/Data')
-rw-r--r-- | tests/Data/Graph/Dynamic/Action.hs | 78 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/EulerTour/Tests.hs | 77 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Internal/Avl/Tests.hs | 22 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Internal/Random/Tests.hs | 22 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Internal/Splay/Tests.hs | 22 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Internal/Tree/Tests.hs | 121 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Levels/Tests.hs | 83 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Program.hs | 232 | ||||
-rw-r--r-- | tests/Data/Graph/Dynamic/Slow.hs | 120 |
9 files changed, 777 insertions, 0 deletions
diff --git a/tests/Data/Graph/Dynamic/Action.hs b/tests/Data/Graph/Dynamic/Action.hs new file mode 100644 index 0000000..cab2ce6 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Action.hs @@ -0,0 +1,78 @@ +-- | Generate arbitrary "actions" (cut, link...) to test the connectivity +-- algorithms. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +module Data.Graph.Dynamic.Action + ( ActionType (..) + , Action (..) + + , runSlowForestAction + , runSlowGraphAction + ) where + +import qualified Data.Graph.Dynamic.Slow as Slow +import Data.Hashable (Hashable) +import Test.QuickCheck + +data ActionType = LinkCut | Toggl + +data Action (t :: ActionType) v where + Cut :: !v -> !v -> Action 'LinkCut v + Link :: !v -> !v -> Action 'LinkCut v + Toggle :: !v -> !v -> Action 'Toggl v + Query :: !v -> !v -> Action a v + +deriving instance Show v => Show (Action t v) + +deriving instance Functor (Action t) + +instance Arbitrary v => Arbitrary (Action 'LinkCut v) where + arbitrary = oneof + [ Cut <$> arbitrary <*> arbitrary + , Link <$> arbitrary <*> arbitrary + , Query <$> arbitrary <*> arbitrary + ] + shrink (Link a b) = Link <$> shrink a <*> shrink b + shrink (Cut a b) = Cut <$> shrink a <*> shrink b + shrink (Query a b) = Query <$> shrink a <*> shrink b + +instance Arbitrary v => Arbitrary (Action 'Toggl v) where + arbitrary = oneof + [ Toggle <$> arbitrary <*> arbitrary + , Query <$> arbitrary <*> arbitrary + ] + shrink (Toggle a b) = Toggle <$> shrink a <*> shrink b + shrink (Query a b) = Query <$> shrink a <*> shrink b + +runSlowForestAction + :: (Eq v, Hashable v) + => Slow.Graph v -> Action t v -> (Slow.Graph v, Maybe Bool) +runSlowForestAction graph (Cut x y) = + (Slow.cut x y graph, Nothing) +runSlowForestAction graph (Link x y) + | Slow.connected x y graph = (graph, Nothing) + | otherwise = (Slow.link x y graph, Nothing) +runSlowForestAction graph (Toggle x y) + | Slow.edge x y graph = (Slow.cut x y graph, Nothing) + | Slow.connected x y graph = (graph, Nothing) + | otherwise = (Slow.link x y graph, Nothing) +runSlowForestAction graph (Query x y) = + (graph, Just (Slow.connected x y graph)) + +runSlowGraphAction + :: (Eq v, Hashable v) + => Slow.Graph v -> Action t v -> (Slow.Graph v, Maybe Bool) +runSlowGraphAction graph (Cut x y) = + (Slow.cut x y graph, Nothing) +runSlowGraphAction graph (Link x y) = + (Slow.link x y graph, Nothing) +runSlowGraphAction graph (Toggle x y) + | Slow.edge x y graph = (Slow.cut x y graph, Nothing) + | otherwise = (Slow.link x y graph, Nothing) +runSlowGraphAction graph (Query x y) = + (graph, Just (Slow.connected x y graph)) diff --git a/tests/Data/Graph/Dynamic/EulerTour/Tests.hs b/tests/Data/Graph/Dynamic/EulerTour/Tests.hs new file mode 100644 index 0000000..0a74cbd --- /dev/null +++ b/tests/Data/Graph/Dynamic/EulerTour/Tests.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Data.Graph.Dynamic.EulerTour.Tests where + +import Control.Monad (foldM, forM_) +import Control.Monad.ST +import Data.Graph.Dynamic.Action +import qualified Data.Graph.Dynamic.EulerTour as ET +import Data.Graph.Dynamic.Internal.Tree (Tree) +import qualified Data.Graph.Dynamic.Program as Program +import qualified Data.Graph.Dynamic.Slow as Slow +import Data.Hashable (Hashable) +import Data.List (mapAccumL, foldl') +import Data.Maybe (catMaybes) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.TH +import qualified Test.QuickCheck as QC + +runForestAction + :: (Eq v, Hashable v, Monoid a, Tree tree) + => ET.Forest tree a s v -> [Bool] -> Action t v -> ST s [Bool] +runForestAction etf xs (Cut x y) = ET.cut etf x y >> return xs +runForestAction etf xs (Link x y) = ET.link etf x y >> return xs +runForestAction etf xs (Toggle x y) = ET.edge etf x y >>= \case + True -> ET.cut etf x y >> return xs + False -> ET.link etf x y >> return xs +runForestAction etf xs (Query x y) = + ET.connected etf x y >>= \q -> return (q:xs) + +checkActions :: QC.Positive Int -> [Action t Int] -> QC.Property +checkActions (QC.Positive n) actions = slowResult QC.=== result + where + actions' = map (fmap (`mod` n)) actions + initialGraph = Slow.edgeless [0..n-1] + slowResult = catMaybes $ snd $ mapAccumL runSlowForestAction initialGraph actions' + result :: [Bool] + result = runST $ do + initialForest <- ET.edgeless' [0..n-1] + results <- foldM (runForestAction initialForest) [] actions' + return $ reverse results + +prop_forest_linkcut :: QC.Positive Int -> [Action 'LinkCut Int] -> QC.Property +prop_forest_linkcut = checkActions + +prop_forest_toggle :: QC.Positive Int -> [Action 'Toggl Int] -> QC.Property +prop_forest_toggle = checkActions + +prop_program :: Program.IntTreeProgram -> () +prop_program (Program.IntTreeProgram p) = runST $ do + f <- ET.empty' + Program.runProgram f p + +prop_spanningTree :: QC.Positive Int -> [Action 'LinkCut Int] -> QC.Property +prop_spanningTree (QC.Positive n) actions = + Slow.isSpanningForest spanningForest slow QC.=== True + where + actions' = map (fmap (`mod` n)) actions + + spanningForest = runST $ do + et <- ET.edgeless' [0 .. n - 1] + forM_ actions' $ \action -> runForestAction et [] action + ET.spanningForest et + + slow = foldl' + (\g a -> fst $ runSlowForestAction g a) + (Slow.edgeless [0 .. n - 1]) + actions' + +tests :: Test +tests = $testGroupGenerator diff --git a/tests/Data/Graph/Dynamic/Internal/Avl/Tests.hs b/tests/Data/Graph/Dynamic/Internal/Avl/Tests.hs new file mode 100644 index 0000000..156e494 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Internal/Avl/Tests.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Graph.Dynamic.Internal.Avl.Tests + ( tests + ) where + +import qualified Data.Graph.Dynamic.Internal.Avl as Avl +import qualified Data.Graph.Dynamic.Internal.Tree.Tests as Class +import Data.Monoid (Sum) +import Data.Proxy (Proxy (..)) +import Test.Framework (Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.TH (testGroupGenerator) +import qualified Test.QuickCheck as QC + +prop_append :: Class.BuildTree Int (Sum Int) -> QC.Property +prop_append = Class.prop_build (Proxy :: Proxy Avl.Tree) + +prop_split :: Int -> Class.BuildTree Int () -> QC.Property +prop_split = Class.prop_split (Proxy :: Proxy Avl.Tree) + +tests :: Test +tests = $(testGroupGenerator) diff --git a/tests/Data/Graph/Dynamic/Internal/Random/Tests.hs b/tests/Data/Graph/Dynamic/Internal/Random/Tests.hs new file mode 100644 index 0000000..b8986a5 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Internal/Random/Tests.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Graph.Dynamic.Internal.Random.Tests + ( tests + ) where + +import qualified Data.Graph.Dynamic.Internal.Random as Random +import qualified Data.Graph.Dynamic.Internal.Tree.Tests as Class +import Data.Monoid (Sum) +import Data.Proxy (Proxy (..)) +import Test.Framework (Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.TH (testGroupGenerator) +import qualified Test.QuickCheck as QC + +prop_append :: Class.BuildTree Int (Sum Int) -> QC.Property +prop_append = Class.prop_build (Proxy :: Proxy Random.Tree) + +prop_split :: Int -> Class.BuildTree Int (Sum Int) -> QC.Property +prop_split = Class.prop_split (Proxy :: Proxy Random.Tree) + +tests :: Test +tests = $(testGroupGenerator) diff --git a/tests/Data/Graph/Dynamic/Internal/Splay/Tests.hs b/tests/Data/Graph/Dynamic/Internal/Splay/Tests.hs new file mode 100644 index 0000000..767f9e2 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Internal/Splay/Tests.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.Graph.Dynamic.Internal.Splay.Tests + ( tests + ) where + +import qualified Data.Graph.Dynamic.Internal.Splay as Splay +import qualified Data.Graph.Dynamic.Internal.Tree.Tests as Class +import Data.Monoid (Sum) +import Data.Proxy (Proxy (..)) +import Test.Framework (Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.TH (testGroupGenerator) +import qualified Test.QuickCheck as QC + +prop_append :: Class.BuildTree Int (Sum Int) -> QC.Property +prop_append = Class.prop_build (Proxy :: Proxy Splay.Tree) + +prop_split :: Int -> Class.BuildTree Int (Sum Int) -> QC.Property +prop_split = Class.prop_split (Proxy :: Proxy Splay.Tree) + +tests :: Test +tests = $(testGroupGenerator) diff --git a/tests/Data/Graph/Dynamic/Internal/Tree/Tests.hs b/tests/Data/Graph/Dynamic/Internal/Tree/Tests.hs new file mode 100644 index 0000000..c3f7b27 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Internal/Tree/Tests.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Graph.Dynamic.Internal.Tree.Tests + ( BuildTree + , prop_build + , prop_split + ) where + +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.ST (runST) +import Data.Graph.Dynamic.Internal.Tree +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy (Proxy) +import Data.Semigroup ((<>)) +import qualified Test.QuickCheck as QC + +data BuildTree a v + = Singleton a v + | Append (BuildTree a v) (BuildTree a v) + | Snoc (BuildTree a v) a v + | Cons a v (BuildTree a v) + deriving (Show) + +arbitraryBuildTree + :: (QC.Arbitrary a, QC.Arbitrary v) => Int -> QC.Gen (BuildTree a v) +arbitraryBuildTree n + | n <= 0 = Singleton <$> QC.arbitrary <*> QC.arbitrary + | otherwise = QC.oneof + [ Singleton <$> QC.arbitrary <*> QC.arbitrary + , Append <$> arbitraryBuildTree (n - 1) <*> arbitraryBuildTree (n - 1) + , Snoc <$> arbitraryBuildTree (n - 1) <*> QC.arbitrary <*> QC.arbitrary + , Cons <$> QC.arbitrary <*> QC.arbitrary <*> arbitraryBuildTree (n - 1) + ] + +instance (QC.Arbitrary a, QC.Arbitrary v) => QC.Arbitrary (BuildTree a v) where + arbitrary = QC.sized arbitraryBuildTree + + shrink (Singleton _ _) = [] + shrink (Snoc l a v) = [l] ++ [Snoc l' a v | l' <- QC.shrink l] + shrink (Cons a v r) = [r] ++ [Cons a v r' | r' <- QC.shrink r] + shrink (Append l r) = + [l, r] ++ + [Append l' r | l' <- QC.shrink l] ++ + [Append l r' | r' <- QC.shrink r] + +-- | Returns pointers to all nodes. +appendsToTree + :: (Tree t, PrimMonad m, Monoid v) + => Proxy t + -> TreeGen t (PrimState m) + -> BuildTree a v + -> m (t (PrimState m) a v, NonEmpty (t (PrimState m) a v)) +appendsToTree _proxy gen = go + where + go (Singleton a v) = do + s <- singleton gen a v + return (s, s NonEmpty.:| []) + go (Snoc b a v) = do + (l, lps) <- go b + s <- singleton gen a v + rt <- l `snoc` s + return (rt, lps <> (s NonEmpty.:| [])) + go (Cons a v b) = do + s <- singleton gen a v + (r, rps) <- go b + rt <- s `cons` r + return (rt, (s NonEmpty.:| []) <> rps) + go (Append bl br) = do + (l, lps) <- go bl + (r, rps) <- go br + rt <- append l r + return (rt, lps <> rps) + +appendsToList :: BuildTree a v -> [a] +appendsToList (Singleton a _) = [a] +appendsToList (Snoc l a _) = appendsToList l ++ [a] +appendsToList (Cons a _ r) = [a] ++ appendsToList r +appendsToList (Append l r) = appendsToList l ++ appendsToList r + +prop_build + :: (TestTree t, Eq a, Show a, Eq v, Monoid v, Show v) + => Proxy t -> BuildTree a v -> QC.Property +prop_build proxy appends = runST $ do + gen <- newTreeGen proxy + (t, _) <- appendsToTree proxy gen appends + assertInvariants t + + l <- toList t + return $ l QC.=== appendsToList appends + +prop_split + :: (TestTree t, Eq a, Show a, Eq v, Monoid v, Show v) + => Proxy t -> Int -> BuildTree a v -> QC.Property +prop_split proxy idx0 appends = runST $ do + gen <- newTreeGen proxy + (_t, ptrs) <- appendsToTree proxy gen appends + let idx = idx0 `mod` NonEmpty.length ptrs + ptr = ptrs NonEmpty.!! idx + + (mbL, mbR) <- split ptr + case mbL of + Just l -> do + assertInvariants l + assertRoot l + _ -> return () + + case mbR of + Just r -> do + assertInvariants r + assertRoot r + _ -> return () + + assertInvariants ptr + assertSingleton ptr + + lList <- maybe (return []) toList mbL + cList <- toList ptr + rList <- maybe (return []) toList mbR + + return $ lList ++ cList ++ rList QC.=== appendsToList appends diff --git a/tests/Data/Graph/Dynamic/Levels/Tests.hs b/tests/Data/Graph/Dynamic/Levels/Tests.hs new file mode 100644 index 0000000..ba17c11 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Levels/Tests.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Data.Graph.Dynamic.Levels.Tests where + +import Control.Monad (foldM, forM_) +import Control.Monad.ST +import Data.Graph.Dynamic.Action +import Data.Graph.Dynamic.Internal.Tree (Tree) +import qualified Data.Graph.Dynamic.Levels as Levels +import qualified Data.Graph.Dynamic.Program as Program +import qualified Data.Graph.Dynamic.Slow as Slow +import Data.Hashable (Hashable) +import Data.List (foldl', mapAccumL) +import Data.Maybe (catMaybes) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.Framework.TH +import qualified Test.QuickCheck as QC + +runGraphAction + :: (Eq v, Hashable v, Tree tree) + => Levels.Graph tree s v -> [Bool] -> Action t v -> ST s [Bool] +runGraphAction levels xs (Cut x y) = do + Levels.cut_ levels x y + return xs +runGraphAction levels xs (Link x y) = do + Levels.link_ levels x y + return xs +runGraphAction levels xs (Toggle x y) = do + Levels.edge levels x y >>= \case + True -> Levels.cut_ levels x y + False -> Levels.link_ levels x y + return xs +runGraphAction levels xs (Query x y) = + Levels.connected levels x y >>= \q -> return (q:xs) + +checkActions :: QC.Positive Int -> [Action t Int] -> QC.Property +checkActions (QC.Positive n) actions = slowResult QC.=== result + where + actions' = map (fmap (`mod` n)) actions + initialSlowGraph = Slow.edgeless [0..n-1] + slowResult = catMaybes $ snd $ mapAccumL runSlowGraphAction initialSlowGraph actions' + result :: [Bool] + result = runST $ do + initialGraph <- Levels.edgeless' [0..n-1] + results <- foldM (runGraphAction initialGraph) [] actions' + return $ reverse results + +prop_graph_linkcut :: QC.Positive Int -> [Action 'LinkCut Int] -> QC.Property +prop_graph_linkcut = checkActions + +prop_graph_toggle :: QC.Positive Int -> [Action 'Toggl Int] -> QC.Property +prop_graph_toggle = checkActions + +prop_program :: Program.IntGraphProgram -> () +prop_program (Program.IntGraphProgram p) = runST $ do + f <- Levels.empty' + Program.runProgram f p + +prop_spanningTree :: QC.Positive Int -> [Action 'LinkCut Int] -> QC.Property +prop_spanningTree (QC.Positive n) actions = + Slow.isSpanningForest spanningForest slow QC.=== True + where + actions' = map (fmap (`mod` n)) actions + + spanningForest = runST $ do + et <- Levels.edgeless' [0 .. n - 1] + forM_ actions' $ \action -> runGraphAction et [] action + Levels.spanningForest et + + slow = foldl' + (\g a -> fst $ runSlowGraphAction g a) + (Slow.edgeless [0 .. n - 1]) + actions' + +tests :: Test +tests = $testGroupGenerator diff --git a/tests/Data/Graph/Dynamic/Program.hs b/tests/Data/Graph/Dynamic/Program.hs new file mode 100644 index 0000000..f800985 --- /dev/null +++ b/tests/Data/Graph/Dynamic/Program.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Graph.Dynamic.Program + ( Program + , Instruction (..) + , genProgram + + , Interpreter (..) + , runProgram + + , IntTreeProgram (..) + , IntGraphProgram (..) + + , encodeProgram + , decodeProgram + , encodeInt + , decodeInt + ) where + +import Control.DeepSeq +import Control.Monad (when) +import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.Graph.Dynamic.EulerTour as ET +import Data.Graph.Dynamic.Internal.Tree (Tree) +import qualified Data.Graph.Dynamic.Levels as Levels +import qualified Data.Graph.Dynamic.Slow as Slow +import Data.Hashable (Hashable) +import qualified Data.HashSet as HS +import Data.List (intersperse, (\\)) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import GHC.Generics +import qualified Test.QuickCheck as QC +import Text.Read (readMaybe) + +type Program v = [Instruction v] + +data Instruction v + = Insert v + | Link v v + | Delete v + | Cut v v + | Connected v v Bool + deriving (Show, Generic) + +instance (NFData v) => NFData (Instruction v) + +genProgram + :: (Eq v, Hashable v) + => Bool -- ^ Acyclic only + -> Int -- ^ Size of program + -> Slow.Graph v -- ^ State of the graph + -> [v] -- ^ Pool of Vs to use + -> QC.Gen (Program v) +genProgram _ size _ _ | size <= 0 = return [] +genProgram acyclic size0 graph0 vs0 = do + let hasSomeVertices = case Slow.vertices graph0 of + (_ : _ : _) -> True + _ -> False + + mbInstruction <- QC.frequency $ + [(10, genInsert)] ++ + [(30, genLink) | hasSomeVertices] ++ + [(1, genDelete) | hasSomeVertices] ++ + [(10, genCut) | hasSomeVertices] ++ + [(30, genConnected) | hasSomeVertices] + + case mbInstruction of + Nothing -> genProgram acyclic size0 graph0 vs0 + Just (instr, graph1, vs1) -> (instr :) <$> + genProgram acyclic (size0 - 1) graph1 vs1 + where + genInsert = + let (v, vs1) = case vs0 of + [] -> error "Ran out of Vs..." + (x : xs) -> (x, xs) + + graph1 = Slow.insert v graph0 in + + return $ Just (Insert v, graph1, vs1) + + genLink = do + x <- QC.elements $ Slow.vertices graph0 + y <- QC.elements $ Slow.vertices graph0 \\ [x] + if | Slow.connected x y graph0 && acyclic -> + return Nothing + | Slow.edge x y graph0 -> + return Nothing + | otherwise -> + let graph1 = Slow.link x y graph0 in + return $ Just (Link x y, graph1, vs0) + + genDelete = do + v <- QC.elements $ Slow.vertices graph0 + let graph1 = Slow.delete v graph0 + return $ Just (Delete v, graph1, v : vs0) + + genCut = do + x <- QC.elements $ Slow.vertices graph0 + let nbs = HS.toList $ Slow.neighbours x graph0 + if null nbs then + return Nothing + else do + y <- QC.elements nbs + let graph1 = Slow.cut x y graph0 + return $ Just (Cut x y, graph1, vs0) + + genConnected = do + x <- QC.elements $ Slow.vertices graph0 + y <- QC.elements $ Slow.vertices graph0 \\ [x] + let res = Slow.connected x y graph0 + return $ Just (Connected x y res, graph0, vs0) + +-- | A graph that we can interpret the program against. +class Interpreter f where + insert + :: (Eq v, Hashable v, PrimMonad m) + => f (PrimState m) v -> v -> m () + link + :: (Eq v, Hashable v, PrimMonad m) + => f (PrimState m) v -> v -> v -> m () + delete + :: (Eq v, Hashable v, PrimMonad m) + => f (PrimState m) v -> v -> m () + cut + :: (Eq v, Hashable v, PrimMonad m) + => f (PrimState m) v -> v -> v -> m () + connected + :: (Eq v, Hashable v, PrimMonad m) + => f (PrimState m) v -> v -> v -> m Bool + +instance Tree t => Interpreter (Levels.Graph t) where + insert = Levels.insert_ + link f x y = Levels.link_ f x y + delete = Levels.delete_ + cut = Levels.cut_ + connected f x y = Levels.connected f x y + +instance Tree t => Interpreter (ET.Forest t ()) where + insert = ET.insert_ + link f x y = ET.link_ f x y + delete = ET.delete_ + cut f x y = ET.cut_ f x y + connected f x y = ET.connected f x y + +runProgram + :: (Eq v, Hashable v, Show v, PrimMonad m, Interpreter f) + => f (PrimState m) v -> Program v -> m () +runProgram f = go (0 :: Int) + where + go _i [] = return () + go !i (instr : instrs) = do + + case instr of + Insert x -> insert f x + Link x y -> link f x y + Delete x -> delete f x + Cut x y -> cut f x y + Connected x y expected -> do + actual <- connected f x y + when (expected /= actual) $ fail $ + "Error after " ++ show i ++ + " instructions, expected " ++ show expected ++ + " but got " ++ show actual ++ " in instruction " ++ + show instr + + go (i + 1) instrs + +newtype IntTreeProgram = IntTreeProgram {unIntTreeProgram :: Program Int} + deriving (Show) + +instance QC.Arbitrary IntTreeProgram where + arbitrary = QC.sized $ \size -> fmap IntTreeProgram $ + genProgram True size Slow.empty [1 ..] + +newtype IntGraphProgram = IntGraphProgram {unIntGraphProgram :: Program Int} + deriving (Show) + +instance QC.Arbitrary IntGraphProgram where + arbitrary = QC.sized $ \size -> fmap IntGraphProgram $ + genProgram False size Slow.empty [1 ..] + +-------------------------------------------------------------------------------- + +encodeProgram + :: (v -> T.Text) -> Program v -> TL.Text +encodeProgram encodeVertex = + TLB.toLazyText . mconcat . intersperse "\n" . map encodeInstruction + where + x <+> y = x <> " " <> y + v = TLB.fromText . encodeVertex + b False = "false" + b True = "true" + + encodeInstruction (Insert x) = "insert" <+> v x + encodeInstruction (Link x y) = "link" <+> v x <+> v y + encodeInstruction (Delete x) = "delete" <+> v x + encodeInstruction (Cut x y) = "cut" <+> v x <+> v y + encodeInstruction (Connected x y e) = "connected" <+> v x <+> v y <+> b e + +decodeProgram + :: (T.Text -> Either String v) -> TL.Text -> Either String (Program v) +decodeProgram decodeVertex = + mapM decodeInstruction . TL.lines + where + v = decodeVertex + b "false" = return False + b "true" = return True + b x = Left $ "Can't decode bool: " ++ T.unpack x + + decodeInstruction line = case T.words (TL.toStrict line) of + ["insert", x] -> Insert <$> v x + ["link", x, y] -> Link <$> v x <*> v y + ["delete", x] -> Delete <$> v x + ["cut", x, y] -> Cut <$> v x <*> v y + ["connected", x, y, e] -> Connected <$> v x <*> v y <*> b e + _ -> Left $ + "Can't decode instruction: " ++ TL.unpack line + +encodeInt :: Int -> T.Text +encodeInt = T.pack . show + +decodeInt :: T.Text -> Either String Int +decodeInt t = case readMaybe (T.unpack t) of + Nothing -> Left $ "Can't decode int: " ++ T.unpack t + Just x -> Right x diff --git a/tests/Data/Graph/Dynamic/Slow.hs b/tests/Data/Graph/Dynamic/Slow.hs new file mode 100644 index 0000000..c7805da --- /dev/null +++ b/tests/Data/Graph/Dynamic/Slow.hs @@ -0,0 +1,120 @@ +-- | A very slow but simple and hence probably correct implementation against we +-- can check our proper implementations. +module Data.Graph.Dynamic.Slow + ( Graph + , empty + , edgeless + , insert + , link + , delete + , cut + , edge + , connected + , neighbours + , vertices + + , isSpanningForest + ) where + +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashSet as HS +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import qualified Data.Tree as T + +newtype Graph v = Graph + { unGraph :: HMS.HashMap v (HS.HashSet v) + } deriving (Show) + +empty :: Graph v +empty = Graph HMS.empty + +edgeless :: (Eq v, Hashable v) => [v] -> Graph v +edgeless verts = Graph $ + HMS.fromList [(v, HS.empty) | v <- verts] + +insert :: (Eq v, Hashable v) => v -> Graph v -> Graph v +insert v = Graph . HMS.insert v HS.empty . unGraph + +link :: (Eq v, Hashable v) => v -> v -> Graph v -> Graph v +link x y g = Graph $ + HMS.insertWith HS.union x (HS.singleton y) $ + HMS.insertWith HS.union y (HS.singleton x) $ + unGraph g + +delete :: (Eq v, Hashable v) => v -> Graph v -> Graph v +delete x g | not (x `HMS.member` unGraph g) = g +delete x g0 = + let nbs = neighbours x g0 + g1 = List.foldl' (\g n -> cut x n g) g0 nbs in + Graph $ HMS.delete x (unGraph g1) + + +cut :: (Eq v, Hashable v) => v -> v -> Graph v -> Graph v +cut x y g = + let graph = + HMS.adjust (HS.delete y) x $ + HMS.adjust (HS.delete x) y $ + unGraph g in + g {unGraph = graph} + +neighbours :: (Eq v, Hashable v) => v -> Graph v -> HS.HashSet v +neighbours x g = fromMaybe HS.empty $ HMS.lookup x (unGraph g) + +edge :: (Eq v, Hashable v) => v -> v -> Graph v -> Bool +edge x y g = y `HS.member` neighbours x g + +connected :: (Eq v, Hashable v) => v -> v -> Graph v -> Bool +connected x y g = y `elem` component x g + +-- | Find all vertices connected to this component. The list is build lazily so +-- we can reuse this code efficiently in 'connected'. +component :: (Eq v, Hashable v) => v -> Graph v -> [v] +component x g = go HS.empty (HS.singleton x) + where + go visited queue = case HS.toList queue of + [] -> [] + (q : _) + | q `HS.member` visited -> go visited (HS.delete q queue) + | otherwise -> + let new = neighbours q g `HS.difference` visited in + q : go (HS.insert q visited) (new `HS.union` HS.delete q queue) + +vertices :: (Eq v, Hashable v) => Graph v -> [v] +vertices = map fst . HMS.toList . unGraph + +-- | Verifies that a forest is a right proper spanning forest of a graph. +isSpanningForest :: (Eq v, Hashable v) => T.Forest v -> Graph v -> Bool +isSpanningForest forest graph = + -- All items in the forest are unique. + unique forest && + -- The forest covers the entire graph. + HS.fromList (concatMap T.flatten forest) == HS.fromList (vertices graph) && + -- The components in the forest pairwise have the same elements as the + -- components in the graph. + and + [ HS.fromList (T.flatten tree) == HS.fromList (component root graph) + | tree@(T.Node root _) <- forest + ] && + -- The edges in the spanning forest actually exist in the graph. + and + [ edge x y graph + | (x, y) <- edges forest + ] + where + unique :: (Eq a, Hashable a) => T.Forest a -> Bool + unique = + go HS.empty . concatMap T.flatten + where + go _acc [] = True + go acc (x : xs) + | x `HS.member` acc = False + | otherwise = go (HS.insert x acc) xs + + edges :: (Eq a, Hashable a) => T.Forest a -> [(a, a)] + edges = concatMap go + where + go (T.Node root children) = + [(root, x) | T.Node x _ <- children] ++ + concatMap go children |