summaryrefslogtreecommitdiff
path: root/tests/Data
diff options
context:
space:
mode:
Diffstat (limited to 'tests/Data')
-rw-r--r--tests/Data/Graph/Dynamic/Action.hs78
-rw-r--r--tests/Data/Graph/Dynamic/EulerTour/Tests.hs77
-rw-r--r--tests/Data/Graph/Dynamic/Internal/Avl/Tests.hs22
-rw-r--r--tests/Data/Graph/Dynamic/Internal/Random/Tests.hs22
-rw-r--r--tests/Data/Graph/Dynamic/Internal/Splay/Tests.hs22
-rw-r--r--tests/Data/Graph/Dynamic/Internal/Tree/Tests.hs121
-rw-r--r--tests/Data/Graph/Dynamic/Levels/Tests.hs83
-rw-r--r--tests/Data/Graph/Dynamic/Program.hs232
-rw-r--r--tests/Data/Graph/Dynamic/Slow.hs120
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
generated by cgit v0.10.2 at 2019-06-20 06:24:53 (GMT)