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