**diff options**

Diffstat (limited to 'tests/Data/Graph/Dynamic/Slow.hs')

-rw-r--r-- | tests/Data/Graph/Dynamic/Slow.hs | 120 |

1 files changed, 120 insertions, 0 deletions

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 |