packages feed

dynamic-graphs (empty) → 0.1.0.1

raw patch · 26 files changed

+3423/−0 lines, 26 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, containers, criterion, deepseq, dynamic-graphs, hashable, hashtables, mwc-random, primitive, test-framework, test-framework-quickcheck2, test-framework-th, text, unordered-containers, vector

Files

+ CHANGELOG.md view
@@ -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>
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/bench.hs view
@@ -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]]
+ benchmarks/hs/bench-program.hs view
@@ -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)+        ]
+ benchmarks/hs/gen-program.hs view
@@ -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
+ benchmarks/simple.hs view
@@ -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]]
+ dynamic-graphs.cabal view
@@ -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
+ src/Data/Graph/Dynamic/EulerTour.hs view
@@ -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
+ src/Data/Graph/Dynamic/Internal/Avl.hs view
@@ -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
+ src/Data/Graph/Dynamic/Internal/HashTable.hs view
@@ -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
+ src/Data/Graph/Dynamic/Internal/Random.hs view
@@ -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
+ src/Data/Graph/Dynamic/Internal/Splay.hs view
@@ -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 ()
+ src/Data/Graph/Dynamic/Internal/Tree.hs view
@@ -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 ()
+ src/Data/Graph/Dynamic/Levels.hs view
@@ -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
+ tests/Data/Graph/Dynamic/Action.hs view
@@ -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))
+ tests/Data/Graph/Dynamic/EulerTour/Tests.hs view
@@ -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
+ tests/Data/Graph/Dynamic/Internal/Avl/Tests.hs view
@@ -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)
+ tests/Data/Graph/Dynamic/Internal/Random/Tests.hs view
@@ -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)
+ tests/Data/Graph/Dynamic/Internal/Splay/Tests.hs view
@@ -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)
+ tests/Data/Graph/Dynamic/Internal/Tree/Tests.hs view
@@ -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
+ tests/Data/Graph/Dynamic/Levels/Tests.hs view
@@ -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
+ tests/Data/Graph/Dynamic/Program.hs view
@@ -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
+ tests/Data/Graph/Dynamic/Slow.hs view
@@ -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
+ tests/Suite.hs view
@@ -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+    ]