diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,9 @@ +# CHANGELOG + +- 0.1.0.1 (2019-01-11) + * Restrict dependency versions somewhat + +- 0.1.0.0 (2019-01-11) + * First version. Basic versions of dynamic connectivity. This blogpost has + some more information: + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Alex Lang + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alex Lang nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +# dynamic-graphs + +## Summary + +A Haskell library for dealing with the _dynamic connectivity_ problem. Consider +an undirected graph, where edges may be added and removed. This library allows +you to answer the question "are the nodes X and Y connected" at any point in +time. + +This blogpost has some more information about this library: +. + +## Installation + +`dynamic-graphs` is available on +[hackage](https://hackage.haskell.org/package/dynamic-graphs). You can install +it using Stack, Cabal, Nix, or whichever tool you prefer. + +## Example + +```haskell +import qualified Data.Graph.Dynamic.Levels as GD +import qualified Data.Tree as T + +main :: IO () +main = do + graph <- GD.empty' + mapM_ (GD.insert_ graph) ["Akanu", "Kanoa", "Kekoa", "Kaiwi", "Onakea"] + GD.link_ graph "Akanu" "Kanoa" + GD.link_ graph "Akanu" "Kaiwi" + GD.link_ graph "Akanu" "Onakea" + GD.link_ graph "Kaiwi" "Onakea" + GD.link_ graph "Onakea" "Kanoa" + GD.link_ graph "Kanoa" "Kekoa" + + GD.connected graph "Kaiwi" "Kekoa" >>= print + GD.cut_ graph "Kaiwi" "Akanu" + GD.cut_ graph "Onakea" "Akanu" + GD.cut_ graph "Onakea" "Kanoa" + GD.connected graph "Kaiwi" "Kekoa" >>= print + GD.link_ graph "Akanu" "Kaiwi" + GD.connected graph "Kaiwi" "Kekoa" >>= print +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/bench.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +import Criterion.Main + +import qualified Data.Graph.Dynamic.EulerTour as ETF +import qualified Data.Graph.Dynamic.Levels as Levels + +main :: IO () +main = defaultMainWith defaultConfig + [ bgroup "tree" $ map tree [64 * n | n <- [1..16]] + , bgroup "graph" $ map graph [16 * n | n <- [1..16]] + ] + where + graph n = bench (show n) $ nfIO (completeGraph n) + tree n = bench (show n) $ nfIO (completeBinaryTree n) + +completeGraph :: Int -> IO [(Bool, Bool)] +completeGraph n = do + levels <- Levels.edgeless' [0..n-1] + mapM_ (\(x, y) -> Levels.link levels x y) edges + mapM (\(x, y) -> do + c1 <- Levels.connected levels x y + Levels.cut levels x y + c2 <- Levels.connected levels x y + return (c1, c2) + ) edges + where + edges = [(x, y) | x <- [0..n-1], y <- [x + 1.. n - 1]] + +completeBinaryTree :: Int -> IO [(Bool, Bool)] +completeBinaryTree n = do + etf <- ETF.edgeless' [0..n-1] + mapM_ (\(x, y) -> ETF.link etf x y) edges + mapM (\(x, y) -> do + c1 <- ETF.connected etf x y + ETF.cut etf x y + c2 <- ETF.connected etf x y + return (c1, c2) + ) edges + return [] + where + edges = [(x, y) | x <- [0..n-1], y <- filter (< n) [2 * x, 2 * x + 1]] diff --git a/benchmarks/hs/bench-program.hs b/benchmarks/hs/bench-program.hs new file mode 100644 --- /dev/null +++ b/benchmarks/hs/bench-program.hs @@ -0,0 +1,14 @@ +import qualified Criterion.Main as Crit +import qualified Data.Graph.Dynamic.Levels as Levels +import qualified Data.Graph.Dynamic.Program as Program +import qualified Data.Text.Lazy.IO as TL + +main :: IO () +main = do + errOrProgram <- Program.decodeProgram Program.decodeInt <$> TL.getContents + + Crit.defaultMain + [ Crit.env (either fail return errOrProgram) $ \program -> Crit.bench "levels" $ Crit.nfIO $ do + levels <- Levels.empty' + Program.runProgram levels (program :: Program.Program Int) + ] diff --git a/benchmarks/hs/gen-program.hs b/benchmarks/hs/gen-program.hs new file mode 100644 --- /dev/null +++ b/benchmarks/hs/gen-program.hs @@ -0,0 +1,20 @@ +import qualified Data.Graph.Dynamic.Program as Program +import qualified Data.Text.Lazy.IO as TL +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import qualified System.IO as IO +import qualified Test.QuickCheck as QC +import Text.Read (readMaybe) + +main :: IO () +main = do + progName <- getProgName + args <- getArgs + case args of + [sizeStr] | Just size <- readMaybe sizeStr -> do + Program.IntGraphProgram sample <- head <$> + QC.sample' (QC.resize size QC.arbitrary) + TL.putStrLn $ Program.encodeProgram Program.encodeInt sample + _ -> do + IO.hPutStrLn IO.stderr $ "Usage: " ++ progName ++ " size" + exitFailure diff --git a/benchmarks/simple.hs b/benchmarks/simple.hs new file mode 100644 --- /dev/null +++ b/benchmarks/simple.hs @@ -0,0 +1,45 @@ + +{-# LANGUAGE BangPatterns #-} + +{-# OPTIONS_GHC -fprof-auto #-} + +import Control.DeepSeq +import qualified Data.Graph.Dynamic.EulerTour as ETF +import qualified Data.Graph.Dynamic.Levels as Levels + +main :: IO () +main = do + foo <- completeGraph 250 + return $ rnf foo + +completeGraph :: Int -> IO [(Bool, Bool)] +completeGraph n = do + levels <- Levels.edgeless' vertices + mapM_ (\(x, y) -> Levels.link levels x y) edges + mapM (\(x, y) -> do + c1 <- Levels.connected levels x y + Levels.cut levels x y + c2 <- Levels.connected levels x y + return (c1, c2) + ) edges + where + vertices = [(x, y, z) | x <- [0..n-1], y <- [0..n-1], z <- [0..n-1]] + dist (x1, y1, z1) (x2, y2, z2) = abs (x1 - x2) + abs (y1 - y2) + abs (z1 - z2) + adjVecs = [(-1, 0, 0), (1, 0, 0), (0, -1, 0), (0, 1, 0), (0, 0, -1), (0, 0, 1)] + addV3 (x1, y1, z1) (x2, y2, z2) = (x1 + x2, y1 + y2, z1 + z2) + valid (x, y, z) = x >= 0 && x < n && y >= 0 && y < n && z >= 0 && z < n + edges = [(x, y) | x <- vertices, d <- adjVecs, let y = addV3 x d, valid y] + +completeBinaryTree :: Int -> IO [(Bool, Bool)] +completeBinaryTree n = do + etf <- ETF.edgeless' [0..n-1] + mapM_ (\(x, y) -> ETF.link etf x y) edges + mapM (\(x, y) -> do + c1 <- ETF.connected etf x y + ETF.cut etf x y + c2 <- ETF.connected etf x y + return (c1, c2) + ) edges + return [] + where + edges = [(x, y) | x <- [0..n-1], y <- filter (< n) [2 * x, 2 * x + 1]] diff --git a/dynamic-graphs.cabal b/dynamic-graphs.cabal new file mode 100644 --- /dev/null +++ b/dynamic-graphs.cabal @@ -0,0 +1,162 @@ +Name: dynamic-graphs +Version: 0.1.0.1 +Synopsis: Dynamic graph algorithms +Description: A library for dynamic graph algorithms, and in particular + dynamic connectivity. +License: BSD3 +License-file: LICENSE +Author: Alex Lang, Jasper Van der Jeugt +Maintainer: me@alang.ca +copyright: 2018 Alex Lang, Jasper Van der Jeugt +Category: Data +Build-type: Simple +Extra-source-files: CHANGELOG.md, README.md +Cabal-version: >=1.10 + +Flag build-extra-executables + Description: Build the auxiliary executables, including benchmarks, tools and examples + Default: False + Manual: True + +Library + Hs-source-dirs: src + Default-language: Haskell2010 + Ghc-options: -Wall + + Exposed-modules: + Data.Graph.Dynamic.EulerTour + Data.Graph.Dynamic.Levels + + Data.Graph.Dynamic.Internal.Avl + Data.Graph.Dynamic.Internal.Splay + Data.Graph.Dynamic.Internal.Random + Data.Graph.Dynamic.Internal.Tree + Data.Graph.Dynamic.Internal.HashTable + + Build-depends: + base >= 4.8 && < 5, + containers >= 0.3 && < 0.7, + hashable >= 1.0 && < 1.3, + hashtables >= 1.2 && < 1.3, + mwc-random >= 0.12 && < 0.14, + primitive >= 0.5 && < 0.7, + unordered-containers >= 0.2 && < 0.3, + vector >= 0.10 && < 0.13 + +Test-suite dynamic-graphs-tests + Type: exitcode-stdio-1.0 + Ghc-options: -Wall + Main-is: Suite.hs + Hs-source-dirs: tests + Default-language: Haskell2010 + + Other-modules: + Data.Graph.Dynamic.EulerTour.Tests + Data.Graph.Dynamic.Internal.Avl.Tests + Data.Graph.Dynamic.Internal.Splay.Tests + Data.Graph.Dynamic.Internal.Random.Tests + Data.Graph.Dynamic.Internal.Tree.Tests + Data.Graph.Dynamic.Levels.Tests + + Data.Graph.Dynamic.Program + Data.Graph.Dynamic.Slow + Data.Graph.Dynamic.Action + + Build-depends: + aeson, + base, + deepseq, + dynamic-graphs, + bytestring, + containers, + mwc-random, + hashable, + unordered-containers, + primitive, + text, + QuickCheck, + test-framework, + test-framework-quickcheck2, + test-framework-th + +Benchmark dynamic-graphs-benchmarks + Type: exitcode-stdio-1.0 + Main-is: bench.hs + Hs-source-dirs: benchmarks + Default-language: Haskell2010 + Ghc-options: -Wall -O2 -threaded -rtsopts + Build-depends: + dynamic-graphs, + primitive, + base, + criterion + +Executable dynamic-graphs-simple + main-is: simple.hs + hs-source-dirs: benchmarks + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded -rtsopts + + If flag(build-extra-executables) + buildable: True + else + buildable: False + + Build-depends: + dynamic-graphs, + base, + deepseq, + primitive + +Executable bench-program + Main-is: bench-program.hs + Hs-source-dirs: benchmarks/hs tests + Default-language: Haskell2010 + Ghc-options: -Wall -O2 -threaded -rtsopts + + If flag(build-extra-executables) + buildable: True + Else + buildable: False + + Build-depends: + base, + containers, + deepseq, + criterion, + dynamic-graphs, + hashable, + primitive, + QuickCheck, + text, + unordered-containers + + Other-modules: + Data.Graph.Dynamic.Program + Data.Graph.Dynamic.Slow + +Executable gen-program + Main-is: gen-program.hs + Hs-source-dirs: benchmarks/hs tests + Default-language: Haskell2010 + Ghc-options: -Wall -O2 -threaded -rtsopts + + If flag(build-extra-executables) + Buildable: True + Else + Buildable: False + + Build-depends: + base, + containers, + deepseq, + dynamic-graphs, + hashable, + primitive, + QuickCheck, + text, + unordered-containers + + Other-modules: + Data.Graph.Dynamic.Program + Data.Graph.Dynamic.Slow diff --git a/src/Data/Graph/Dynamic/EulerTour.hs b/src/Data/Graph/Dynamic/EulerTour.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/EulerTour.hs @@ -0,0 +1,438 @@ +-- | This module provides dynamic connectivity for an acyclic graph (i.e. a +-- forest). +-- +-- It is based on: +-- /Finding biconnected components and computing tree functions in logarithmic parallel time/ +-- by /Robert E. Tarjan and Uzi Vishki/ (1984). +-- +-- We use two naming conventions in this module: +-- +-- * A prime suffix (@'@) indicates a simpler or less polymorphic version of a +-- function or datatype. For example, see 'empty' and 'empty'', and +-- 'Graph' and 'Graph''. +-- +-- * An underscore suffix (@_@) means that the return value is ignored. For +-- example, see 'link' and 'link_'. +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Graph.Dynamic.EulerTour + ( -- * Type + Forest + , Graph + , Graph' + + -- * Construction + , empty + , empty' + , edgeless + , edgeless' + , fromTree + , fromTree' + + -- * Queries + , connected + , edge + , vertex + , neighbours + + -- * Modifying + , link + , link_ + , cut + , cut_ + , insert + , insert_ + , delete + , delete_ + + -- * Advanced/internal operations + , findRoot + , componentSize + , spanningForest + + -- * Debugging + , print + ) where + +import Control.Monad (filterM, foldM, forM_, + void) +import Control.Monad.Primitive +import qualified Data.Graph.Dynamic.Internal.HashTable as HT +import qualified Data.Graph.Dynamic.Internal.Random as Random +import qualified Data.Graph.Dynamic.Internal.Tree as Tree +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashSet as HS +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe +import Data.Monoid +import Data.Proxy (Proxy (..)) +import qualified Data.Tree as DT +import Prelude hiding (print) + +-- | The most general type for an Euler Tour Forest. Used by other modules. +data Forest t a s v = ETF + { edges :: {-# UNPACK#-} !(HT.HashTable s v (HMS.HashMap v (t s (v, v) a))) + , toMonoid :: v -> v -> a + , treeGen :: (Tree.TreeGen t s) + } + +-- | Graph type polymorphic in the tree used to represent sequences. +type Graph t s v = Forest t () s v + +-- | Simple graph type. +type Graph' s v = Graph Random.Tree s v + +insertTree + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m) + => Forest t a s v -> v -> v -> t s (v, v) a -> m () +insertTree (ETF ht _ _) x y t = do + mbMap <- HT.lookup ht x + case mbMap of + Nothing -> HT.insert ht x $ HMS.singleton y t + Just m -> HT.insert ht x $ HMS.insert y t m + +lookupTree + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m) + => Forest t a s v -> v -> v -> m (Maybe (t s (v, v) (a))) +lookupTree (ETF ht _ _) x y = do + mbMap <- HT.lookup ht x + case mbMap of + Nothing -> return Nothing + Just m -> return $ HMS.lookup y m + +deleteTree + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m) + => Forest t a s v -> v -> v -> m () +deleteTree (ETF ht _ _) x y = do + mbMap <- HT.lookup ht x + case mbMap of + Nothing -> return () + Just m0 -> + let m1 = HMS.delete y m0 in + if HMS.null m1 then HT.delete ht x else HT.insert ht x m1 + +-- | /O(1)/ +-- +-- Create the empty tree. +empty + :: forall t m v a. (Tree.Tree t, PrimMonad m) + => (v -> v -> a) -> m (Forest t a (PrimState m) v) +empty f = do + ht <- HT.new + tg <- Tree.newTreeGen (Proxy :: Proxy t) + return $ ETF ht f tg + +-- | Simple version of 'empty'. +empty' + :: PrimMonad m => m (Graph' (PrimState m) v) +empty' = empty (\_ _ -> ()) + +-- | /O(v*log(v))/ +-- +-- Create a graph with the given vertices but no edges. +edgeless + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => (v -> v -> a) -> [v] -> m (Forest t a (PrimState m) v) +edgeless toMonoid vs = do + etf <- empty toMonoid + forM_ vs $ \v -> do + node <- Tree.singleton (treeGen etf) (v, v) (toMonoid v v) + insertTree etf v v node + return etf + +-- | Simple version of 'edgeless'. +edgeless' + :: (Eq v, Hashable v, PrimMonad m) + => [v] -> m (Graph' (PrimState m) v) +edgeless' = edgeless (\_ _ -> ()) + +-- | Create a graph from a 'DT.Tree'. Note that the values in nodes must be +-- unique. +fromTree + :: forall v m t a. (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => (v -> v -> a) -> DT.Tree v -> m (Forest t a (PrimState m) v) +fromTree toMonoid tree = do + etf <- empty toMonoid + _ <- go etf tree + return etf + where + go etf (DT.Node l children) = do + node0 <- Tree.singleton (treeGen etf) (l, l) (toMonoid l l) + insertTree etf l l node0 + foldM (go' etf l) node0 children + + go' etf parent node0 tr@(DT.Node l _) = do + lnode <- go etf tr + parentToL <- Tree.singleton (treeGen etf) (parent, l) (toMonoid parent l) + lToParent <- Tree.singleton (treeGen etf) (l, parent) (toMonoid l parent) + + node1 <- Tree.concat $ node0 NonEmpty.:| [parentToL, lnode, lToParent] + insertTree etf l parent lToParent + insertTree etf parent l parentToL + return node1 + +-- | Simple version of 'fromTree'. +fromTree' + :: (Eq v, Hashable v, PrimMonad m) + => DT.Tree v -> m (Graph' (PrimState m) v) +fromTree' = fromTree (\_ _ -> ()) + +findRoot + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m, Monoid a) + => Forest t a s v -> v -> m (Maybe (t s (v, v) a)) +findRoot etf v = do + mbTree <- lookupTree etf v v + case mbTree of + Nothing -> return Nothing + Just t -> Just <$> Tree.root t + +-- | /O(log(v))/ +-- +-- Remove an edge in between two vertices. If there is no edge in between +-- these vertices, do nothing. Return whether or not an edge was actually +-- removed. +cut + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> v -> m Bool +cut etf a b = do + mbAb <- lookupTree etf a b + mbBa <- lookupTree etf b a + case (mbAb, mbBa) of + _ | a == b -> return False -- Can't cut self-loops + (Just ab, Just ba) -> do + (part1, part2) <- Tree.split ab + + baIsInPart1 <- case part1 of + Just p -> Tree.connected p ba + _ -> return False + + (mbL, _, mbR) <- if baIsInPart1 then do + (part3, part4) <- Tree.split ba + return (part3, part4, part2) + else do + (part3, part4) <- Tree.split ba + return (part1, part3, part4) + + _ <- sequenceA $ Tree.append <$> mbL <*> mbR + deleteTree etf a b + deleteTree etf b a + return True + + (Nothing, _) -> return False -- No edge to cut + (_, Nothing) -> return False -- No edge to cut + +-- | Version of 'cut' which ignores the result. +cut_ + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> v -> m () +cut_ etf a b = void (cut etf a b) + +-- | reroot the represented tree by shifting the euler tour. Returns the new +-- root. +reroot + :: (Tree.Tree t, PrimMonad m, s ~ PrimState m, Monoid v) + => t s a v -> m (t s a v) +reroot t = do + (mbPre, mbPost) <- Tree.split t + t1 <- maybe (return t) (t `Tree.cons`) mbPost + maybe (return t1) (t1 `Tree.append`) mbPre + +-- | /O(log(v))/ +-- +-- Check if this edge exists in the graph. +edge + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m) + => Forest t a (PrimState m) v -> v -> v -> m Bool +edge etf a b = isJust <$> lookupTree etf a b + +-- | /O(log(v))/ +-- +-- Check if this vertex exists in the graph. +vertex + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m) + => Forest t a (PrimState m) v -> v -> m Bool +vertex etf a = isJust <$> lookupTree etf a a + +-- | /O(log(v))/ +-- +-- Check if a path exists in between two vertices. +connected + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> v -> m Bool +connected etf a b = do + mbALoop <- lookupTree etf a a + mbBLoop <- lookupTree etf b b + case (mbALoop, mbBLoop) of + (Just aLoop, Just bLoop) -> Tree.connected aLoop bLoop + _ -> return False + +-- | /O(log(v))/ +-- +-- Insert an edge in between two vertices. If the vertices are already +-- connected, we don't do anything, since this is an acyclic graph. Returns +-- whether or not an edge was actually inserted. +link + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> v -> m Bool +link etf@ETF{..} a b = do + mbALoop <- lookupTree etf a a + mbBLoop <- lookupTree etf b b + case (mbALoop, mbBLoop) of + (Just aLoop, Just bLoop) -> Tree.connected aLoop bLoop >>= \case + True -> return False + False -> do + + bLoop1 <- reroot bLoop + abNode <- Tree.singleton treeGen (a, b) (toMonoid a b) + baNode <- Tree.singleton treeGen (b, a) (toMonoid b a) + bLoop2 <- abNode `Tree.cons` bLoop1 + bLoop3 <- bLoop2 `Tree.snoc` baNode + (mbPreA, mbPostA) <- Tree.split aLoop + + _ <- Tree.concat $ + aLoop NonEmpty.:| catMaybes + [ Just bLoop3 + , mbPostA + , mbPreA + ] + + insertTree etf a b abNode + insertTree etf b a baNode + return True + + _ -> return False + +-- | Version of 'link' which ignores the result. +link_ + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> v -> m () +link_ etf a b = void (link etf a b) + +-- | /O(log(v))/ +-- +-- Insert a new vertex. Do nothing if it is already there. Returns whether +-- or not a vertex was inserted in the graph. +insert + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> m Bool +insert etf@ETF{..} v = do + mbTree <- lookupTree etf v v + case mbTree of + Just _ -> return False + Nothing -> do + node <- Tree.singleton treeGen (v, v) (toMonoid v v) + insertTree etf v v node + return True + +-- | Version of 'insert' which ignores the result. +insert_ + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> m () +insert_ etf v = void (insert etf v) + +-- | /O(log(v) + n/ where /n/ is the number of neighbours +-- +-- Get all neighbours of the given vertex. +neighbours + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> m [v] +neighbours etf x = fromMaybe [] <$> maybeNeighbours etf x + +maybeNeighbours + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> m (Maybe [v]) +maybeNeighbours (ETF ht _ _) x = do + mbMap <- HT.lookup ht x + case mbMap of + Nothing -> return Nothing + Just m -> return $ Just $ filter (/= x) $ map fst $ HMS.toList m + +-- | /O(n*log(v))/ where /n/ is the number of neighbours +-- +-- Remove a vertex from the graph, if it exists. If it is connected to any +-- other vertices, those edges are cut first. Returns whether or not a vertex +-- was removed from the graph. +delete + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> m Bool +delete etf x = do + mbNbs <- maybeNeighbours etf x + case mbNbs of + Nothing -> return False + Just nbs -> do + forM_ nbs $ \y -> cut etf x y + deleteTree etf x x + return True + +-- | Version of 'delete' which ignores the result. +delete_ + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a) + => Forest t a (PrimState m) v -> v -> m () +delete_ etf x = void (delete etf x) + +print :: (Show a, Monoid b, Tree.TestTree t) => Forest t b RealWorld a -> IO () +print (ETF ht _ _) = do + maps <- map snd <$> HT.toList ht + let trees = concatMap (map snd . HMS.toList) maps + comps <- components trees + forM_ comps $ \comp -> do + root <- Tree.root comp + Tree.print root + putStrLn "" + where + components [] = return [] + components (t : ts) = do + ts' <- filterM (fmap not . Tree.connected t) ts + (t :) <$> components ts' + +componentSize + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m) + => Forest t (Sum Int) s v -> v -> m Int +componentSize etf v = do + mbTree <- lookupTree etf v v + case mbTree of + Nothing -> return 0 + Just tree -> do + root <- Tree.root tree + getSum <$> Tree.aggregate root + +-- | Obtain the current spanning forest. +spanningForest + :: (Eq v, Hashable v, Tree.Tree t, Monoid a, PrimMonad m) + => Forest t a (PrimState m) v -> m (DT.Forest v) +spanningForest (ETF ht _ _) = do + maps <- map snd <$> HT.toList ht + let trees = concatMap (map snd . HMS.toList) maps + go HS.empty [] trees + where + go _visited acc [] = return acc + go visited acc (t : ts) = do + root <- Tree.readRoot t + label <- Tree.label root + if HS.member label visited then + go visited acc ts + else do + st <- spanningTree root + go (HS.insert label visited) (st : acc) ts + +spanningTree + :: (Eq v, Hashable v, PrimMonad m, Monoid e, Tree.Tree t) + => t (PrimState m) (v, v) e -> m (DT.Tree v) +spanningTree tree = do + list <- Tree.toList tree + case list of + ((r, _) : _) -> return $ DT.Node r (fst $ go Nothing [] list) + _ -> fail + "Data.Graph.Dynamic..EulerTour.spanningTree: empty list" + where + go _mbParent acc [] = (acc, []) + go mbParent acc ((a, b) : edges) + | a == b = go mbParent acc edges -- Ignore self-loops. + | Just b == mbParent = (acc, edges) -- Like a closing bracket. + | otherwise = + -- Parse child. + let (child, rest) = go (Just a) [] edges in + go mbParent (DT.Node b child : acc) rest diff --git a/src/Data/Graph/Dynamic/Internal/Avl.hs b/src/Data/Graph/Dynamic/Internal/Avl.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/Internal/Avl.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Graph.Dynamic.Internal.Avl + ( Tree + + , singleton + , append + , concat + , join + , split + , root + , connected + , label + , aggregate + , toList + + -- * Debugging only + , freeze + , print + , assertInvariants + , assertSingleton + , assertRoot + ) where + +import Control.Monad (foldM, when) +import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.Graph.Dynamic.Internal.Tree as Class +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid ((<>)) +import Data.Primitive.MutVar (MutVar) +import qualified Data.Primitive.MutVar as MutVar +import qualified Data.Tree as Tree +import Prelude hiding (concat, print) + +data Tree s a v = Tree + { tParent :: {-# UNPACK #-} !(MutVar s (Tree s a v)) + , tLeft :: {-# UNPACK #-} !(MutVar s (Tree s a v)) + , tRight :: {-# UNPACK #-} !(MutVar s (Tree s a v)) + , tAggs :: {-# UNPACK #-} !(MutVar s (Aggs v)) + , tLabel :: !a + , tValue :: !v + } + +instance Eq (Tree s a v) where + -- Reference equality through a MutVar. + t1 == t2 = tParent t1 == tParent t2 + +data Aggs v = Aggs + { aHeight :: {-# UNPACK #-} !Int + , aAggregate :: !v + } deriving (Eq, Show) + +emptyAggs :: Monoid v => Aggs v +emptyAggs = Aggs 0 mempty + +singletonAggs :: v -> Aggs v +singletonAggs = Aggs 1 + +joinAggs :: Monoid v => Aggs v -> v -> Aggs v -> Aggs v +joinAggs (Aggs lh la) a (Aggs rh ra) = + Aggs (max lh rh + 1) (la <> a <> ra) + +singleton :: PrimMonad m => a -> v -> m (Tree (PrimState m) a v) +singleton tLabel tValue = do + tParent <- MutVar.newMutVar undefined + tLeft <- MutVar.newMutVar undefined + tRight <- MutVar.newMutVar undefined + tAggs <- MutVar.newMutVar $ singletonAggs tValue + let tree = Tree {..} + MutVar.writeMutVar tParent tree + MutVar.writeMutVar tLeft tree + MutVar.writeMutVar tRight tree + return tree + +root :: PrimMonad m => Tree (PrimState m) a v -> m (Tree (PrimState m) a v) +root tree@Tree {..} = do + parent <- MutVar.readMutVar tParent + if parent == tree then return tree else root parent + +concat + :: (PrimMonad m, Monoid v) + => NonEmpty (Tree (PrimState m) a v) + -> m (Tree (PrimState m) a v) +concat (x0 NonEmpty.:| xs0) = + foldM append x0 xs0 + +split + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v)) +split x0 = do + (mbL, mbR, p, left) <- cut x0 + if p == x0 then + return (mbL, mbR) + else do + upwards mbL mbR p left + where + upwards lacc0 racc0 x left0 = do + (mbL, mbR, p, left1) <- cut x + if left0 then do + racc1 <- join racc0 x mbR + if p == x then + return (lacc0, Just racc1) + else + upwards lacc0 (Just racc1) p left1 + else do + lacc1 <- join mbL x lacc0 + if p == x then + return (Just lacc1, racc0) + else + upwards (Just lacc1) racc0 p left1 + + cut x = do + p <- MutVar.readMutVar (tParent x) + pl <- MutVar.readMutVar (tLeft p) + l <- MutVar.readMutVar (tLeft x) + r <- MutVar.readMutVar (tRight x) + when (l /= x) $ removeParent l + when (r /= x) $ removeParent r + removeParent x + removeLeft x + removeRight x + updateAggs x + if pl == x then removeLeft p else removeRight p + return + ( if l == x then Nothing else Just l + , if r == x then Nothing else Just r + , p + , pl == x + ) + +append + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +append l0 r0 = do + -- NOTE: there is a faster way to do this by just following the right spine + -- and joining along the way. + rm <- getRightMost l0 + (mbL, mbR) <- split rm + case mbR of + Just _ -> error "append: invalid state" + _ -> assertSingleton rm + join mbL rm (Just r0) + where + getRightMost x = do + r <- MutVar.readMutVar (tRight x) + if r == x then return x else getRightMost r + +connected + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m Bool +connected x y = do + xr <- root x + yr <- root y + return $ xr == yr + +label :: (PrimMonad m, Monoid v) => Tree (PrimState m) a v -> m a +label = return . tLabel + +aggregate :: (PrimMonad m, Monoid v) => Tree (PrimState m) a v -> m v +aggregate = fmap aAggregate . MutVar.readMutVar . tAggs + +-- | For debugging/testing. +toList + :: PrimMonad m => Tree (PrimState m) a v -> m [a] +toList = go [] + where + go acc0 tree@Tree {..} = do + left <- MutVar.readMutVar tLeft + right <- MutVar.readMutVar tRight + acc1 <- if right == tree then return acc0 else go acc0 right + let acc2 = tLabel : acc1 + if left == tree then return acc2 else go acc2 left + +join + :: (PrimMonad m, Monoid v) + => Maybe (Tree (PrimState m) a v) + -> Tree (PrimState m) a v -- Must be a singleton + -> Maybe (Tree (PrimState m) a v) + -> m (Tree (PrimState m) a v) +join mbL c mbR = do + lh <- maybe (return 0) (fmap aHeight . MutVar.readMutVar . tAggs) mbL + rh <- maybe (return 0) (fmap aHeight . MutVar.readMutVar . tAggs) mbR + if | lh > rh + 1, Just l <- mbL -> + joinRight l c mbR + | rh > lh + 1, Just r <- mbR -> + joinLeft mbL c r + | otherwise -> do + case mbL of Just l -> setLeft c l; _ -> return () + case mbR of Just r -> setRight c r; _ -> return () + updateAggs c + return c + +joinLeft + :: (PrimMonad m, Monoid v) + => Maybe (Tree (PrimState m) a v) + -> Tree (PrimState m) a v -- Must be a singleton + -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +joinLeft mbL c r = do + rl <- MutVar.readMutVar (tLeft r) + rla <- leftAggs r rl + + rr <- MutVar.readMutVar (tRight r) + rra <- rightAggs r rr + + la <- maybe (return emptyAggs) (MutVar.readMutVar . tAggs) mbL + + if aHeight rla <= aHeight la + 1 then do + setLeft r c + when (rl /= r) $ setRight c rl + case mbL of Just l -> setLeft c l; _ -> return () + + let !ca = joinAggs rla (tValue c) la + + -- Invalidity in the parent is fixed with two rotations + if aHeight rra + 1 < aHeight ca then do + rotateLeft c rl + rotateRight r rl + + updateAggs c + updateAggs r + updateAggsToRoot rl + else do + -- One rotation + updateAggs c + updateAggs r + upLeft r + else + joinLeft mbL c rl + +upLeft + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +upLeft l = do + p <- MutVar.readMutVar (tParent l) + if p == l then + return l + else do + r <- MutVar.readMutVar (tRight p) + ra <- rightAggs p r + la <- leftAggs p l + if aHeight ra + 1 < aHeight la then do + rotateRight p l + updateAggs p + updateAggsToRoot l + else do + updateAggs p -- Stuff below us might have changed. + upLeft p + +joinRight + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v -- Must be a singleton + -> Maybe (Tree (PrimState m) a v) + -> m (Tree (PrimState m) a v) +joinRight l c mbR = do + lr <- MutVar.readMutVar (tRight l) + lra <- rightAggs l lr + + ll <- MutVar.readMutVar (tLeft l) + lla <- leftAggs l ll + + ra <- maybe (return emptyAggs) (MutVar.readMutVar . tAggs) mbR + + if aHeight lra <= aHeight ra + 1 then do + setRight l c + when (lr /= l) $ setLeft c lr + case mbR of Just r -> setRight c r; _ -> return () + + let !ca = joinAggs lra (tValue c) ra + + -- Invalidity in the parent is fixed with two rotations + if aHeight lla + 1 < aHeight ca then do + rotateRight c lr + rotateLeft l lr + + -- Many of these are already computed... + updateAggs l + updateAggs c + updateAggsToRoot lr + else do + -- One rotation + updateAggs c + updateAggs l + upRight l + else + joinRight lr c mbR + +upRight + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +upRight r = do + p <- MutVar.readMutVar (tParent r) + if p == r then + return p + else do + l <- MutVar.readMutVar (tLeft p) + la <- leftAggs p l + ra <- rightAggs p r + if aHeight la + 1 < aHeight ra then do + rotateLeft p r + updateAggs p + updateAggsToRoot r + else do + updateAggs p -- Stuff below us might have changed. + upRight p + +rotateLeft, rotateRight + :: PrimMonad m + => Tree (PrimState m) a v -- X's parent + -> Tree (PrimState m) a v -- X + -> m () +rotateLeft p x = do + b <- MutVar.readMutVar (tLeft x) + if b == x then removeRight p else setRight p b + gp <- MutVar.readMutVar (tParent p) + if gp == p then removeParent x else replace gp p x + setLeft x p +rotateRight p x = do + b <- MutVar.readMutVar (tRight x) + if b == x then removeLeft p else setLeft p b + gp <- MutVar.readMutVar (tParent p) + if gp == p then removeParent x else replace gp p x + setRight x p + +setLeft, setRight + :: PrimMonad m + => Tree (PrimState m) a v -- Parent + -> Tree (PrimState m) a v -- New child + -> m () +setLeft p x = do + MutVar.writeMutVar (tParent x) p + MutVar.writeMutVar (tLeft p) x +setRight p x = do + MutVar.writeMutVar (tParent x) p + MutVar.writeMutVar (tRight p) x + +removeParent, removeLeft, removeRight + :: PrimMonad m + => Tree (PrimState m) a v -- Parent + -> m () +removeParent x = MutVar.writeMutVar (tParent x) x +removeLeft x = MutVar.writeMutVar (tLeft x) x +removeRight x = MutVar.writeMutVar (tRight x) x + +leftAggs, rightAggs + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v -- Parent + -> Tree (PrimState m) a v -- Left or right child + -> m (Aggs v) +leftAggs p l = + if p == l then return emptyAggs else MutVar.readMutVar (tAggs l) +rightAggs p r = + if p == r then return emptyAggs else MutVar.readMutVar (tAggs r) + +-- | Replace X by Y in the tree. X must have a parent. +replace + :: PrimMonad m + => Tree (PrimState m) a v -- ^ X's parent + -> Tree (PrimState m) a v -- ^ X + -> Tree (PrimState m) a v -- ^ Y + -> m () +replace p x y = do + pl <- MutVar.readMutVar (tLeft p) + MutVar.writeMutVar (tParent y) p + if pl == x + then MutVar.writeMutVar (tLeft p) y + else MutVar.writeMutVar (tRight p) y + +-- | Recompute the aggregate and height of a node. +updateAggs + :: (Monoid v, PrimMonad m) + => Tree (PrimState m) a v + -> m () +updateAggs t = do + l <- MutVar.readMutVar (tLeft t) + r <- MutVar.readMutVar (tRight t) + la <- leftAggs t l + ra <- rightAggs t r + let !agg = joinAggs la (tValue t) ra + MutVar.writeMutVar (tAggs t) agg + +-- | Recompute aggregate and height all the way to the root of the tree. +updateAggsToRoot + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +updateAggsToRoot x = do + updateAggs x + p <- MutVar.readMutVar (tParent x) + if p == x then return x else updateAggsToRoot p + +-- | For debugging/testing. +freeze :: PrimMonad m => Tree (PrimState m) a v -> m (Tree.Tree a) +freeze tree@Tree {..} = do + left <- MutVar.readMutVar tLeft + right <- MutVar.readMutVar tRight + children <- sequence $ + [freeze left | left /= tree] ++ + [freeze right | right /= tree] + return $ Tree.Node tLabel children + +print :: Show a => Tree (PrimState IO) a v -> IO () +print = go 0 + where + go d t@Tree {..} = do + left <- MutVar.readMutVar tLeft + when (left /= t) $ go (d + 1) left + + putStrLn $ replicate d ' ' ++ show tLabel + + right <- MutVar.readMutVar tRight + when (right /= t) $ go (d + 1) right + +assertInvariants + :: (PrimMonad m, Monoid v, Eq v, Show v) => Tree (PrimState m) a v -> m () +assertInvariants t = do + _ <- computeAggs t t + return () + where + -- TODO: Check average + computeAggs p x = do + p' <- MutVar.readMutVar (tParent x) + when (p /= p') $ fail "broken parent pointer" + + l <- MutVar.readMutVar (tLeft x) + r <- MutVar.readMutVar (tRight x) + la <- if l == x then return emptyAggs else computeAggs x l + ra <- if r == x then return emptyAggs else computeAggs x r + + let actualAggs = joinAggs la (tValue x) ra + storedAggs <- MutVar.readMutVar (tAggs x) + + when (actualAggs /= storedAggs) $ fail $ + "error in stored aggregates: " ++ show storedAggs ++ + ", actual: " ++ show actualAggs + + when (abs (aHeight la - aHeight ra) > 1) $ fail "inbalanced" + return actualAggs + +assertSingleton :: PrimMonad m => Tree (PrimState m) a v -> m () +assertSingleton x = do + l <- MutVar.readMutVar (tLeft x) + r <- MutVar.readMutVar (tRight x) + p <- MutVar.readMutVar (tParent x) + when (l /= x || r /= x || p /= x) $ fail "not a singleton" + +assertRoot :: PrimMonad m => Tree (PrimState m) a v -> m () +assertRoot x = do + p <- MutVar.readMutVar (tParent x) + when (p /= x) $ fail "not the root" + +data TreeGen s = TreeGen + +instance Class.Tree Tree where + type TreeGen Tree = TreeGen + newTreeGen _ = return TreeGen + + singleton _ = singleton + append = append + split = split + connected = connected + root = root + label = label + aggregate = aggregate + toList = toList + +instance Class.TestTree Tree where + print = print + assertInvariants = assertInvariants + assertSingleton = assertSingleton + assertRoot = assertRoot diff --git a/src/Data/Graph/Dynamic/Internal/HashTable.hs b/src/Data/Graph/Dynamic/Internal/HashTable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/Internal/HashTable.hs @@ -0,0 +1,49 @@ +-- | This is a very simple wrapper around the 'hashtables' library that uses +-- 'PrimMonad' rather than 'ST'. +module Data.Graph.Dynamic.Internal.HashTable + ( HashTable + , new + , insert + , delete + , lookup + + -- Slow and debugging only + , toList + ) where + +import Control.Monad.Primitive (PrimMonad (..), stToPrim) +import Data.Hashable (Hashable) +import qualified Data.HashTable.ST.Cuckoo as Cuckoo +import Prelude hiding (lookup) + +type HashTable s k v = Cuckoo.HashTable s k v + +new :: PrimMonad m => m (HashTable (PrimState m) k v) +new = stToPrim Cuckoo.new +{-# INLINE new #-} + +insert + :: (Eq k, Hashable k, PrimMonad m) + => HashTable (PrimState m) k v -> k -> v -> m () +insert ht k v = stToPrim (Cuckoo.insert ht k v) +{-# INLINE insert #-} + +delete + :: (Eq k, Hashable k, PrimMonad m) + => HashTable (PrimState m) k v -> k -> m () +delete ht k = stToPrim (Cuckoo.delete ht k) +{-# INLINE delete #-} + +lookup + :: (Eq k, Hashable k, PrimMonad m) + => HashTable (PrimState m) k v -> k -> m (Maybe v) +lookup ht k = stToPrim (Cuckoo.lookup ht k) +{-# INLINE lookup #-} + +-------------------------------------------------------------------------------- + +-- | Slow, only for debugging and testing. +toList + :: PrimMonad m + => HashTable (PrimState m) k v -> m [(k, v)] +toList ht = stToPrim $ Cuckoo.foldM (\acc kv -> return (kv : acc)) [] ht diff --git a/src/Data/Graph/Dynamic/Internal/Random.hs b/src/Data/Graph/Dynamic/Internal/Random.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/Internal/Random.hs @@ -0,0 +1,269 @@ +-- | Randomly balanced tree. +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Graph.Dynamic.Internal.Random + ( Tree + + , singleton + , append + , split + , connected + , root + , label + , aggregate + , toList + + -- * Debugging only + , freeze + , print + , assertInvariants + , assertSingleton + , assertRoot + ) where + +import Control.Monad (when) +import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.Graph.Dynamic.Internal.Tree as Class +import Data.Monoid ((<>)) +import Data.Primitive.MutVar (MutVar) +import qualified Data.Primitive.MutVar as MutVar +import qualified Data.Tree as Tree +import Prelude hiding (concat, print) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Random.MWC as MWC +import Unsafe.Coerce (unsafeCoerce) + +data T s a v = T + { tParent :: {-# UNPACK #-} !(Tree s a v) + , tLeft :: {-# UNPACK #-} !(Tree s a v) + , tRight :: {-# UNPACK #-} !(Tree s a v) + , tRandom :: !Int + , tLabel :: !a + , tValue :: !v + , tAgg :: !v + } + +-- | NOTE (jaspervdj): There are two ways of indicating the parent / left / +-- right is not set (we want to avoid Maybe's since they cause a lot of +-- indirections). +-- +-- Imagine that we are considering tLeft. +-- +-- 1. We can set tLeft of x to the MutVar that holds the tree itself (i.e. a +-- self-loop). +-- 2. We can set tLeft to some nil value. +-- +-- They seem to offer similar performance. We choose to use the latter since it +-- is less likely to end up in infinite loops that way, and additionally, we can +-- move easily move e.g. x's left child to y's right child, even it is an empty +-- child. +nil :: Tree s a v +nil = unsafeCoerce $ unsafePerformIO $ Tree <$> MutVar.newMutVar undefined +{-# NOINLINE nil #-} + +newtype Tree s a v = Tree (MutVar s (T s a v)) deriving (Eq) + +singleton + :: PrimMonad m + => MWC.Gen (PrimState m) -> a -> v -> m (Tree (PrimState m) a v) +singleton gen tLabel tValue = do + random <- MWC.uniform gen + Tree <$> MutVar.newMutVar (T nil nil nil random tLabel tValue tValue) + +root :: PrimMonad m => Tree (PrimState m) a v -> m (Tree (PrimState m) a v) +root (Tree tv) = do + T {..} <- MutVar.readMutVar tv + if tParent == nil then return (Tree tv) else root tParent + +-- | Appends two trees. Returns the root of the tree. +append + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +append = merge + +merge + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +merge xt@(Tree xv) yt@(Tree yv) + | xt == nil = return yt + | yt == nil = return xt + | otherwise = do + x <- MutVar.readMutVar xv + y <- MutVar.readMutVar yv + if tRandom x < tRandom y then do + rt@(Tree rv) <- merge xt (tLeft y) + MutVar.writeMutVar yv $! y {tLeft = rt, tAgg = tAgg x <> tAgg y} + MutVar.modifyMutVar rv $ \r -> r {tParent = yt} + return yt + else do + rt@(Tree rv) <- merge (tRight x) yt + MutVar.writeMutVar xv $! x {tRight = rt, tAgg = tAgg x <> tAgg y} + MutVar.modifyMutVar rv $ \r -> r {tParent = xt} + return xt + +split + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v)) +split xt@(Tree xv) = do + x <- MutVar.readMutVar xv + let pv = tParent x + lt = tLeft x + rt = tRight x + + when (lt /= nil) (removeParent lt) + when (rt /= nil) (removeParent rt) + MutVar.writeMutVar xv $! + x {tParent = nil, tLeft = nil, tRight = nil, tAgg = tValue x} + + mergeUp pv xt lt rt + +mergeUp + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v -- Current node + -> Tree (PrimState m) a v -- Eliminated node + -> Tree (PrimState m) a v -- Left tree accumulator + -> Tree (PrimState m) a v -- Right tree accumulator + -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v)) +mergeUp xt _ lacc racc | xt == nil = + return + ( if lacc == nil then Nothing else Just lacc + , if racc == nil then Nothing else Just racc + ) +mergeUp xt@(Tree xv) ct lacc racc = do + x <- MutVar.readMutVar xv + let pt = tParent x + lt = tLeft x + rt = tRight x + if ct == lt then do + ra <- if rt == nil then return mempty else aggregate rt + MutVar.writeMutVar xv $! x {tParent = nil, tLeft = nil, tAgg = tValue x <> ra} + racc' <- merge racc xt + mergeUp pt xt lacc racc' + else do + la <- if lt == nil then return mempty else aggregate lt + MutVar.writeMutVar xv $! x {tParent = nil, tRight = nil, tAgg = la <> tValue x} + lacc' <- merge xt lacc + mergeUp pt xt lacc' racc + +connected + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m Bool +connected xv yv = do + xr <- root xv + yr <- root yv + return $ xr == yr + +label + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m a +label (Tree xv) = tLabel <$> MutVar.readMutVar xv + +aggregate + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m v +aggregate (Tree xv) = tAgg <$> MutVar.readMutVar xv + +-- | For debugging/testing. +toList + :: PrimMonad m => Tree (PrimState m) a v -> m [a] +toList = go [] + where + go acc0 (Tree mv) = do + T {..} <- MutVar.readMutVar mv + acc1 <- if tRight == nil then return acc0 else go acc0 tRight + let acc2 = tLabel : acc1 + if tLeft == nil then return acc2 else go acc2 tLeft + +removeParent, _removeLeft, _removeRight + :: PrimMonad m + => Tree (PrimState m) a v -- Parent + -> m () +removeParent (Tree xv) = MutVar.modifyMutVar' xv $ \x -> x {tParent = nil} +_removeLeft (Tree xv) = MutVar.modifyMutVar' xv $ \x -> x {tLeft = nil} +_removeRight (Tree xv) = MutVar.modifyMutVar' xv $ \x -> x {tRight = nil} + +-- | For debugging/testing. +freeze :: PrimMonad m => Tree (PrimState m) a v -> m (Tree.Tree a) +freeze (Tree mv) = do + T {..} <- MutVar.readMutVar mv + children <- sequence $ + [freeze tLeft | tLeft /= nil] ++ + [freeze tRight | tRight /= nil] + return $ Tree.Node tLabel children + +print :: Show a => Tree (PrimState IO) a v -> IO () +print = go 0 + where + go d (Tree mv) = do + T {..} <- MutVar.readMutVar mv + when (tLeft /= nil) $ go (d + 1) tLeft + putStrLn $ replicate d ' ' ++ show tLabel + when (tRight /= nil) $ go (d + 1) tRight + +assertInvariants + :: (PrimMonad m, Monoid v, Eq v, Show v) => Tree (PrimState m) a v -> m () +assertInvariants t = do + _ <- computeAgg nil t + return () + where + -- TODO: Check average + computeAgg pt xt@(Tree xv) = do + x <- MutVar.readMutVar xv + let pt' = tParent x + when (pt /= pt') $ fail "broken parent pointer" + + let lt = tLeft x + let rt = tRight x + la <- if lt == nil then return mempty else computeAgg xt lt + ra <- if rt == nil then return mempty else computeAgg xt rt + + let actualAgg = la <> (tValue x) <> ra + let storedAgg = tAgg x + + when (actualAgg /= storedAgg) $ fail $ + "error in stored aggregates: " ++ show storedAgg ++ + ", actual: " ++ show actualAgg + + return actualAgg + +assertSingleton :: PrimMonad m => Tree (PrimState m) a v -> m () +assertSingleton (Tree xv) = do + T {..} <- MutVar.readMutVar xv + when (tLeft /= nil || tRight /= nil || tParent /= nil) $ + fail "not a singleton" + +assertRoot :: PrimMonad m => Tree (PrimState m) a v -> m () +assertRoot (Tree xv) = do + T {..} <- MutVar.readMutVar xv + when (tParent /= nil) $ fail "not the root" + +instance Class.Tree Tree where + type TreeGen Tree = MWC.Gen + newTreeGen _ = MWC.create + + singleton = singleton + append = append + split = split + connected = connected + root = root + label = label + aggregate = aggregate + toList = toList + +instance Class.TestTree Tree where + print = print + assertInvariants = assertInvariants + assertSingleton = assertSingleton + assertRoot = assertRoot diff --git a/src/Data/Graph/Dynamic/Internal/Splay.hs b/src/Data/Graph/Dynamic/Internal/Splay.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/Internal/Splay.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Graph.Dynamic.Internal.Splay + ( Tree + + , singleton + , cons + , snoc + , append + , split + , connected + , root + , aggregate + , toList + + -- * Debugging only + , readRoot + , freeze + , print + , assertInvariants + ) where + +import Control.Monad (when) +import Control.Monad.Primitive (PrimMonad (..)) +import qualified Data.Graph.Dynamic.Internal.Tree as Class +import Data.Monoid ((<>)) +import Data.Primitive.MutVar (MutVar) +import qualified Data.Primitive.MutVar as MutVar +import qualified Data.Tree as Tree +import Prelude hiding (concat, print) +import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) + +data T s a v = T + { tParent :: {-# UNPACK #-} !(Tree s a v) + , tLeft :: {-# UNPACK #-} !(Tree s a v) + , tRight :: {-# UNPACK #-} !(Tree s a v) + , tLabel :: !a + , tValue :: !v + , tAgg :: !v + } + +-- | NOTE (jaspervdj): There are two ways of indicating the parent / left / +-- right is not set (we want to avoid Maybe's since they cause a lot of +-- indirections). +-- +-- Imagine that we are considering tLeft. +-- +-- 1. We can set tLeft of x to the MutVar that holds the tree itself (i.e. a +-- self-loop). +-- 2. We can set tLeft to some nil value. +-- +-- They seem to offer similar performance. We choose to use the latter since it +-- is less likely to end up in infinite loops that way, and additionally, we can +-- move easily move e.g. x's left child to y's right child, even it is an empty +-- child. +nil :: Tree s a v +nil = unsafeCoerce $ unsafePerformIO $ fmap Tree $ MutVar.newMutVar undefined +{-# NOINLINE nil #-} + +newtype Tree s a v = Tree {unTree :: MutVar s (T s a v)} + deriving (Eq) + +singleton :: PrimMonad m => a -> v -> m (Tree (PrimState m) a v) +singleton tLabel tValue = + fmap Tree $ MutVar.newMutVar $! T nil nil nil tLabel tValue tValue + +readRoot :: PrimMonad m => Tree (PrimState m) a v -> m (Tree (PrimState m) a v) +readRoot tree = do + T {..} <- MutVar.readMutVar (unTree tree) + if tParent == nil then return tree else readRoot tParent + +-- | `lv` must be a singleton tree +cons + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +cons lt@(Tree lv) rt@(Tree rv) = do + r <- MutVar.readMutVar rv + MutVar.modifyMutVar' lv $ \l -> l {tRight = rt, tAgg = tAgg l <> tAgg r} + MutVar.writeMutVar rv $! r {tParent = lt} + return lt + +-- | `rv` must be a singleton tree +snoc + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +snoc lt@(Tree lv) rt@(Tree rv) = do + l <- MutVar.readMutVar lv + MutVar.modifyMutVar' rv $ \r -> r {tLeft = lt, tAgg = tAgg l <> tAgg r} + MutVar.writeMutVar lv $! l {tParent = rt} + return rt + +-- | Appends two trees. Returns the root of the tree. +append + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +append xt@(Tree _xv) yt@(Tree yv) = do + rmt@(Tree rmv) <- getRightMost xt + _ <- splay rmt + y <- MutVar.readMutVar yv + MutVar.modifyMutVar rmv $ \r -> r {tRight = yt, tAgg = tAgg r <> tAgg y} + MutVar.writeMutVar yv $! y {tParent = rmt} + return rmt + where + getRightMost tt@(Tree tv) = do + t <- MutVar.readMutVar tv + if tRight t == nil then return tt else getRightMost (tRight t) + +split + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v)) +split xt@(Tree xv) = do + _ <- splay xt + T {..} <- MutVar.readMutVar xv + when (tLeft /= nil) (removeParent tLeft) -- Works even if l is x + when (tRight /= nil) (removeParent tRight) + MutVar.writeMutVar xv $ T {tAgg = tValue, ..} + removeLeft xt + removeRight xt + return + ( if tLeft == nil then Nothing else Just tLeft + , if tRight == nil then Nothing else Just tRight + ) + +connected + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> Tree (PrimState m) a v + -> m Bool +connected x y = do + _ <- splay x + x' <- splay y + return $ x == x' + +root + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) +root x = do + _ <- splay x + return x + +label + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m a +label (Tree xv) = tLabel <$> MutVar.readMutVar xv + +aggregate + :: (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m v +aggregate (Tree xv) = tAgg <$> MutVar.readMutVar xv + +-- | For debugging/testing. +toList + :: PrimMonad m => Tree (PrimState m) a v -> m [a] +toList = go [] + where + go acc0 (Tree tv) = do + T {..} <- MutVar.readMutVar tv + acc1 <- if tRight == nil then return acc0 else go acc0 tRight + let acc2 = tLabel : acc1 + if tLeft == nil then return acc2 else go acc2 tLeft + +splay + :: forall m a v. (PrimMonad m, Monoid v) + => Tree (PrimState m) a v + -> m (Tree (PrimState m) a v) -- Returns the old root. +splay xt@(Tree xv) = do + -- Note (jaspervdj): Rather than repeatedly reading from/writing to xv we + -- read x once and thread its (continuously updated) value through the + -- entire stack of `go` calls. + -- + -- The same is true for the left and right aggregates of x: they can be + -- passed upwards rather than recomputed. + x0 <- MutVar.readMutVar xv + xla <- if tLeft x0 == nil then return mempty else tAgg <$> MutVar.readMutVar (unTree $ tLeft x0) + xra <- if tRight x0 == nil then return mempty else tAgg <$> MutVar.readMutVar (unTree $ tRight x0) + go xt xla xra x0 + where + go :: Tree (PrimState m) a v -> v -> v -> T (PrimState m) a v + -> m (Tree (PrimState m) a v) + go closestToRootFound xla xra !x = do + let !(pt@(Tree pv)) = tParent x + if pt == nil then do + MutVar.writeMutVar xv x + return closestToRootFound + else do + p <- MutVar.readMutVar pv + let gt@(Tree gv) = tParent p + let plt@(Tree plv) = tLeft p + let prt@(Tree prv) = tRight p + let xlt@(Tree xlv) = tLeft x + let xrt@(Tree xrv) = tRight x + if | gt == nil, plt == xt -> do + -- ZIG (Right) + -- + -- p => x + -- / \ + -- x p + -- \ / + -- xr xr + -- + when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr -> + xr {tParent = pt} + + pra <- if prt == nil then return mempty else tAgg <$> MutVar.readMutVar prv + MutVar.writeMutVar pv $! p + { tLeft = xrt + , tParent = xt + , tAgg = xra <> tValue p <> pra + } + + MutVar.writeMutVar xv $! x + { tAgg = tAgg p + , tRight = pt + , tParent = nil + } + + return pt + + | gt == nil -> do + -- ZIG (Left) + -- + -- p => x + -- \ / + -- x p + -- / \ + -- xl xl + -- + when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl -> + xl {tParent = pt} + + pla <- if plt == nil then return mempty else tAgg <$> MutVar.readMutVar plv + MutVar.writeMutVar pv $! p + { tRight = xlt + , tParent = xt + , tAgg = pla <> tValue p <> xla + } + + MutVar.writeMutVar xv $! x + { tAgg = tAgg p + , tLeft = pt + , tParent = nil + } + + return pt + + | otherwise -> do + + g <- MutVar.readMutVar gv + let ggt@(Tree ggv) = tParent g + let glt@(Tree glv) = tLeft g + let grt@(Tree grv) = tRight g + when (ggt /= nil) $ MutVar.modifyMutVar' ggv $ \gg -> + if tLeft gg == gt + then gg {tLeft = xt} + else gg {tRight = xt} + + if | plt == xt && glt == pt -> do + -- ZIGZIG (Right): + -- + -- gg gg + -- | | + -- g x + -- / \ / \ + -- p => p + -- / \ / \ + -- x pr xr g + -- / \ / + -- xr pr + -- + + pra <- if prt == nil then return mempty else tAgg <$> MutVar.readMutVar prv + gra <- if grt == nil then return mempty else tAgg <$> MutVar.readMutVar grv + let !ga' = pra <> tValue g <> gra + when (prt /= nil) $ MutVar.modifyMutVar' prv $ \pr -> + pr {tParent = gt} + + MutVar.writeMutVar gv $! g + { tParent = pt + , tLeft = prt + , tAgg = ga' + } + + when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr -> + xr {tParent = pt} + + let !pa' = xra <> tValue p <> ga' + MutVar.writeMutVar pv $! p + { tParent = xt + , tLeft = xrt + , tRight = gt + , tAgg = pa' + } + + go gt xla pa' $! x + { tRight = pt + , tAgg = tAgg g + , tParent = ggt + } + + | plv /= xv && glv /= pv -> do + -- ZIGZIG (Left): + -- + -- gg gg + -- | | + -- g x + -- / \ / \ + -- p => p + -- / \ / \ + -- pl x g xl + -- / \ / \ + -- xl pl + -- + pla <- if plt == nil then return mempty else tAgg <$> MutVar.readMutVar plv + gla <- if glt == nil then return mempty else tAgg <$> MutVar.readMutVar glv + let !ga' = gla <> tValue g <> pla + when (plt /= nil) $ MutVar.modifyMutVar' plv $ \pl -> + pl {tParent = gt} + + MutVar.writeMutVar gv $! g + { tParent = pt + , tRight = plt + , tAgg = ga' + } + + when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl -> + xl {tParent = pt} + + let !pa' = ga' <> tValue p <> xla + MutVar.writeMutVar pv $! p + { tParent = xt + , tLeft = gt + , tRight = xlt + , tAgg = pa' + } + + go gt pa' xra $! x + { tLeft = pt + , tAgg = tAgg g + , tParent = ggt + } + + | plv == xv -> do + -- ZIGZIG (Left): + -- + -- gg gg + -- | | + -- g x + -- \ / \ + -- p => g p + -- / \ / + -- x xl xr + -- / \ + -- xl xr + -- + when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl -> + xl {tParent = gt} + + gla <- if glt == nil then return mempty else tAgg <$> MutVar.readMutVar glv + let !ga' = gla <> tValue g <> xla + MutVar.writeMutVar gv $! g + { tParent = xt + , tRight = xlt + , tAgg = ga' + } + + when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr -> + xr {tParent = pt} + + pra <- if prt == nil then return mempty else tAgg <$> MutVar.readMutVar prv + let pa' = xra <> tValue p <> pra + MutVar.writeMutVar pv $! p + { tParent = xt + , tLeft = xrt + , tAgg = pa' + } + + go gt ga' pa' $! x + { tParent = ggt + , tLeft = gt + , tRight = pt + , tAgg = tAgg g + } + + | otherwise -> do + -- ZIGZIG (Right): + -- + -- gg gg + -- | | + -- g x + -- / / \ + -- p => p g + -- \ \ / + -- x xl xr + -- / \ + -- xl xr + -- + when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr -> + xr {tParent = gt} + + gra <- if grt == nil then return mempty else tAgg <$> MutVar.readMutVar grv + let !ga' = xra <> tValue g <> gra + MutVar.writeMutVar gv $! g + { tParent = xt + , tLeft = xrt + , tAgg = ga' + } + + when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl -> + xl {tParent = pt} + + pla <- if plt == nil then return mempty else tAgg <$> MutVar.readMutVar plv + let !pa' = pla <> tValue p <> xla + MutVar.writeMutVar pv $! p + { tParent = xt + , tRight = xlt + , tAgg = pa' + } + + go gt pa' ga' $! x + { tParent = ggt + , tLeft = pt + , tRight = gt + , tAgg = tAgg g + } + +removeParent, removeLeft, removeRight + :: PrimMonad m + => Tree (PrimState m) a v -- Parent + -> m () +removeParent (Tree x) = MutVar.modifyMutVar' x $ \x' -> x' {tParent = nil} +removeLeft (Tree x) = MutVar.modifyMutVar' x $ \x' -> x' {tLeft = nil} +removeRight (Tree x) = MutVar.modifyMutVar' x $ \x' -> x' {tRight = nil} + +-- | For debugging/testing. +freeze :: PrimMonad m => Tree (PrimState m) a v -> m (Tree.Tree a) +freeze (Tree tv) = do + T {..} <- MutVar.readMutVar tv + children <- sequence $ + [freeze tLeft | tLeft /= nil] ++ + [freeze tRight | tRight /= nil] + return $ Tree.Node tLabel children + +print :: Show a => Tree (PrimState IO) a v -> IO () +print = go 0 + where + go d (Tree tv) = do + T {..} <- MutVar.readMutVar tv + when (tLeft /= nil) $ go (d + 1) tLeft + putStrLn $ replicate d ' ' ++ show tLabel + when (tRight /= nil) $ go (d + 1) tRight + +assertInvariants + :: (PrimMonad m, Monoid v, Eq v, Show v) => Tree (PrimState m) a v -> m () +assertInvariants t = do + _ <- computeAgg nil t + return () + where + -- TODO: Check average + computeAgg pt xt@(Tree xv) = do + x' <- MutVar.readMutVar xv + let p' = tParent x' + when (pt /= p') $ fail "broken parent pointer" + + let l = tLeft x' + let r = tRight x' + la <- if l == nil then return mempty else computeAgg xt l + ra <- if r == nil then return mempty else computeAgg xt r + + let actualAgg = la <> (tValue x') <> ra + let storedAgg = tAgg x' + + when (actualAgg /= storedAgg) $ fail $ + "error in stored aggregates: " ++ show storedAgg ++ + ", actual: " ++ show actualAgg + + return actualAgg + +data TreeGen s = TreeGen + +instance Class.Tree Tree where + type TreeGen Tree = TreeGen + newTreeGen _ = return TreeGen + + singleton _ = singleton + append = append + split = split + connected = connected + root = root + readRoot = readRoot + label = label + aggregate = aggregate + toList = toList + +instance Class.TestTree Tree where + print = print + assertInvariants = assertInvariants + assertSingleton = \_ -> return () + assertRoot = \_ -> return () diff --git a/src/Data/Graph/Dynamic/Internal/Tree.hs b/src/Data/Graph/Dynamic/Internal/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/Internal/Tree.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Graph.Dynamic.Internal.Tree + ( Tree (..) + , concat + + , TestTree (..) + ) where + +import Control.Monad (foldM) +import Control.Monad.Primitive (PrimMonad (..)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy (Proxy) +import Prelude hiding (concat) + +-- | The chosen represenation of the tree has a big impact on the performance of +-- the algorithms. This typeclass allows us to swap them out more easily. +class Tree (t :: * -> * -> * -> *) where + -- | A management structure used to create new trees + type TreeGen t :: * -> * + + -- | Create a tree gen itself + newTreeGen + :: PrimMonad m => Proxy t -> m (TreeGen t (PrimState m)) + + -- | Create a tree with a single element. + singleton + :: (PrimMonad m, Monoid v) + => TreeGen t (PrimState m) -> a -> v -> m (t (PrimState m) a v) + + -- | Join two trees together. + append + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v -> t (PrimState m) a v + -> m (t (PrimState m) a v) + + -- | Prepend a singleton tree + cons + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v -> t (PrimState m) a v + -> m (t (PrimState m) a v) + cons = append + + -- | Append a singleton tree + snoc + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v -> t (PrimState m) a v + -> m (t (PrimState m) a v) + snoc = append + + -- | Split a tree, turning the argument into a singleton and returning the + -- left and right halves of the tree. + split + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v + -> m (Maybe (t (PrimState m) a v), Maybe (t (PrimState m) a v)) + + -- | Check if two nodes belong to the same tree + connected + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v -> t (PrimState m) a v + -> m Bool + + -- | Find the root of a tree + root + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v + -> m (t (PrimState m) a v) + + -- | Read the root of a tree. This is not allowed to modify the tree (e.g., + -- no splaying allowed). + readRoot + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v + -> m (t (PrimState m) a v) + readRoot = root + + -- | Read the label from a tree + label + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v + -> m a + + -- | Read the aggregate of a tree + aggregate + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v + -> m v + + -- | Convert a tree to a list + toList + :: (PrimMonad m, Monoid v) + => t (PrimState m) a v + -> m [a] + +concat + :: forall t m a v. (Tree t, PrimMonad m, Monoid v) + => NonEmpty (t (PrimState m) a v) + -> m (t (PrimState m) a v) +concat trees0 = + case trees0 of x NonEmpty.:| xs -> foldM append x xs + +-- | These methods can be used for testing and debugging. +class Tree t => TestTree t where + print + :: Show a + => t (PrimState IO) a v -> IO () + + assertInvariants + :: (PrimMonad m, Monoid v, Eq v, Show v) + => t (PrimState m) a v -> m () + + assertSingleton + :: (PrimMonad m, Monoid v, Eq v, Show v) + => t (PrimState m) a v -> m () + + assertRoot + :: (PrimMonad m, Monoid v, Eq v, Show v) + => t (PrimState m) a v -> m () diff --git a/src/Data/Graph/Dynamic/Levels.hs b/src/Data/Graph/Dynamic/Levels.hs new file mode 100644 --- /dev/null +++ b/src/Data/Graph/Dynamic/Levels.hs @@ -0,0 +1,395 @@ +-- | This module implements full dynamic grah connectivity. +-- +-- It is based on: +-- /Poly-logarithmic deterministic fully-dynamic algorithms for connectivity, minimum spanning tree, 2-edge, and biconnectivity/ +-- by /Jacob Holm, Kristian de Lichtenberg and Mikkel Thorup/ (1998). +-- +-- We use two naming conventions in this module: +-- +-- * A prime suffix (@'@) indicates a simpler or less polymorphic version of a +-- function or datatype. For example, see 'empty' and 'empty'', and +-- 'Graph' and 'Graph''. +-- +-- * An underscore suffix (@_@) means that the return value is ignored. For +-- example, see 'link' and 'link_'. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Graph.Dynamic.Levels + ( -- * Type + Graph + , Graph' + + -- * Construction + , empty + , empty' + , edgeless + , edgeless' + , complete + , complete' + + -- * Queries + , connected + , edge + , vertex + , neighbours + + -- * Modifying + , link + , link_ + , cut + , cut_ + , insert + , insert_ + , delete + , delete_ + + -- * Advanced/internal + , spanningForest + ) where + +import Control.Monad +import Control.Monad.Primitive +import Data.Bits +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HMS +import qualified Data.HashSet as HS +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Primitive.MutVar +import qualified Data.Tree as DT +import qualified Data.Vector.Mutable as VM + +import qualified Data.Graph.Dynamic.EulerTour as ET +import qualified Data.Graph.Dynamic.Internal.Random as Random +import Data.Graph.Dynamic.Internal.Tree (Tree) +import qualified Data.Graph.Dynamic.Internal.Tree as Tree + +type EdgeSet v = HMS.HashMap v (HS.HashSet v) + +linkEdgeSet :: (Eq v, Hashable v) => v -> v -> EdgeSet v -> EdgeSet v +linkEdgeSet x y = + HMS.insertWith HS.union x (HS.singleton y) . + HMS.insertWith HS.union y (HS.singleton x) + +cutEdgeSet :: (Eq v, Hashable v) => v -> v -> EdgeSet v -> EdgeSet v +cutEdgeSet x y = HMS.adjust (HS.delete x) y . HMS.adjust (HS.delete y) x + +memberEdgeSet :: (Eq v, Hashable v) => v -> v -> EdgeSet v -> Bool +memberEdgeSet x y = maybe False (y `HS.member`) . HMS.lookup x + +data L t s v = L + { numVerts :: !Int + , allEdges :: !(EdgeSet v) + , unLevels :: !(VM.MVector s (ET.Forest t (Sum Int) s v, EdgeSet v)) + } + +newtype Graph t s v = Graph (MutVar s (L t s v)) + +type Graph' s v = Graph Random.Tree s v + +logBase2 :: Int -> Int +logBase2 x = finiteBitSize x - 1 - countLeadingZeros x + +-- | /O(1)/ +-- +-- Create an empty graph. +empty :: (Eq v, Hashable v, Tree t, PrimMonad m) => m (Graph t (PrimState m) v) +empty = edgeless [] + +-- | Simple version of 'empty'. +empty' :: (Eq v, Hashable v, PrimMonad m) => m (Graph' (PrimState m) v) +empty' = empty + +-- | Create a graph with the given vertices but no edges. +edgeless + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => [v] -> m (Graph t (PrimState m) v) +edgeless xs = do + unLevels <- VM.new 0 + let allEdges = HMS.empty + numVerts = 0 + g <- Graph <$> newMutVar L {..} + mapM_ (insert g) xs + return g + +-- | Simple version of 'edgeless'. +edgeless' + :: (Eq v, Hashable v, PrimMonad m) => [v] -> m (Graph' (PrimState m) v) +edgeless' = edgeless + +-- | Create the complete graph with the given vertices. +complete + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => [v] -> m (Graph t (PrimState m) v) +complete vertices = do + g <- edgeless vertices + forM_ (pairs vertices) $ \(x, y) -> link g x y + return g + where + pairs :: [a] -> [(a, a)] + pairs [] = [] + pairs (x : xs) = + [(x, y) | y <- xs] ++ pairs xs + +-- | Simple version of 'complete' +complete' + :: (Eq v, Hashable v, PrimMonad m) => [v] -> m (Graph' (PrimState m) v) +complete' = complete + +-- | /O(log(v))/ +-- +-- Insert an edge in between two vertices. If the vertices already have +-- an edge between them don't do anything. Returns whether or not an edge was +-- actually inserted. +link + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> v -> m Bool +link (Graph levels) a b = do + L {..} <- readMutVar levels + let !newAllEdges = linkEdgeSet a b allEdges + if memberEdgeSet a b allEdges || a == b || VM.null unLevels + then return False + else do + (thisEtf, thisNonTreeEdges) <- VM.read unLevels 0 + isTreeEdge <- ET.link thisEtf a b + let !thisNonTreeEdges' + | isTreeEdge = thisNonTreeEdges + | otherwise = linkEdgeSet a b thisNonTreeEdges + + VM.write unLevels 0 (thisEtf, thisNonTreeEdges') + writeMutVar levels $ L + {allEdges = newAllEdges, unLevels = unLevels, numVerts = numVerts} + return True + +-- | Version of 'link' which ignores the result. +link_ + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> v -> m () +link_ g a b = void (link g a b) + +-- | /O(log(v))/ +-- +-- Check if a path exists in between two vertices. +connected + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> v -> m Bool +connected _ a b | a == b = return True +connected (Graph levels) a b = do + L {..} <- readMutVar levels + if VM.null unLevels + then return False + else do + (etf, _) <- VM.read unLevels 0 + ET.connected etf a b + +-- | Check if this edge exists in the graph. +edge + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> v -> m Bool +edge (Graph levels) a b = do + L {..} <- readMutVar levels + return $ memberEdgeSet a b allEdges + +-- | Check if this vertex exists in the graph. +vertex + :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> m Bool +vertex (Graph levels) a = do + L {..} <- readMutVar levels + return $ a `HMS.member` allEdges + +-- | Ammortized /O(log² v)/ +-- +-- Remove an edge in between two vertices. If there is no edge in between +-- these vertices, do nothing. Return whether or not an edge was actually +-- removed. +cut + :: forall t m v. (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> v -> m Bool +cut (Graph levels) a b = do + L {..} <- readMutVar levels + let newAllEdges = cutEdgeSet a b allEdges + if VM.length unLevels == 0 || a == b + then return False + else do + cut' <- go unLevels (VM.length unLevels-1) + writeMutVar levels L {allEdges = newAllEdges, ..} + return cut' + where + go :: VM.MVector (PrimState m) (ET.Forest t (Sum Int) (PrimState m) v, EdgeSet v) -> Int -> m Bool + go unLevels idx = do + -- traceShowM ("go", idx) + (etf, nonTreeEdges0) <- VM.read unLevels idx + cutResult <- ET.cut etf a b + case cutResult of + False -> do + let !nonTreeEdges1 = cutEdgeSet a b nonTreeEdges0 + VM.write unLevels idx (etf, nonTreeEdges1) + if idx > 0 then go unLevels (idx - 1) else return False + True -> do + aSize <- ET.componentSize etf a + bSize <- ET.componentSize etf b + let (smaller, _bigger) = if aSize <= bSize then (a, b) else (b, a) + Just sRoot <- ET.findRoot etf smaller + + -- These are all edges, and vertices within the smaller tree. + sTreeEdges <- Tree.toList sRoot + let !sVertices = HS.fromList $ map fst $ + filter (uncurry (==)) sTreeEdges + + -- We need to consider all edges incident to the smaller tree. + let sIncidentEdges = + [ (x, y) + | x <- HS.toList sVertices + , y <- maybe [] HS.toList (HMS.lookup x nonTreeEdges0) + ] + + -- Find a replacement and punish all edges we visit. + let findRep punish [] = (punish, Nothing) + findRep punish ((x, y) : candidates) + | y `HS.member` sVertices = + findRep ((x, y) : punish) candidates + | otherwise = + (punish, Just (x, y)) + + -- Perform the search + let (punished, replacementEdge) = findRep [] sIncidentEdges + + -- Increase the levels of the tree edges and the punished edges. + nonTreeEdges1 <- if + | idx + 1 >= VM.length unLevels -> return nonTreeEdges0 + | otherwise -> do + (incEtf, incNonTreeEdges0) <- VM.read unLevels (idx + 1) + + let moveTreeEdge (x, y) = + ET.link_ incEtf x y + + let moveNonTreeEdge !(ntes, !incNTes) (x, y) = + (cutEdgeSet x y ntes, linkEdgeSet x y incNTes) + + mapM_ moveTreeEdge sTreeEdges + let !(!nonTreeEdges1, !incNonTreeEdges1) = L.foldl' + moveNonTreeEdge (nonTreeEdges0, incNonTreeEdges0) punished + + VM.write unLevels (idx + 1) (incEtf, incNonTreeEdges1) + return nonTreeEdges1 + + case replacementEdge of + Nothing -> do + VM.write unLevels idx (etf, nonTreeEdges1) + if idx > 0 then go unLevels (idx - 1) else return True + Just rep@(c, d) -> do + let !nonTreeEdges2 = cutEdgeSet c d nonTreeEdges1 + VM.write unLevels idx (etf, nonTreeEdges2) + ET.link_ etf c d + propagateReplacement unLevels (idx - 1) rep + return True + + propagateReplacement unLevels idx (c, d) = when (idx >= 0) $ do + (etf, _) <- VM.read unLevels idx + ET.cut_ etf a b + ET.link_ etf c d + -- TODO: mess with edges?? + propagateReplacement unLevels (idx - 1) (c, d) + +-- | Version of 'cut' which ignores the result. +cut_ + :: forall t m v. (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> v -> m () +cut_ g a b = void (cut g a b) + +-- | Insert a new vertex. Do nothing if it is already there. Returns whether +-- or not a vertex was inserted in the graph. +insert + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> m Bool +insert (Graph g) x = do + l@L {..} <- readMutVar g + if HMS.member x allEdges then + return False + else do + let newAllEdges = HMS.insert x HS.empty allEdges + let numVertices = numVerts + 1 + unLevels' <- do + let oldNumLevels = VM.length unLevels + newUnLevels <- VM.take (logBase2 numVertices + 1) <$> + VM.grow unLevels (max 0 $ logBase2 numVertices - oldNumLevels + 1) + forM_ [oldNumLevels .. logBase2 numVertices] $ \levelIdx -> do + df <- ET.edgeless (\v1 v2 -> if v1 == v2 then Sum 1 else Sum 0) $ map fst $ HMS.toList allEdges + VM.write newUnLevels levelIdx (df, HMS.empty) + return newUnLevels + let updateLevel i + | i >= VM.length unLevels' = return () + | otherwise = do + (forest, nt) <- VM.read unLevels' i + ET.insert_ forest x + VM.write unLevels' i (forest, nt) + updateLevel (i + 1) + + updateLevel 0 + writeMutVar g $ l {allEdges = newAllEdges, unLevels = unLevels', numVerts = numVertices} + return True + +-- | Version of 'insert' which ignores the result. +insert_ + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> m () +insert_ g x = void (insert g x) + +-- | Remove a vertex from the graph, if it exists. If it is connected to any +-- other vertices, those edges are cut first. Returns whether or not a vertex +-- was removed from the graph. +delete + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> m Bool +delete g@(Graph levels) x = do + l0 <- readMutVar levels + case HMS.lookup x (allEdges l0) of + Nothing -> return False + Just nbs -> do + forM_ nbs $ \y -> cut g x y + + l1 <- readMutVar levels + let newAllEdges = HMS.delete x (allEdges l1) + updateLevel i + | i >= VM.length (unLevels l1) = return () + | otherwise = do + (forest, nt) <- VM.read (unLevels l1) i + ET.delete_ forest x + VM.write (unLevels l1) i (forest, HMS.delete x nt) + updateLevel (i + 1) + + updateLevel 0 + writeMutVar levels $ l1 {allEdges = newAllEdges, numVerts = numVerts l0 - 1} + return True + +-- | Version of 'delete' which ignores the result. +delete_ + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> m () +delete_ g x = void (delete g x) + +-- | Get all neighbours of the given vertex. +neighbours + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> v -> m (HS.HashSet v) +neighbours (Graph levels) x = do + l0 <- readMutVar levels + return $ fromMaybe HS.empty (HMS.lookup x (allEdges l0)) + +-- | Obtain the current spanning forest. +spanningForest + :: (Eq v, Hashable v, Tree t, PrimMonad m) + => Graph t (PrimState m) v -> m (DT.Forest v) +spanningForest (Graph levels) = do + L {..} <- readMutVar levels + if VM.null unLevels + then return [] + else do + (etf, _) <- VM.read unLevels 0 + ET.spanningForest etf diff --git a/tests/Data/Graph/Dynamic/Action.hs b/tests/Data/Graph/Dynamic/Action.hs new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 diff --git a/tests/Suite.hs b/tests/Suite.hs new file mode 100644 --- /dev/null +++ b/tests/Suite.hs @@ -0,0 +1,15 @@ +import qualified Data.Graph.Dynamic.EulerTour.Tests +import qualified Data.Graph.Dynamic.Internal.Avl.Tests +import qualified Data.Graph.Dynamic.Internal.Random.Tests +import qualified Data.Graph.Dynamic.Internal.Splay.Tests +import qualified Data.Graph.Dynamic.Levels.Tests +import Test.Framework + +main :: IO () +main = defaultMain + [ Data.Graph.Dynamic.EulerTour.Tests.tests + , Data.Graph.Dynamic.Internal.Avl.Tests.tests + , Data.Graph.Dynamic.Internal.Random.Tests.tests + , Data.Graph.Dynamic.Internal.Splay.Tests.tests + , Data.Graph.Dynamic.Levels.Tests.tests + ]