summaryrefslogtreecommitdiff
path: root/src/Data/Graph/Dynamic
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Graph/Dynamic')
-rw-r--r--src/Data/Graph/Dynamic/EulerTour.hs438
-rw-r--r--src/Data/Graph/Dynamic/Internal/Avl.hs483
-rw-r--r--src/Data/Graph/Dynamic/Internal/HashTable.hs49
-rw-r--r--src/Data/Graph/Dynamic/Internal/Random.hs269
-rw-r--r--src/Data/Graph/Dynamic/Internal/Splay.hs511
-rw-r--r--src/Data/Graph/Dynamic/Internal/Tree.hs120
-rw-r--r--src/Data/Graph/Dynamic/Levels.hs395
7 files changed, 2265 insertions, 0 deletions
diff --git a/src/Data/Graph/Dynamic/EulerTour.hs b/src/Data/Graph/Dynamic/EulerTour.hs
new file mode 100644
index 0000000..adbe230
--- /dev/null
+++ b/src/Data/Graph/Dynamic/EulerTour.hs
@@ -0,0 +1,438 @@
+-- | This module provides dynamic connectivity for an acyclic graph (i.e. a
+-- forest).
+--
+-- It is based on:
+-- /Finding biconnected components and computing tree functions in logarithmic parallel time/
+-- by /Robert E. Tarjan and Uzi Vishki/ (1984).
+--
+-- We use two naming conventions in this module:
+--
+-- * A prime suffix (@'@) indicates a simpler or less polymorphic version of a
+-- function or datatype. For example, see 'empty' and 'empty'', and
+-- 'Graph' and 'Graph''.
+--
+-- * An underscore suffix (@_@) means that the return value is ignored. For
+-- example, see 'link' and 'link_'.
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Data.Graph.Dynamic.EulerTour
+ ( -- * Type
+ Forest
+ , Graph
+ , Graph'
+
+ -- * Construction
+ , empty
+ , empty'
+ , edgeless
+ , edgeless'
+ , fromTree
+ , fromTree'
+
+ -- * Queries
+ , connected
+ , edge
+ , vertex
+ , neighbours
+
+ -- * Modifying
+ , link
+ , link_
+ , cut
+ , cut_
+ , insert
+ , insert_
+ , delete
+ , delete_
+
+ -- * Advanced/internal operations
+ , findRoot
+ , componentSize
+ , spanningForest
+
+ -- * Debugging
+ , print
+ ) where
+
+import Control.Monad (filterM, foldM, forM_,
+ void)
+import Control.Monad.Primitive
+import qualified Data.Graph.Dynamic.Internal.HashTable as HT
+import qualified Data.Graph.Dynamic.Internal.Random as Random
+import qualified Data.Graph.Dynamic.Internal.Tree as Tree
+import Data.Hashable (Hashable)
+import qualified Data.HashMap.Strict as HMS
+import qualified Data.HashSet as HS
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe
+import Data.Monoid
+import Data.Proxy (Proxy (..))
+import qualified Data.Tree as DT
+import Prelude hiding (print)
+
+-- | The most general type for an Euler Tour Forest. Used by other modules.
+data Forest t a s v = ETF
+ { edges :: {-# UNPACK#-} !(HT.HashTable s v (HMS.HashMap v (t s (v, v) a)))
+ , toMonoid :: v -> v -> a
+ , treeGen :: (Tree.TreeGen t s)
+ }
+
+-- | Graph type polymorphic in the tree used to represent sequences.
+type Graph t s v = Forest t () s v
+
+-- | Simple graph type.
+type Graph' s v = Graph Random.Tree s v
+
+insertTree
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m)
+ => Forest t a s v -> v -> v -> t s (v, v) a -> m ()
+insertTree (ETF ht _ _) x y t = do
+ mbMap <- HT.lookup ht x
+ case mbMap of
+ Nothing -> HT.insert ht x $ HMS.singleton y t
+ Just m -> HT.insert ht x $ HMS.insert y t m
+
+lookupTree
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m)
+ => Forest t a s v -> v -> v -> m (Maybe (t s (v, v) (a)))
+lookupTree (ETF ht _ _) x y = do
+ mbMap <- HT.lookup ht x
+ case mbMap of
+ Nothing -> return Nothing
+ Just m -> return $ HMS.lookup y m
+
+deleteTree
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m)
+ => Forest t a s v -> v -> v -> m ()
+deleteTree (ETF ht _ _) x y = do
+ mbMap <- HT.lookup ht x
+ case mbMap of
+ Nothing -> return ()
+ Just m0 ->
+ let m1 = HMS.delete y m0 in
+ if HMS.null m1 then HT.delete ht x else HT.insert ht x m1
+
+-- | /O(1)/
+--
+-- Create the empty tree.
+empty
+ :: forall t m v a. (Tree.Tree t, PrimMonad m)
+ => (v -> v -> a) -> m (Forest t a (PrimState m) v)
+empty f = do
+ ht <- HT.new
+ tg <- Tree.newTreeGen (Proxy :: Proxy t)
+ return $ ETF ht f tg
+
+-- | Simple version of 'empty'.
+empty'
+ :: PrimMonad m => m (Graph' (PrimState m) v)
+empty' = empty (\_ _ -> ())
+
+-- | /O(v*log(v))/
+--
+-- Create a graph with the given vertices but no edges.
+edgeless
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => (v -> v -> a) -> [v] -> m (Forest t a (PrimState m) v)
+edgeless toMonoid vs = do
+ etf <- empty toMonoid
+ forM_ vs $ \v -> do
+ node <- Tree.singleton (treeGen etf) (v, v) (toMonoid v v)
+ insertTree etf v v node
+ return etf
+
+-- | Simple version of 'edgeless'.
+edgeless'
+ :: (Eq v, Hashable v, PrimMonad m)
+ => [v] -> m (Graph' (PrimState m) v)
+edgeless' = edgeless (\_ _ -> ())
+
+-- | Create a graph from a 'DT.Tree'. Note that the values in nodes must be
+-- unique.
+fromTree
+ :: forall v m t a. (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => (v -> v -> a) -> DT.Tree v -> m (Forest t a (PrimState m) v)
+fromTree toMonoid tree = do
+ etf <- empty toMonoid
+ _ <- go etf tree
+ return etf
+ where
+ go etf (DT.Node l children) = do
+ node0 <- Tree.singleton (treeGen etf) (l, l) (toMonoid l l)
+ insertTree etf l l node0
+ foldM (go' etf l) node0 children
+
+ go' etf parent node0 tr@(DT.Node l _) = do
+ lnode <- go etf tr
+ parentToL <- Tree.singleton (treeGen etf) (parent, l) (toMonoid parent l)
+ lToParent <- Tree.singleton (treeGen etf) (l, parent) (toMonoid l parent)
+
+ node1 <- Tree.concat $ node0 NonEmpty.:| [parentToL, lnode, lToParent]
+ insertTree etf l parent lToParent
+ insertTree etf parent l parentToL
+ return node1
+
+-- | Simple version of 'fromTree'.
+fromTree'
+ :: (Eq v, Hashable v, PrimMonad m)
+ => DT.Tree v -> m (Graph' (PrimState m) v)
+fromTree' = fromTree (\_ _ -> ())
+
+findRoot
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m, Monoid a)
+ => Forest t a s v -> v -> m (Maybe (t s (v, v) a))
+findRoot etf v = do
+ mbTree <- lookupTree etf v v
+ case mbTree of
+ Nothing -> return Nothing
+ Just t -> Just <$> Tree.root t
+
+-- | /O(log(v))/
+--
+-- Remove an edge in between two vertices. If there is no edge in between
+-- these vertices, do nothing. Return whether or not an edge was actually
+-- removed.
+cut
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> v -> m Bool
+cut etf a b = do
+ mbAb <- lookupTree etf a b
+ mbBa <- lookupTree etf b a
+ case (mbAb, mbBa) of
+ _ | a == b -> return False -- Can't cut self-loops
+ (Just ab, Just ba) -> do
+ (part1, part2) <- Tree.split ab
+
+ baIsInPart1 <- case part1 of
+ Just p -> Tree.connected p ba
+ _ -> return False
+
+ (mbL, _, mbR) <- if baIsInPart1 then do
+ (part3, part4) <- Tree.split ba
+ return (part3, part4, part2)
+ else do
+ (part3, part4) <- Tree.split ba
+ return (part1, part3, part4)
+
+ _ <- sequenceA $ Tree.append <$> mbL <*> mbR
+ deleteTree etf a b
+ deleteTree etf b a
+ return True
+
+ (Nothing, _) -> return False -- No edge to cut
+ (_, Nothing) -> return False -- No edge to cut
+
+-- | Version of 'cut' which ignores the result.
+cut_
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> v -> m ()
+cut_ etf a b = void (cut etf a b)
+
+-- | reroot the represented tree by shifting the euler tour. Returns the new
+-- root.
+reroot
+ :: (Tree.Tree t, PrimMonad m, s ~ PrimState m, Monoid v)
+ => t s a v -> m (t s a v)
+reroot t = do
+ (mbPre, mbPost) <- Tree.split t
+ t1 <- maybe (return t) (t `Tree.cons`) mbPost
+ maybe (return t1) (t1 `Tree.append`) mbPre
+
+-- | /O(log(v))/
+--
+-- Check if this edge exists in the graph.
+edge
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m)
+ => Forest t a (PrimState m) v -> v -> v -> m Bool
+edge etf a b = isJust <$> lookupTree etf a b
+
+-- | /O(log(v))/
+--
+-- Check if this vertex exists in the graph.
+vertex
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m)
+ => Forest t a (PrimState m) v -> v -> m Bool
+vertex etf a = isJust <$> lookupTree etf a a
+
+-- | /O(log(v))/
+--
+-- Check if a path exists in between two vertices.
+connected
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> v -> m Bool
+connected etf a b = do
+ mbALoop <- lookupTree etf a a
+ mbBLoop <- lookupTree etf b b
+ case (mbALoop, mbBLoop) of
+ (Just aLoop, Just bLoop) -> Tree.connected aLoop bLoop
+ _ -> return False
+
+-- | /O(log(v))/
+--
+-- Insert an edge in between two vertices. If the vertices are already
+-- connected, we don't do anything, since this is an acyclic graph. Returns
+-- whether or not an edge was actually inserted.
+link
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> v -> m Bool
+link etf@ETF{..} a b = do
+ mbALoop <- lookupTree etf a a
+ mbBLoop <- lookupTree etf b b
+ case (mbALoop, mbBLoop) of
+ (Just aLoop, Just bLoop) -> Tree.connected aLoop bLoop >>= \case
+ True -> return False
+ False -> do
+
+ bLoop1 <- reroot bLoop
+ abNode <- Tree.singleton treeGen (a, b) (toMonoid a b)
+ baNode <- Tree.singleton treeGen (b, a) (toMonoid b a)
+ bLoop2 <- abNode `Tree.cons` bLoop1
+ bLoop3 <- bLoop2 `Tree.snoc` baNode
+ (mbPreA, mbPostA) <- Tree.split aLoop
+
+ _ <- Tree.concat $
+ aLoop NonEmpty.:| catMaybes
+ [ Just bLoop3
+ , mbPostA
+ , mbPreA
+ ]
+
+ insertTree etf a b abNode
+ insertTree etf b a baNode
+ return True
+
+ _ -> return False
+
+-- | Version of 'link' which ignores the result.
+link_
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> v -> m ()
+link_ etf a b = void (link etf a b)
+
+-- | /O(log(v))/
+--
+-- Insert a new vertex. Do nothing if it is already there. Returns whether
+-- or not a vertex was inserted in the graph.
+insert
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> m Bool
+insert etf@ETF{..} v = do
+ mbTree <- lookupTree etf v v
+ case mbTree of
+ Just _ -> return False
+ Nothing -> do
+ node <- Tree.singleton treeGen (v, v) (toMonoid v v)
+ insertTree etf v v node
+ return True
+
+-- | Version of 'insert' which ignores the result.
+insert_
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> m ()
+insert_ etf v = void (insert etf v)
+
+-- | /O(log(v) + n/ where /n/ is the number of neighbours
+--
+-- Get all neighbours of the given vertex.
+neighbours
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> m [v]
+neighbours etf x = fromMaybe [] <$> maybeNeighbours etf x
+
+maybeNeighbours
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> m (Maybe [v])
+maybeNeighbours (ETF ht _ _) x = do
+ mbMap <- HT.lookup ht x
+ case mbMap of
+ Nothing -> return Nothing
+ Just m -> return $ Just $ filter (/= x) $ map fst $ HMS.toList m
+
+-- | /O(n*log(v))/ where /n/ is the number of neighbours
+--
+-- Remove a vertex from the graph, if it exists. If it is connected to any
+-- other vertices, those edges are cut first. Returns whether or not a vertex
+-- was removed from the graph.
+delete
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> m Bool
+delete etf x = do
+ mbNbs <- maybeNeighbours etf x
+ case mbNbs of
+ Nothing -> return False
+ Just nbs -> do
+ forM_ nbs $ \y -> cut etf x y
+ deleteTree etf x x
+ return True
+
+-- | Version of 'delete' which ignores the result.
+delete_
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, Monoid a)
+ => Forest t a (PrimState m) v -> v -> m ()
+delete_ etf x = void (delete etf x)
+
+print :: (Show a, Monoid b, Tree.TestTree t) => Forest t b RealWorld a -> IO ()
+print (ETF ht _ _) = do
+ maps <- map snd <$> HT.toList ht
+ let trees = concatMap (map snd . HMS.toList) maps
+ comps <- components trees
+ forM_ comps $ \comp -> do
+ root <- Tree.root comp
+ Tree.print root
+ putStrLn ""
+ where
+ components [] = return []
+ components (t : ts) = do
+ ts' <- filterM (fmap not . Tree.connected t) ts
+ (t :) <$> components ts'
+
+componentSize
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m, s ~ PrimState m)
+ => Forest t (Sum Int) s v -> v -> m Int
+componentSize etf v = do
+ mbTree <- lookupTree etf v v
+ case mbTree of
+ Nothing -> return 0
+ Just tree -> do
+ root <- Tree.root tree
+ getSum <$> Tree.aggregate root
+
+-- | Obtain the current spanning forest.
+spanningForest
+ :: (Eq v, Hashable v, Tree.Tree t, Monoid a, PrimMonad m)
+ => Forest t a (PrimState m) v -> m (DT.Forest v)
+spanningForest (ETF ht _ _) = do
+ maps <- map snd <$> HT.toList ht
+ let trees = concatMap (map snd . HMS.toList) maps
+ go HS.empty [] trees
+ where
+ go _visited acc [] = return acc
+ go visited acc (t : ts) = do
+ root <- Tree.readRoot t
+ label <- Tree.label root
+ if HS.member label visited then
+ go visited acc ts
+ else do
+ st <- spanningTree root
+ go (HS.insert label visited) (st : acc) ts
+
+spanningTree
+ :: (Eq v, Hashable v, PrimMonad m, Monoid e, Tree.Tree t)
+ => t (PrimState m) (v, v) e -> m (DT.Tree v)
+spanningTree tree = do
+ list <- Tree.toList tree
+ case list of
+ ((r, _) : _) -> return $ DT.Node r (fst $ go Nothing [] list)
+ _ -> fail
+ "Data.Graph.Dynamic..EulerTour.spanningTree: empty list"
+ where
+ go _mbParent acc [] = (acc, [])
+ go mbParent acc ((a, b) : edges)
+ | a == b = go mbParent acc edges -- Ignore self-loops.
+ | Just b == mbParent = (acc, edges) -- Like a closing bracket.
+ | otherwise =
+ -- Parse child.
+ let (child, rest) = go (Just a) [] edges in
+ go mbParent (DT.Node b child : acc) rest
diff --git a/src/Data/Graph/Dynamic/Internal/Avl.hs b/src/Data/Graph/Dynamic/Internal/Avl.hs
new file mode 100644
index 0000000..4f02445
--- /dev/null
+++ b/src/Data/Graph/Dynamic/Internal/Avl.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Graph.Dynamic.Internal.Avl
+ ( Tree
+
+ , singleton
+ , append
+ , concat
+ , join
+ , split
+ , root
+ , connected
+ , label
+ , aggregate
+ , toList
+
+ -- * Debugging only
+ , freeze
+ , print
+ , assertInvariants
+ , assertSingleton
+ , assertRoot
+ ) where
+
+import Control.Monad (foldM, when)
+import Control.Monad.Primitive (PrimMonad (..))
+import qualified Data.Graph.Dynamic.Internal.Tree as Class
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Monoid ((<>))
+import Data.Primitive.MutVar (MutVar)
+import qualified Data.Primitive.MutVar as MutVar
+import qualified Data.Tree as Tree
+import Prelude hiding (concat, print)
+
+data Tree s a v = Tree
+ { tParent :: {-# UNPACK #-} !(MutVar s (Tree s a v))
+ , tLeft :: {-# UNPACK #-} !(MutVar s (Tree s a v))
+ , tRight :: {-# UNPACK #-} !(MutVar s (Tree s a v))
+ , tAggs :: {-# UNPACK #-} !(MutVar s (Aggs v))
+ , tLabel :: !a
+ , tValue :: !v
+ }
+
+instance Eq (Tree s a v) where
+ -- Reference equality through a MutVar.
+ t1 == t2 = tParent t1 == tParent t2
+
+data Aggs v = Aggs
+ { aHeight :: {-# UNPACK #-} !Int
+ , aAggregate :: !v
+ } deriving (Eq, Show)
+
+emptyAggs :: Monoid v => Aggs v
+emptyAggs = Aggs 0 mempty
+
+singletonAggs :: v -> Aggs v
+singletonAggs = Aggs 1
+
+joinAggs :: Monoid v => Aggs v -> v -> Aggs v -> Aggs v
+joinAggs (Aggs lh la) a (Aggs rh ra) =
+ Aggs (max lh rh + 1) (la <> a <> ra)
+
+singleton :: PrimMonad m => a -> v -> m (Tree (PrimState m) a v)
+singleton tLabel tValue = do
+ tParent <- MutVar.newMutVar undefined
+ tLeft <- MutVar.newMutVar undefined
+ tRight <- MutVar.newMutVar undefined
+ tAggs <- MutVar.newMutVar $ singletonAggs tValue
+ let tree = Tree {..}
+ MutVar.writeMutVar tParent tree
+ MutVar.writeMutVar tLeft tree
+ MutVar.writeMutVar tRight tree
+ return tree
+
+root :: PrimMonad m => Tree (PrimState m) a v -> m (Tree (PrimState m) a v)
+root tree@Tree {..} = do
+ parent <- MutVar.readMutVar tParent
+ if parent == tree then return tree else root parent
+
+concat
+ :: (PrimMonad m, Monoid v)
+ => NonEmpty (Tree (PrimState m) a v)
+ -> m (Tree (PrimState m) a v)
+concat (x0 NonEmpty.:| xs0) =
+ foldM append x0 xs0
+
+split
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v))
+split x0 = do
+ (mbL, mbR, p, left) <- cut x0
+ if p == x0 then
+ return (mbL, mbR)
+ else do
+ upwards mbL mbR p left
+ where
+ upwards lacc0 racc0 x left0 = do
+ (mbL, mbR, p, left1) <- cut x
+ if left0 then do
+ racc1 <- join racc0 x mbR
+ if p == x then
+ return (lacc0, Just racc1)
+ else
+ upwards lacc0 (Just racc1) p left1
+ else do
+ lacc1 <- join mbL x lacc0
+ if p == x then
+ return (Just lacc1, racc0)
+ else
+ upwards (Just lacc1) racc0 p left1
+
+ cut x = do
+ p <- MutVar.readMutVar (tParent x)
+ pl <- MutVar.readMutVar (tLeft p)
+ l <- MutVar.readMutVar (tLeft x)
+ r <- MutVar.readMutVar (tRight x)
+ when (l /= x) $ removeParent l
+ when (r /= x) $ removeParent r
+ removeParent x
+ removeLeft x
+ removeRight x
+ updateAggs x
+ if pl == x then removeLeft p else removeRight p
+ return
+ ( if l == x then Nothing else Just l
+ , if r == x then Nothing else Just r
+ , p
+ , pl == x
+ )
+
+append
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+append l0 r0 = do
+ -- NOTE: there is a faster way to do this by just following the right spine
+ -- and joining along the way.
+ rm <- getRightMost l0
+ (mbL, mbR) <- split rm
+ case mbR of
+ Just _ -> error "append: invalid state"
+ _ -> assertSingleton rm
+ join mbL rm (Just r0)
+ where
+ getRightMost x = do
+ r <- MutVar.readMutVar (tRight x)
+ if r == x then return x else getRightMost r
+
+connected
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m Bool
+connected x y = do
+ xr <- root x
+ yr <- root y
+ return $ xr == yr
+
+label :: (PrimMonad m, Monoid v) => Tree (PrimState m) a v -> m a
+label = return . tLabel
+
+aggregate :: (PrimMonad m, Monoid v) => Tree (PrimState m) a v -> m v
+aggregate = fmap aAggregate . MutVar.readMutVar . tAggs
+
+-- | For debugging/testing.
+toList
+ :: PrimMonad m => Tree (PrimState m) a v -> m [a]
+toList = go []
+ where
+ go acc0 tree@Tree {..} = do
+ left <- MutVar.readMutVar tLeft
+ right <- MutVar.readMutVar tRight
+ acc1 <- if right == tree then return acc0 else go acc0 right
+ let acc2 = tLabel : acc1
+ if left == tree then return acc2 else go acc2 left
+
+join
+ :: (PrimMonad m, Monoid v)
+ => Maybe (Tree (PrimState m) a v)
+ -> Tree (PrimState m) a v -- Must be a singleton
+ -> Maybe (Tree (PrimState m) a v)
+ -> m (Tree (PrimState m) a v)
+join mbL c mbR = do
+ lh <- maybe (return 0) (fmap aHeight . MutVar.readMutVar . tAggs) mbL
+ rh <- maybe (return 0) (fmap aHeight . MutVar.readMutVar . tAggs) mbR
+ if | lh > rh + 1, Just l <- mbL ->
+ joinRight l c mbR
+ | rh > lh + 1, Just r <- mbR ->
+ joinLeft mbL c r
+ | otherwise -> do
+ case mbL of Just l -> setLeft c l; _ -> return ()
+ case mbR of Just r -> setRight c r; _ -> return ()
+ updateAggs c
+ return c
+
+joinLeft
+ :: (PrimMonad m, Monoid v)
+ => Maybe (Tree (PrimState m) a v)
+ -> Tree (PrimState m) a v -- Must be a singleton
+ -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+joinLeft mbL c r = do
+ rl <- MutVar.readMutVar (tLeft r)
+ rla <- leftAggs r rl
+
+ rr <- MutVar.readMutVar (tRight r)
+ rra <- rightAggs r rr
+
+ la <- maybe (return emptyAggs) (MutVar.readMutVar . tAggs) mbL
+
+ if aHeight rla <= aHeight la + 1 then do
+ setLeft r c
+ when (rl /= r) $ setRight c rl
+ case mbL of Just l -> setLeft c l; _ -> return ()
+
+ let !ca = joinAggs rla (tValue c) la
+
+ -- Invalidity in the parent is fixed with two rotations
+ if aHeight rra + 1 < aHeight ca then do
+ rotateLeft c rl
+ rotateRight r rl
+
+ updateAggs c
+ updateAggs r
+ updateAggsToRoot rl
+ else do
+ -- One rotation
+ updateAggs c
+ updateAggs r
+ upLeft r
+ else
+ joinLeft mbL c rl
+
+upLeft
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+upLeft l = do
+ p <- MutVar.readMutVar (tParent l)
+ if p == l then
+ return l
+ else do
+ r <- MutVar.readMutVar (tRight p)
+ ra <- rightAggs p r
+ la <- leftAggs p l
+ if aHeight ra + 1 < aHeight la then do
+ rotateRight p l
+ updateAggs p
+ updateAggsToRoot l
+ else do
+ updateAggs p -- Stuff below us might have changed.
+ upLeft p
+
+joinRight
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v -- Must be a singleton
+ -> Maybe (Tree (PrimState m) a v)
+ -> m (Tree (PrimState m) a v)
+joinRight l c mbR = do
+ lr <- MutVar.readMutVar (tRight l)
+ lra <- rightAggs l lr
+
+ ll <- MutVar.readMutVar (tLeft l)
+ lla <- leftAggs l ll
+
+ ra <- maybe (return emptyAggs) (MutVar.readMutVar . tAggs) mbR
+
+ if aHeight lra <= aHeight ra + 1 then do
+ setRight l c
+ when (lr /= l) $ setLeft c lr
+ case mbR of Just r -> setRight c r; _ -> return ()
+
+ let !ca = joinAggs lra (tValue c) ra
+
+ -- Invalidity in the parent is fixed with two rotations
+ if aHeight lla + 1 < aHeight ca then do
+ rotateRight c lr
+ rotateLeft l lr
+
+ -- Many of these are already computed...
+ updateAggs l
+ updateAggs c
+ updateAggsToRoot lr
+ else do
+ -- One rotation
+ updateAggs c
+ updateAggs l
+ upRight l
+ else
+ joinRight lr c mbR
+
+upRight
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+upRight r = do
+ p <- MutVar.readMutVar (tParent r)
+ if p == r then
+ return p
+ else do
+ l <- MutVar.readMutVar (tLeft p)
+ la <- leftAggs p l
+ ra <- rightAggs p r
+ if aHeight la + 1 < aHeight ra then do
+ rotateLeft p r
+ updateAggs p
+ updateAggsToRoot r
+ else do
+ updateAggs p -- Stuff below us might have changed.
+ upRight p
+
+rotateLeft, rotateRight
+ :: PrimMonad m
+ => Tree (PrimState m) a v -- X's parent
+ -> Tree (PrimState m) a v -- X
+ -> m ()
+rotateLeft p x = do
+ b <- MutVar.readMutVar (tLeft x)
+ if b == x then removeRight p else setRight p b
+ gp <- MutVar.readMutVar (tParent p)
+ if gp == p then removeParent x else replace gp p x
+ setLeft x p
+rotateRight p x = do
+ b <- MutVar.readMutVar (tRight x)
+ if b == x then removeLeft p else setLeft p b
+ gp <- MutVar.readMutVar (tParent p)
+ if gp == p then removeParent x else replace gp p x
+ setRight x p
+
+setLeft, setRight
+ :: PrimMonad m
+ => Tree (PrimState m) a v -- Parent
+ -> Tree (PrimState m) a v -- New child
+ -> m ()
+setLeft p x = do
+ MutVar.writeMutVar (tParent x) p
+ MutVar.writeMutVar (tLeft p) x
+setRight p x = do
+ MutVar.writeMutVar (tParent x) p
+ MutVar.writeMutVar (tRight p) x
+
+removeParent, removeLeft, removeRight
+ :: PrimMonad m
+ => Tree (PrimState m) a v -- Parent
+ -> m ()
+removeParent x = MutVar.writeMutVar (tParent x) x
+removeLeft x = MutVar.writeMutVar (tLeft x) x
+removeRight x = MutVar.writeMutVar (tRight x) x
+
+leftAggs, rightAggs
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v -- Parent
+ -> Tree (PrimState m) a v -- Left or right child
+ -> m (Aggs v)
+leftAggs p l =
+ if p == l then return emptyAggs else MutVar.readMutVar (tAggs l)
+rightAggs p r =
+ if p == r then return emptyAggs else MutVar.readMutVar (tAggs r)
+
+-- | Replace X by Y in the tree. X must have a parent.
+replace
+ :: PrimMonad m
+ => Tree (PrimState m) a v -- ^ X's parent
+ -> Tree (PrimState m) a v -- ^ X
+ -> Tree (PrimState m) a v -- ^ Y
+ -> m ()
+replace p x y = do
+ pl <- MutVar.readMutVar (tLeft p)
+ MutVar.writeMutVar (tParent y) p
+ if pl == x
+ then MutVar.writeMutVar (tLeft p) y
+ else MutVar.writeMutVar (tRight p) y
+
+-- | Recompute the aggregate and height of a node.
+updateAggs
+ :: (Monoid v, PrimMonad m)
+ => Tree (PrimState m) a v
+ -> m ()
+updateAggs t = do
+ l <- MutVar.readMutVar (tLeft t)
+ r <- MutVar.readMutVar (tRight t)
+ la <- leftAggs t l
+ ra <- rightAggs t r
+ let !agg = joinAggs la (tValue t) ra
+ MutVar.writeMutVar (tAggs t) agg
+
+-- | Recompute aggregate and height all the way to the root of the tree.
+updateAggsToRoot
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+updateAggsToRoot x = do
+ updateAggs x
+ p <- MutVar.readMutVar (tParent x)
+ if p == x then return x else updateAggsToRoot p
+
+-- | For debugging/testing.
+freeze :: PrimMonad m => Tree (PrimState m) a v -> m (Tree.Tree a)
+freeze tree@Tree {..} = do
+ left <- MutVar.readMutVar tLeft
+ right <- MutVar.readMutVar tRight
+ children <- sequence $
+ [freeze left | left /= tree] ++
+ [freeze right | right /= tree]
+ return $ Tree.Node tLabel children
+
+print :: Show a => Tree (PrimState IO) a v -> IO ()
+print = go 0
+ where
+ go d t@Tree {..} = do
+ left <- MutVar.readMutVar tLeft
+ when (left /= t) $ go (d + 1) left
+
+ putStrLn $ replicate d ' ' ++ show tLabel
+
+ right <- MutVar.readMutVar tRight
+ when (right /= t) $ go (d + 1) right
+
+assertInvariants
+ :: (PrimMonad m, Monoid v, Eq v, Show v) => Tree (PrimState m) a v -> m ()
+assertInvariants t = do
+ _ <- computeAggs t t
+ return ()
+ where
+ -- TODO: Check average
+ computeAggs p x = do
+ p' <- MutVar.readMutVar (tParent x)
+ when (p /= p') $ fail "broken parent pointer"
+
+ l <- MutVar.readMutVar (tLeft x)
+ r <- MutVar.readMutVar (tRight x)
+ la <- if l == x then return emptyAggs else computeAggs x l
+ ra <- if r == x then return emptyAggs else computeAggs x r
+
+ let actualAggs = joinAggs la (tValue x) ra
+ storedAggs <- MutVar.readMutVar (tAggs x)
+
+ when (actualAggs /= storedAggs) $ fail $
+ "error in stored aggregates: " ++ show storedAggs ++
+ ", actual: " ++ show actualAggs
+
+ when (abs (aHeight la - aHeight ra) > 1) $ fail "inbalanced"
+ return actualAggs
+
+assertSingleton :: PrimMonad m => Tree (PrimState m) a v -> m ()
+assertSingleton x = do
+ l <- MutVar.readMutVar (tLeft x)
+ r <- MutVar.readMutVar (tRight x)
+ p <- MutVar.readMutVar (tParent x)
+ when (l /= x || r /= x || p /= x) $ fail "not a singleton"
+
+assertRoot :: PrimMonad m => Tree (PrimState m) a v -> m ()
+assertRoot x = do
+ p <- MutVar.readMutVar (tParent x)
+ when (p /= x) $ fail "not the root"
+
+data TreeGen s = TreeGen
+
+instance Class.Tree Tree where
+ type TreeGen Tree = TreeGen
+ newTreeGen _ = return TreeGen
+
+ singleton _ = singleton
+ append = append
+ split = split
+ connected = connected
+ root = root
+ label = label
+ aggregate = aggregate
+ toList = toList
+
+instance Class.TestTree Tree where
+ print = print
+ assertInvariants = assertInvariants
+ assertSingleton = assertSingleton
+ assertRoot = assertRoot
diff --git a/src/Data/Graph/Dynamic/Internal/HashTable.hs b/src/Data/Graph/Dynamic/Internal/HashTable.hs
new file mode 100644
index 0000000..e439c17
--- /dev/null
+++ b/src/Data/Graph/Dynamic/Internal/HashTable.hs
@@ -0,0 +1,49 @@
+-- | This is a very simple wrapper around the 'hashtables' library that uses
+-- 'PrimMonad' rather than 'ST'.
+module Data.Graph.Dynamic.Internal.HashTable
+ ( HashTable
+ , new
+ , insert
+ , delete
+ , lookup
+
+ -- Slow and debugging only
+ , toList
+ ) where
+
+import Control.Monad.Primitive (PrimMonad (..), stToPrim)
+import Data.Hashable (Hashable)
+import qualified Data.HashTable.ST.Cuckoo as Cuckoo
+import Prelude hiding (lookup)
+
+type HashTable s k v = Cuckoo.HashTable s k v
+
+new :: PrimMonad m => m (HashTable (PrimState m) k v)
+new = stToPrim Cuckoo.new
+{-# INLINE new #-}
+
+insert
+ :: (Eq k, Hashable k, PrimMonad m)
+ => HashTable (PrimState m) k v -> k -> v -> m ()
+insert ht k v = stToPrim (Cuckoo.insert ht k v)
+{-# INLINE insert #-}
+
+delete
+ :: (Eq k, Hashable k, PrimMonad m)
+ => HashTable (PrimState m) k v -> k -> m ()
+delete ht k = stToPrim (Cuckoo.delete ht k)
+{-# INLINE delete #-}
+
+lookup
+ :: (Eq k, Hashable k, PrimMonad m)
+ => HashTable (PrimState m) k v -> k -> m (Maybe v)
+lookup ht k = stToPrim (Cuckoo.lookup ht k)
+{-# INLINE lookup #-}
+
+--------------------------------------------------------------------------------
+
+-- | Slow, only for debugging and testing.
+toList
+ :: PrimMonad m
+ => HashTable (PrimState m) k v -> m [(k, v)]
+toList ht = stToPrim $ Cuckoo.foldM (\acc kv -> return (kv : acc)) [] ht
diff --git a/src/Data/Graph/Dynamic/Internal/Random.hs b/src/Data/Graph/Dynamic/Internal/Random.hs
new file mode 100644
index 0000000..5b83db8
--- /dev/null
+++ b/src/Data/Graph/Dynamic/Internal/Random.hs
@@ -0,0 +1,269 @@
+-- | Randomly balanced tree.
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Data.Graph.Dynamic.Internal.Random
+ ( Tree
+
+ , singleton
+ , append
+ , split
+ , connected
+ , root
+ , label
+ , aggregate
+ , toList
+
+ -- * Debugging only
+ , freeze
+ , print
+ , assertInvariants
+ , assertSingleton
+ , assertRoot
+ ) where
+
+import Control.Monad (when)
+import Control.Monad.Primitive (PrimMonad (..))
+import qualified Data.Graph.Dynamic.Internal.Tree as Class
+import Data.Monoid ((<>))
+import Data.Primitive.MutVar (MutVar)
+import qualified Data.Primitive.MutVar as MutVar
+import qualified Data.Tree as Tree
+import Prelude hiding (concat, print)
+import System.IO.Unsafe (unsafePerformIO)
+import qualified System.Random.MWC as MWC
+import Unsafe.Coerce (unsafeCoerce)
+
+data T s a v = T
+ { tParent :: {-# UNPACK #-} !(Tree s a v)
+ , tLeft :: {-# UNPACK #-} !(Tree s a v)
+ , tRight :: {-# UNPACK #-} !(Tree s a v)
+ , tRandom :: !Int
+ , tLabel :: !a
+ , tValue :: !v
+ , tAgg :: !v
+ }
+
+-- | NOTE (jaspervdj): There are two ways of indicating the parent / left /
+-- right is not set (we want to avoid Maybe's since they cause a lot of
+-- indirections).
+--
+-- Imagine that we are considering tLeft.
+--
+-- 1. We can set tLeft of x to the MutVar that holds the tree itself (i.e. a
+-- self-loop).
+-- 2. We can set tLeft to some nil value.
+--
+-- They seem to offer similar performance. We choose to use the latter since it
+-- is less likely to end up in infinite loops that way, and additionally, we can
+-- move easily move e.g. x's left child to y's right child, even it is an empty
+-- child.
+nil :: Tree s a v
+nil = unsafeCoerce $ unsafePerformIO $ Tree <$> MutVar.newMutVar undefined
+{-# NOINLINE nil #-}
+
+newtype Tree s a v = Tree (MutVar s (T s a v)) deriving (Eq)
+
+singleton
+ :: PrimMonad m
+ => MWC.Gen (PrimState m) -> a -> v -> m (Tree (PrimState m) a v)
+singleton gen tLabel tValue = do
+ random <- MWC.uniform gen
+ Tree <$> MutVar.newMutVar (T nil nil nil random tLabel tValue tValue)
+
+root :: PrimMonad m => Tree (PrimState m) a v -> m (Tree (PrimState m) a v)
+root (Tree tv) = do
+ T {..} <- MutVar.readMutVar tv
+ if tParent == nil then return (Tree tv) else root tParent
+
+-- | Appends two trees. Returns the root of the tree.
+append
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+append = merge
+
+merge
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+merge xt@(Tree xv) yt@(Tree yv)
+ | xt == nil = return yt
+ | yt == nil = return xt
+ | otherwise = do
+ x <- MutVar.readMutVar xv
+ y <- MutVar.readMutVar yv
+ if tRandom x < tRandom y then do
+ rt@(Tree rv) <- merge xt (tLeft y)
+ MutVar.writeMutVar yv $! y {tLeft = rt, tAgg = tAgg x <> tAgg y}
+ MutVar.modifyMutVar rv $ \r -> r {tParent = yt}
+ return yt
+ else do
+ rt@(Tree rv) <- merge (tRight x) yt
+ MutVar.writeMutVar xv $! x {tRight = rt, tAgg = tAgg x <> tAgg y}
+ MutVar.modifyMutVar rv $ \r -> r {tParent = xt}
+ return xt
+
+split
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v))
+split xt@(Tree xv) = do
+ x <- MutVar.readMutVar xv
+ let pv = tParent x
+ lt = tLeft x
+ rt = tRight x
+
+ when (lt /= nil) (removeParent lt)
+ when (rt /= nil) (removeParent rt)
+ MutVar.writeMutVar xv $!
+ x {tParent = nil, tLeft = nil, tRight = nil, tAgg = tValue x}
+
+ mergeUp pv xt lt rt
+
+mergeUp
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v -- Current node
+ -> Tree (PrimState m) a v -- Eliminated node
+ -> Tree (PrimState m) a v -- Left tree accumulator
+ -> Tree (PrimState m) a v -- Right tree accumulator
+ -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v))
+mergeUp xt _ lacc racc | xt == nil =
+ return
+ ( if lacc == nil then Nothing else Just lacc
+ , if racc == nil then Nothing else Just racc
+ )
+mergeUp xt@(Tree xv) ct lacc racc = do
+ x <- MutVar.readMutVar xv
+ let pt = tParent x
+ lt = tLeft x
+ rt = tRight x
+ if ct == lt then do
+ ra <- if rt == nil then return mempty else aggregate rt
+ MutVar.writeMutVar xv $! x {tParent = nil, tLeft = nil, tAgg = tValue x <> ra}
+ racc' <- merge racc xt
+ mergeUp pt xt lacc racc'
+ else do
+ la <- if lt == nil then return mempty else aggregate lt
+ MutVar.writeMutVar xv $! x {tParent = nil, tRight = nil, tAgg = la <> tValue x}
+ lacc' <- merge xt lacc
+ mergeUp pt xt lacc' racc
+
+connected
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m Bool
+connected xv yv = do
+ xr <- root xv
+ yr <- root yv
+ return $ xr == yr
+
+label
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m a
+label (Tree xv) = tLabel <$> MutVar.readMutVar xv
+
+aggregate
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m v
+aggregate (Tree xv) = tAgg <$> MutVar.readMutVar xv
+
+-- | For debugging/testing.
+toList
+ :: PrimMonad m => Tree (PrimState m) a v -> m [a]
+toList = go []
+ where
+ go acc0 (Tree mv) = do
+ T {..} <- MutVar.readMutVar mv
+ acc1 <- if tRight == nil then return acc0 else go acc0 tRight
+ let acc2 = tLabel : acc1
+ if tLeft == nil then return acc2 else go acc2 tLeft
+
+removeParent, _removeLeft, _removeRight
+ :: PrimMonad m
+ => Tree (PrimState m) a v -- Parent
+ -> m ()
+removeParent (Tree xv) = MutVar.modifyMutVar' xv $ \x -> x {tParent = nil}
+_removeLeft (Tree xv) = MutVar.modifyMutVar' xv $ \x -> x {tLeft = nil}
+_removeRight (Tree xv) = MutVar.modifyMutVar' xv $ \x -> x {tRight = nil}
+
+-- | For debugging/testing.
+freeze :: PrimMonad m => Tree (PrimState m) a v -> m (Tree.Tree a)
+freeze (Tree mv) = do
+ T {..} <- MutVar.readMutVar mv
+ children <- sequence $
+ [freeze tLeft | tLeft /= nil] ++
+ [freeze tRight | tRight /= nil]
+ return $ Tree.Node tLabel children
+
+print :: Show a => Tree (PrimState IO) a v -> IO ()
+print = go 0
+ where
+ go d (Tree mv) = do
+ T {..} <- MutVar.readMutVar mv
+ when (tLeft /= nil) $ go (d + 1) tLeft
+ putStrLn $ replicate d ' ' ++ show tLabel
+ when (tRight /= nil) $ go (d + 1) tRight
+
+assertInvariants
+ :: (PrimMonad m, Monoid v, Eq v, Show v) => Tree (PrimState m) a v -> m ()
+assertInvariants t = do
+ _ <- computeAgg nil t
+ return ()
+ where
+ -- TODO: Check average
+ computeAgg pt xt@(Tree xv) = do
+ x <- MutVar.readMutVar xv
+ let pt' = tParent x
+ when (pt /= pt') $ fail "broken parent pointer"
+
+ let lt = tLeft x
+ let rt = tRight x
+ la <- if lt == nil then return mempty else computeAgg xt lt
+ ra <- if rt == nil then return mempty else computeAgg xt rt
+
+ let actualAgg = la <> (tValue x) <> ra
+ let storedAgg = tAgg x
+
+ when (actualAgg /= storedAgg) $ fail $
+ "error in stored aggregates: " ++ show storedAgg ++
+ ", actual: " ++ show actualAgg
+
+ return actualAgg
+
+assertSingleton :: PrimMonad m => Tree (PrimState m) a v -> m ()
+assertSingleton (Tree xv) = do
+ T {..} <- MutVar.readMutVar xv
+ when (tLeft /= nil || tRight /= nil || tParent /= nil) $
+ fail "not a singleton"
+
+assertRoot :: PrimMonad m => Tree (PrimState m) a v -> m ()
+assertRoot (Tree xv) = do
+ T {..} <- MutVar.readMutVar xv
+ when (tParent /= nil) $ fail "not the root"
+
+instance Class.Tree Tree where
+ type TreeGen Tree = MWC.Gen
+ newTreeGen _ = MWC.create
+
+ singleton = singleton
+ append = append
+ split = split
+ connected = connected
+ root = root
+ label = label
+ aggregate = aggregate
+ toList = toList
+
+instance Class.TestTree Tree where
+ print = print
+ assertInvariants = assertInvariants
+ assertSingleton = assertSingleton
+ assertRoot = assertRoot
diff --git a/src/Data/Graph/Dynamic/Internal/Splay.hs b/src/Data/Graph/Dynamic/Internal/Splay.hs
new file mode 100644
index 0000000..a6b712d
--- /dev/null
+++ b/src/Data/Graph/Dynamic/Internal/Splay.hs
@@ -0,0 +1,511 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Data.Graph.Dynamic.Internal.Splay
+ ( Tree
+
+ , singleton
+ , cons
+ , snoc
+ , append
+ , split
+ , connected
+ , root
+ , aggregate
+ , toList
+
+ -- * Debugging only
+ , readRoot
+ , freeze
+ , print
+ , assertInvariants
+ ) where
+
+import Control.Monad (when)
+import Control.Monad.Primitive (PrimMonad (..))
+import qualified Data.Graph.Dynamic.Internal.Tree as Class
+import Data.Monoid ((<>))
+import Data.Primitive.MutVar (MutVar)
+import qualified Data.Primitive.MutVar as MutVar
+import qualified Data.Tree as Tree
+import Prelude hiding (concat, print)
+import System.IO.Unsafe (unsafePerformIO)
+import Unsafe.Coerce (unsafeCoerce)
+
+data T s a v = T
+ { tParent :: {-# UNPACK #-} !(Tree s a v)
+ , tLeft :: {-# UNPACK #-} !(Tree s a v)
+ , tRight :: {-# UNPACK #-} !(Tree s a v)
+ , tLabel :: !a
+ , tValue :: !v
+ , tAgg :: !v
+ }
+
+-- | NOTE (jaspervdj): There are two ways of indicating the parent / left /
+-- right is not set (we want to avoid Maybe's since they cause a lot of
+-- indirections).
+--
+-- Imagine that we are considering tLeft.
+--
+-- 1. We can set tLeft of x to the MutVar that holds the tree itself (i.e. a
+-- self-loop).
+-- 2. We can set tLeft to some nil value.
+--
+-- They seem to offer similar performance. We choose to use the latter since it
+-- is less likely to end up in infinite loops that way, and additionally, we can
+-- move easily move e.g. x's left child to y's right child, even it is an empty
+-- child.
+nil :: Tree s a v
+nil = unsafeCoerce $ unsafePerformIO $ fmap Tree $ MutVar.newMutVar undefined
+{-# NOINLINE nil #-}
+
+newtype Tree s a v = Tree {unTree :: MutVar s (T s a v)}
+ deriving (Eq)
+
+singleton :: PrimMonad m => a -> v -> m (Tree (PrimState m) a v)
+singleton tLabel tValue =
+ fmap Tree $ MutVar.newMutVar $! T nil nil nil tLabel tValue tValue
+
+readRoot :: PrimMonad m => Tree (PrimState m) a v -> m (Tree (PrimState m) a v)
+readRoot tree = do
+ T {..} <- MutVar.readMutVar (unTree tree)
+ if tParent == nil then return tree else readRoot tParent
+
+-- | `lv` must be a singleton tree
+cons
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+cons lt@(Tree lv) rt@(Tree rv) = do
+ r <- MutVar.readMutVar rv
+ MutVar.modifyMutVar' lv $ \l -> l {tRight = rt, tAgg = tAgg l <> tAgg r}
+ MutVar.writeMutVar rv $! r {tParent = lt}
+ return lt
+
+-- | `rv` must be a singleton tree
+snoc
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+snoc lt@(Tree lv) rt@(Tree rv) = do
+ l <- MutVar.readMutVar lv
+ MutVar.modifyMutVar' rv $ \r -> r {tLeft = lt, tAgg = tAgg l <> tAgg r}
+ MutVar.writeMutVar lv $! l {tParent = rt}
+ return rt
+
+-- | Appends two trees. Returns the root of the tree.
+append
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+append xt@(Tree _xv) yt@(Tree yv) = do
+ rmt@(Tree rmv) <- getRightMost xt
+ _ <- splay rmt
+ y <- MutVar.readMutVar yv
+ MutVar.modifyMutVar rmv $ \r -> r {tRight = yt, tAgg = tAgg r <> tAgg y}
+ MutVar.writeMutVar yv $! y {tParent = rmt}
+ return rmt
+ where
+ getRightMost tt@(Tree tv) = do
+ t <- MutVar.readMutVar tv
+ if tRight t == nil then return tt else getRightMost (tRight t)
+
+split
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Maybe (Tree (PrimState m) a v), Maybe (Tree (PrimState m) a v))
+split xt@(Tree xv) = do
+ _ <- splay xt
+ T {..} <- MutVar.readMutVar xv
+ when (tLeft /= nil) (removeParent tLeft) -- Works even if l is x
+ when (tRight /= nil) (removeParent tRight)
+ MutVar.writeMutVar xv $ T {tAgg = tValue, ..}
+ removeLeft xt
+ removeRight xt
+ return
+ ( if tLeft == nil then Nothing else Just tLeft
+ , if tRight == nil then Nothing else Just tRight
+ )
+
+connected
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> Tree (PrimState m) a v
+ -> m Bool
+connected x y = do
+ _ <- splay x
+ x' <- splay y
+ return $ x == x'
+
+root
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+root x = do
+ _ <- splay x
+ return x
+
+label
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m a
+label (Tree xv) = tLabel <$> MutVar.readMutVar xv
+
+aggregate
+ :: (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m v
+aggregate (Tree xv) = tAgg <$> MutVar.readMutVar xv
+
+-- | For debugging/testing.
+toList
+ :: PrimMonad m => Tree (PrimState m) a v -> m [a]
+toList = go []
+ where
+ go acc0 (Tree tv) = do
+ T {..} <- MutVar.readMutVar tv
+ acc1 <- if tRight == nil then return acc0 else go acc0 tRight
+ let acc2 = tLabel : acc1
+ if tLeft == nil then return acc2 else go acc2 tLeft
+
+splay
+ :: forall m a v. (PrimMonad m, Monoid v)
+ => Tree (PrimState m) a v
+ -> m (Tree (PrimState m) a v) -- Returns the old root.
+splay xt@(Tree xv) = do
+ -- Note (jaspervdj): Rather than repeatedly reading from/writing to xv we
+ -- read x once and thread its (continuously updated) value through the
+ -- entire stack of `go` calls.
+ --
+ -- The same is true for the left and right aggregates of x: they can be
+ -- passed upwards rather than recomputed.
+ x0 <- MutVar.readMutVar xv
+ xla <- if tLeft x0 == nil then return mempty else tAgg <$> MutVar.readMutVar (unTree $ tLeft x0)
+ xra <- if tRight x0 == nil then return mempty else tAgg <$> MutVar.readMutVar (unTree $ tRight x0)
+ go xt xla xra x0
+ where
+ go :: Tree (PrimState m) a v -> v -> v -> T (PrimState m) a v
+ -> m (Tree (PrimState m) a v)
+ go closestToRootFound xla xra !x = do
+ let !(pt@(Tree pv)) = tParent x
+ if pt == nil then do
+ MutVar.writeMutVar xv x
+ return closestToRootFound
+ else do
+ p <- MutVar.readMutVar pv
+ let gt@(Tree gv) = tParent p
+ let plt@(Tree plv) = tLeft p
+ let prt@(Tree prv) = tRight p
+ let xlt@(Tree xlv) = tLeft x
+ let xrt@(Tree xrv) = tRight x
+ if | gt == nil, plt == xt -> do
+ -- ZIG (Right)
+ --
+ -- p => x
+ -- / \
+ -- x p
+ -- \ /
+ -- xr xr
+ --
+ when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr ->
+ xr {tParent = pt}
+
+ pra <- if prt == nil then return mempty else tAgg <$> MutVar.readMutVar prv
+ MutVar.writeMutVar pv $! p
+ { tLeft = xrt
+ , tParent = xt
+ , tAgg = xra <> tValue p <> pra
+ }
+
+ MutVar.writeMutVar xv $! x
+ { tAgg = tAgg p
+ , tRight = pt
+ , tParent = nil
+ }
+
+ return pt
+
+ | gt == nil -> do
+ -- ZIG (Left)
+ --
+ -- p => x
+ -- \ /
+ -- x p
+ -- / \
+ -- xl xl
+ --
+ when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl ->
+ xl {tParent = pt}
+
+ pla <- if plt == nil then return mempty else tAgg <$> MutVar.readMutVar plv
+ MutVar.writeMutVar pv $! p
+ { tRight = xlt
+ , tParent = xt
+ , tAgg = pla <> tValue p <> xla
+ }
+
+ MutVar.writeMutVar xv $! x
+ { tAgg = tAgg p
+ , tLeft = pt
+ , tParent = nil
+ }
+
+ return pt
+
+ | otherwise -> do
+
+ g <- MutVar.readMutVar gv
+ let ggt@(Tree ggv) = tParent g
+ let glt@(Tree glv) = tLeft g
+ let grt@(Tree grv) = tRight g
+ when (ggt /= nil) $ MutVar.modifyMutVar' ggv $ \gg ->
+ if tLeft gg == gt
+ then gg {tLeft = xt}
+ else gg {tRight = xt}
+
+ if | plt == xt && glt == pt -> do
+ -- ZIGZIG (Right):
+ --
+ -- gg gg
+ -- | |
+ -- g x
+ -- / \ / \
+ -- p => p
+ -- / \ / \
+ -- x pr xr g
+ -- / \ /
+ -- xr pr
+ --
+
+ pra <- if prt == nil then return mempty else tAgg <$> MutVar.readMutVar prv
+ gra <- if grt == nil then return mempty else tAgg <$> MutVar.readMutVar grv
+ let !ga' = pra <> tValue g <> gra
+ when (prt /= nil) $ MutVar.modifyMutVar' prv $ \pr ->
+ pr {tParent = gt}
+
+ MutVar.writeMutVar gv $! g
+ { tParent = pt
+ , tLeft = prt
+ , tAgg = ga'
+ }
+
+ when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr ->
+ xr {tParent = pt}
+
+ let !pa' = xra <> tValue p <> ga'
+ MutVar.writeMutVar pv $! p
+ { tParent = xt
+ , tLeft = xrt
+ , tRight = gt
+ , tAgg = pa'
+ }
+
+ go gt xla pa' $! x
+ { tRight = pt
+ , tAgg = tAgg g
+ , tParent = ggt
+ }
+
+ | plv /= xv && glv /= pv -> do
+ -- ZIGZIG (Left):
+ --
+ -- gg gg
+ -- | |
+ -- g x
+ -- / \ / \
+ -- p => p
+ -- / \ / \
+ -- pl x g xl
+ -- / \ / \
+ -- xl pl
+ --
+ pla <- if plt == nil then return mempty else tAgg <$> MutVar.readMutVar plv
+ gla <- if glt == nil then return mempty else tAgg <$> MutVar.readMutVar glv
+ let !ga' = gla <> tValue g <> pla
+ when (plt /= nil) $ MutVar.modifyMutVar' plv $ \pl ->
+ pl {tParent = gt}
+
+ MutVar.writeMutVar gv $! g
+ { tParent = pt
+ , tRight = plt
+ , tAgg = ga'
+ }
+
+ when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl ->
+ xl {tParent = pt}
+
+ let !pa' = ga' <> tValue p <> xla
+ MutVar.writeMutVar pv $! p
+ { tParent = xt
+ , tLeft = gt
+ , tRight = xlt
+ , tAgg = pa'
+ }
+
+ go gt pa' xra $! x
+ { tLeft = pt
+ , tAgg = tAgg g
+ , tParent = ggt
+ }
+
+ | plv == xv -> do
+ -- ZIGZIG (Left):
+ --
+ -- gg gg
+ -- | |
+ -- g x
+ -- \ / \
+ -- p => g p
+ -- / \ /
+ -- x xl xr
+ -- / \
+ -- xl xr
+ --
+ when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl ->
+ xl {tParent = gt}
+
+ gla <- if glt == nil then return mempty else tAgg <$> MutVar.readMutVar glv
+ let !ga' = gla <> tValue g <> xla
+ MutVar.writeMutVar gv $! g
+ { tParent = xt
+ , tRight = xlt
+ , tAgg = ga'
+ }
+
+ when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr ->
+ xr {tParent = pt}
+
+ pra <- if prt == nil then return mempty else tAgg <$> MutVar.readMutVar prv
+ let pa' = xra <> tValue p <> pra
+ MutVar.writeMutVar pv $! p
+ { tParent = xt
+ , tLeft = xrt
+ , tAgg = pa'
+ }
+
+ go gt ga' pa' $! x
+ { tParent = ggt
+ , tLeft = gt
+ , tRight = pt
+ , tAgg = tAgg g
+ }
+
+ | otherwise -> do
+ -- ZIGZIG (Right):
+ --
+ -- gg gg
+ -- | |
+ -- g x
+ -- / / \
+ -- p => p g
+ -- \ \ /
+ -- x xl xr
+ -- / \
+ -- xl xr
+ --
+ when (xrt /= nil) $ MutVar.modifyMutVar' xrv $ \xr ->
+ xr {tParent = gt}
+
+ gra <- if grt == nil then return mempty else tAgg <$> MutVar.readMutVar grv
+ let !ga' = xra <> tValue g <> gra
+ MutVar.writeMutVar gv $! g
+ { tParent = xt
+ , tLeft = xrt
+ , tAgg = ga'
+ }
+
+ when (xlt /= nil) $ MutVar.modifyMutVar' xlv $ \xl ->
+ xl {tParent = pt}
+
+ pla <- if plt == nil then return mempty else tAgg <$> MutVar.readMutVar plv
+ let !pa' = pla <> tValue p <> xla
+ MutVar.writeMutVar pv $! p
+ { tParent = xt
+ , tRight = xlt
+ , tAgg = pa'
+ }
+
+ go gt pa' ga' $! x
+ { tParent = ggt
+ , tLeft = pt
+ , tRight = gt
+ , tAgg = tAgg g
+ }
+
+removeParent, removeLeft, removeRight
+ :: PrimMonad m
+ => Tree (PrimState m) a v -- Parent
+ -> m ()
+removeParent (Tree x) = MutVar.modifyMutVar' x $ \x' -> x' {tParent = nil}
+removeLeft (Tree x) = MutVar.modifyMutVar' x $ \x' -> x' {tLeft = nil}
+removeRight (Tree x) = MutVar.modifyMutVar' x $ \x' -> x' {tRight = nil}
+
+-- | For debugging/testing.
+freeze :: PrimMonad m => Tree (PrimState m) a v -> m (Tree.Tree a)
+freeze (Tree tv) = do
+ T {..} <- MutVar.readMutVar tv
+ children <- sequence $
+ [freeze tLeft | tLeft /= nil] ++
+ [freeze tRight | tRight /= nil]
+ return $ Tree.Node tLabel children
+
+print :: Show a => Tree (PrimState IO) a v -> IO ()
+print = go 0
+ where
+ go d (Tree tv) = do
+ T {..} <- MutVar.readMutVar tv
+ when (tLeft /= nil) $ go (d + 1) tLeft
+ putStrLn $ replicate d ' ' ++ show tLabel
+ when (tRight /= nil) $ go (d + 1) tRight
+
+assertInvariants
+ :: (PrimMonad m, Monoid v, Eq v, Show v) => Tree (PrimState m) a v -> m ()
+assertInvariants t = do
+ _ <- computeAgg nil t
+ return ()
+ where
+ -- TODO: Check average
+ computeAgg pt xt@(Tree xv) = do
+ x' <- MutVar.readMutVar xv
+ let p' = tParent x'
+ when (pt /= p') $ fail "broken parent pointer"
+
+ let l = tLeft x'
+ let r = tRight x'
+ la <- if l == nil then return mempty else computeAgg xt l
+ ra <- if r == nil then return mempty else computeAgg xt r
+
+ let actualAgg = la <> (tValue x') <> ra
+ let storedAgg = tAgg x'
+
+ when (actualAgg /= storedAgg) $ fail $
+ "error in stored aggregates: " ++ show storedAgg ++
+ ", actual: " ++ show actualAgg
+
+ return actualAgg
+
+data TreeGen s = TreeGen
+
+instance Class.Tree Tree where
+ type TreeGen Tree = TreeGen
+ newTreeGen _ = return TreeGen
+
+ singleton _ = singleton
+ append = append
+ split = split
+ connected = connected
+ root = root
+ readRoot = readRoot
+ label = label
+ aggregate = aggregate
+ toList = toList
+
+instance Class.TestTree Tree where
+ print = print
+ assertInvariants = assertInvariants
+ assertSingleton = \_ -> return ()
+ assertRoot = \_ -> return ()
diff --git a/src/Data/Graph/Dynamic/Internal/Tree.hs b/src/Data/Graph/Dynamic/Internal/Tree.hs
new file mode 100644
index 0000000..8682d16
--- /dev/null
+++ b/src/Data/Graph/Dynamic/Internal/Tree.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Data.Graph.Dynamic.Internal.Tree
+ ( Tree (..)
+ , concat
+
+ , TestTree (..)
+ ) where
+
+import Control.Monad (foldM)
+import Control.Monad.Primitive (PrimMonad (..))
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Proxy (Proxy)
+import Prelude hiding (concat)
+
+-- | The chosen represenation of the tree has a big impact on the performance of
+-- the algorithms. This typeclass allows us to swap them out more easily.
+class Tree (t :: * -> * -> * -> *) where
+ -- | A management structure used to create new trees
+ type TreeGen t :: * -> *
+
+ -- | Create a tree gen itself
+ newTreeGen
+ :: PrimMonad m => Proxy t -> m (TreeGen t (PrimState m))
+
+ -- | Create a tree with a single element.
+ singleton
+ :: (PrimMonad m, Monoid v)
+ => TreeGen t (PrimState m) -> a -> v -> m (t (PrimState m) a v)
+
+ -- | Join two trees together.
+ append
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v -> t (PrimState m) a v
+ -> m (t (PrimState m) a v)
+
+ -- | Prepend a singleton tree
+ cons
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v -> t (PrimState m) a v
+ -> m (t (PrimState m) a v)
+ cons = append
+
+ -- | Append a singleton tree
+ snoc
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v -> t (PrimState m) a v
+ -> m (t (PrimState m) a v)
+ snoc = append
+
+ -- | Split a tree, turning the argument into a singleton and returning the
+ -- left and right halves of the tree.
+ split
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v
+ -> m (Maybe (t (PrimState m) a v), Maybe (t (PrimState m) a v))
+
+ -- | Check if two nodes belong to the same tree
+ connected
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v -> t (PrimState m) a v
+ -> m Bool
+
+ -- | Find the root of a tree
+ root
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v
+ -> m (t (PrimState m) a v)
+
+ -- | Read the root of a tree. This is not allowed to modify the tree (e.g.,
+ -- no splaying allowed).
+ readRoot
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v
+ -> m (t (PrimState m) a v)
+ readRoot = root
+
+ -- | Read the label from a tree
+ label
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v
+ -> m a
+
+ -- | Read the aggregate of a tree
+ aggregate
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v
+ -> m v
+
+ -- | Convert a tree to a list
+ toList
+ :: (PrimMonad m, Monoid v)
+ => t (PrimState m) a v
+ -> m [a]
+
+concat
+ :: forall t m a v. (Tree t, PrimMonad m, Monoid v)
+ => NonEmpty (t (PrimState m) a v)
+ -> m (t (PrimState m) a v)
+concat trees0 =
+ case trees0 of x NonEmpty.:| xs -> foldM append x xs
+
+-- | These methods can be used for testing and debugging.
+class Tree t => TestTree t where
+ print
+ :: Show a
+ => t (PrimState IO) a v -> IO ()
+
+ assertInvariants
+ :: (PrimMonad m, Monoid v, Eq v, Show v)
+ => t (PrimState m) a v -> m ()
+
+ assertSingleton
+ :: (PrimMonad m, Monoid v, Eq v, Show v)
+ => t (PrimState m) a v -> m ()
+
+ assertRoot
+ :: (PrimMonad m, Monoid v, Eq v, Show v)
+ => t (PrimState m) a v -> m ()
diff --git a/src/Data/Graph/Dynamic/Levels.hs b/src/Data/Graph/Dynamic/Levels.hs
new file mode 100644
index 0000000..cce4366
--- /dev/null
+++ b/src/Data/Graph/Dynamic/Levels.hs
@@ -0,0 +1,395 @@
+-- | This module implements full dynamic grah connectivity.
+--
+-- It is based on:
+-- /Poly-logarithmic deterministic fully-dynamic algorithms for connectivity, minimum spanning tree, 2-edge, and biconnectivity/
+-- by /Jacob Holm, Kristian de Lichtenberg and Mikkel Thorup/ (1998).
+--
+-- We use two naming conventions in this module:
+--
+-- * A prime suffix (@'@) indicates a simpler or less polymorphic version of a
+-- function or datatype. For example, see 'empty' and 'empty'', and
+-- 'Graph' and 'Graph''.
+--
+-- * An underscore suffix (@_@) means that the return value is ignored. For
+-- example, see 'link' and 'link_'.
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Data.Graph.Dynamic.Levels
+ ( -- * Type
+ Graph
+ , Graph'
+
+ -- * Construction
+ , empty
+ , empty'
+ , edgeless
+ , edgeless'
+ , complete
+ , complete'
+
+ -- * Queries
+ , connected
+ , edge
+ , vertex
+ , neighbours
+
+ -- * Modifying
+ , link
+ , link_
+ , cut
+ , cut_
+ , insert
+ , insert_
+ , delete
+ , delete_
+
+ -- * Advanced/internal
+ , spanningForest
+ ) where
+
+import Control.Monad
+import Control.Monad.Primitive
+import Data.Bits
+import Data.Hashable (Hashable)
+import qualified Data.HashMap.Strict as HMS
+import qualified Data.HashSet as HS
+import qualified Data.List as L
+import Data.Maybe (fromMaybe)
+import Data.Monoid
+import Data.Primitive.MutVar
+import qualified Data.Tree as DT
+import qualified Data.Vector.Mutable as VM
+
+import qualified Data.Graph.Dynamic.EulerTour as ET
+import qualified Data.Graph.Dynamic.Internal.Random as Random
+import Data.Graph.Dynamic.Internal.Tree (Tree)
+import qualified Data.Graph.Dynamic.Internal.Tree as Tree
+
+type EdgeSet v = HMS.HashMap v (HS.HashSet v)
+
+linkEdgeSet :: (Eq v, Hashable v) => v -> v -> EdgeSet v -> EdgeSet v
+linkEdgeSet x y =
+ HMS.insertWith HS.union x (HS.singleton y) .
+ HMS.insertWith HS.union y (HS.singleton x)
+
+cutEdgeSet :: (Eq v, Hashable v) => v -> v -> EdgeSet v -> EdgeSet v
+cutEdgeSet x y = HMS.adjust (HS.delete x) y . HMS.adjust (HS.delete y) x
+
+memberEdgeSet :: (Eq v, Hashable v) => v -> v -> EdgeSet v -> Bool
+memberEdgeSet x y = maybe False (y `HS.member`) . HMS.lookup x
+
+data L t s v = L
+ { numVerts :: !Int
+ , allEdges :: !(EdgeSet v)
+ , unLevels :: !(VM.MVector s (ET.Forest t (Sum Int) s v, EdgeSet v))
+ }
+
+newtype Graph t s v = Graph (MutVar s (L t s v))
+
+type Graph' s v = Graph Random.Tree s v
+
+logBase2 :: Int -> Int
+logBase2 x = finiteBitSize x - 1 - countLeadingZeros x
+
+-- | /O(1)/
+--
+-- Create an empty graph.
+empty :: (Eq v, Hashable v, Tree t, PrimMonad m) => m (Graph t (PrimState m) v)
+empty = edgeless []
+
+-- | Simple version of 'empty'.
+empty' :: (Eq v, Hashable v, PrimMonad m) => m (Graph' (PrimState m) v)
+empty' = empty
+
+-- | Create a graph with the given vertices but no edges.
+edgeless
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => [v] -> m (Graph t (PrimState m) v)
+edgeless xs = do
+ unLevels <- VM.new 0
+ let allEdges = HMS.empty
+ numVerts = 0
+ g <- Graph <$> newMutVar L {..}
+ mapM_ (insert g) xs
+ return g
+
+-- | Simple version of 'edgeless'.
+edgeless'
+ :: (Eq v, Hashable v, PrimMonad m) => [v] -> m (Graph' (PrimState m) v)
+edgeless' = edgeless
+
+-- | Create the complete graph with the given vertices.
+complete
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => [v] -> m (Graph t (PrimState m) v)
+complete vertices = do
+ g <- edgeless vertices
+ forM_ (pairs vertices) $ \(x, y) -> link g x y
+ return g
+ where
+ pairs :: [a] -> [(a, a)]
+ pairs [] = []
+ pairs (x : xs) =
+ [(x, y) | y <- xs] ++ pairs xs
+
+-- | Simple version of 'complete'
+complete'
+ :: (Eq v, Hashable v, PrimMonad m) => [v] -> m (Graph' (PrimState m) v)
+complete' = complete
+
+-- | /O(log(v))/
+--
+-- Insert an edge in between two vertices. If the vertices already have
+-- an edge between them don't do anything. Returns whether or not an edge was
+-- actually inserted.
+link
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> v -> m Bool
+link (Graph levels) a b = do
+ L {..} <- readMutVar levels
+ let !newAllEdges = linkEdgeSet a b allEdges
+ if memberEdgeSet a b allEdges || a == b || VM.null unLevels
+ then return False
+ else do
+ (thisEtf, thisNonTreeEdges) <- VM.read unLevels 0
+ isTreeEdge <- ET.link thisEtf a b
+ let !thisNonTreeEdges'
+ | isTreeEdge = thisNonTreeEdges
+ | otherwise = linkEdgeSet a b thisNonTreeEdges
+
+ VM.write unLevels 0 (thisEtf, thisNonTreeEdges')
+ writeMutVar levels $ L
+ {allEdges = newAllEdges, unLevels = unLevels, numVerts = numVerts}
+ return True
+
+-- | Version of 'link' which ignores the result.
+link_
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> v -> m ()
+link_ g a b = void (link g a b)
+
+-- | /O(log(v))/
+--
+-- Check if a path exists in between two vertices.
+connected
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> v -> m Bool
+connected _ a b | a == b = return True
+connected (Graph levels) a b = do
+ L {..} <- readMutVar levels
+ if VM.null unLevels
+ then return False
+ else do
+ (etf, _) <- VM.read unLevels 0
+ ET.connected etf a b
+
+-- | Check if this edge exists in the graph.
+edge
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> v -> m Bool
+edge (Graph levels) a b = do
+ L {..} <- readMutVar levels
+ return $ memberEdgeSet a b allEdges
+
+-- | Check if this vertex exists in the graph.
+vertex
+ :: (Eq v, Hashable v, Tree.Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> m Bool
+vertex (Graph levels) a = do
+ L {..} <- readMutVar levels
+ return $ a `HMS.member` allEdges
+
+-- | Ammortized /O(logĀ² v)/
+--
+-- Remove an edge in between two vertices. If there is no edge in between
+-- these vertices, do nothing. Return whether or not an edge was actually
+-- removed.
+cut
+ :: forall t m v. (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> v -> m Bool
+cut (Graph levels) a b = do
+ L {..} <- readMutVar levels
+ let newAllEdges = cutEdgeSet a b allEdges
+ if VM.length unLevels == 0 || a == b
+ then return False
+ else do
+ cut' <- go unLevels (VM.length unLevels-1)
+ writeMutVar levels L {allEdges = newAllEdges, ..}
+ return cut'
+ where
+ go :: VM.MVector (PrimState m) (ET.Forest t (Sum Int) (PrimState m) v, EdgeSet v) -> Int -> m Bool
+ go unLevels idx = do
+ -- traceShowM ("go", idx)
+ (etf, nonTreeEdges0) <- VM.read unLevels idx
+ cutResult <- ET.cut etf a b
+ case cutResult of
+ False -> do
+ let !nonTreeEdges1 = cutEdgeSet a b nonTreeEdges0
+ VM.write unLevels idx (etf, nonTreeEdges1)
+ if idx > 0 then go unLevels (idx - 1) else return False
+ True -> do
+ aSize <- ET.componentSize etf a
+ bSize <- ET.componentSize etf b
+ let (smaller, _bigger) = if aSize <= bSize then (a, b) else (b, a)
+ Just sRoot <- ET.findRoot etf smaller
+
+ -- These are all edges, and vertices within the smaller tree.
+ sTreeEdges <- Tree.toList sRoot
+ let !sVertices = HS.fromList $ map fst $
+ filter (uncurry (==)) sTreeEdges
+
+ -- We need to consider all edges incident to the smaller tree.
+ let sIncidentEdges =
+ [ (x, y)
+ | x <- HS.toList sVertices
+ , y <- maybe [] HS.toList (HMS.lookup x nonTreeEdges0)
+ ]
+
+ -- Find a replacement and punish all edges we visit.
+ let findRep punish [] = (punish, Nothing)
+ findRep punish ((x, y) : candidates)
+ | y `HS.member` sVertices =
+ findRep ((x, y) : punish) candidates
+ | otherwise =
+ (punish, Just (x, y))
+
+ -- Perform the search
+ let (punished, replacementEdge) = findRep [] sIncidentEdges
+
+ -- Increase the levels of the tree edges and the punished edges.
+ nonTreeEdges1 <- if
+ | idx + 1 >= VM.length unLevels -> return nonTreeEdges0
+ | otherwise -> do
+ (incEtf, incNonTreeEdges0) <- VM.read unLevels (idx + 1)
+
+ let moveTreeEdge (x, y) =
+ ET.link_ incEtf x y
+
+ let moveNonTreeEdge !(ntes, !incNTes) (x, y) =
+ (cutEdgeSet x y ntes, linkEdgeSet x y incNTes)
+
+ mapM_ moveTreeEdge sTreeEdges
+ let !(!nonTreeEdges1, !incNonTreeEdges1) = L.foldl'
+ moveNonTreeEdge (nonTreeEdges0, incNonTreeEdges0) punished
+
+ VM.write unLevels (idx + 1) (incEtf, incNonTreeEdges1)
+ return nonTreeEdges1
+
+ case replacementEdge of
+ Nothing -> do
+ VM.write unLevels idx (etf, nonTreeEdges1)
+ if idx > 0 then go unLevels (idx - 1) else return True
+ Just rep@(c, d) -> do
+ let !nonTreeEdges2 = cutEdgeSet c d nonTreeEdges1
+ VM.write unLevels idx (etf, nonTreeEdges2)
+ ET.link_ etf c d
+ propagateReplacement unLevels (idx - 1) rep
+ return True
+
+ propagateReplacement unLevels idx (c, d) = when (idx >= 0) $ do
+ (etf, _) <- VM.read unLevels idx
+ ET.cut_ etf a b
+ ET.link_ etf c d
+ -- TODO: mess with edges??
+ propagateReplacement unLevels (idx - 1) (c, d)
+
+-- | Version of 'cut' which ignores the result.
+cut_
+ :: forall t m v. (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> v -> m ()
+cut_ g a b = void (cut g a b)
+
+-- | Insert a new vertex. Do nothing if it is already there. Returns whether
+-- or not a vertex was inserted in the graph.
+insert
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> m Bool
+insert (Graph g) x = do
+ l@L {..} <- readMutVar g
+ if HMS.member x allEdges then
+ return False
+ else do
+ let newAllEdges = HMS.insert x HS.empty allEdges
+ let numVertices = numVerts + 1
+ unLevels' <- do
+ let oldNumLevels = VM.length unLevels
+ newUnLevels <- VM.take (logBase2 numVertices + 1) <$>
+ VM.grow unLevels (max 0 $ logBase2 numVertices - oldNumLevels + 1)
+ forM_ [oldNumLevels .. logBase2 numVertices] $ \levelIdx -> do
+ df <- ET.edgeless (\v1 v2 -> if v1 == v2 then Sum 1 else Sum 0) $ map fst $ HMS.toList allEdges
+ VM.write newUnLevels levelIdx (df, HMS.empty)
+ return newUnLevels
+ let updateLevel i
+ | i >= VM.length unLevels' = return ()
+ | otherwise = do
+ (forest, nt) <- VM.read unLevels' i
+ ET.insert_ forest x
+ VM.write unLevels' i (forest, nt)
+ updateLevel (i + 1)
+
+ updateLevel 0
+ writeMutVar g $ l {allEdges = newAllEdges, unLevels = unLevels', numVerts = numVertices}
+ return True
+
+-- | Version of 'insert' which ignores the result.
+insert_
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> m ()
+insert_ g x = void (insert g x)
+
+-- | Remove a vertex from the graph, if it exists. If it is connected to any
+-- other vertices, those edges are cut first. Returns whether or not a vertex
+-- was removed from the graph.
+delete
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> m Bool
+delete g@(Graph levels) x = do
+ l0 <- readMutVar levels
+ case HMS.lookup x (allEdges l0) of
+ Nothing -> return False
+ Just nbs -> do
+ forM_ nbs $ \y -> cut g x y
+
+ l1 <- readMutVar levels
+ let newAllEdges = HMS.delete x (allEdges l1)
+ updateLevel i
+ | i >= VM.length (unLevels l1) = return ()
+ | otherwise = do
+ (forest, nt) <- VM.read (unLevels l1) i
+ ET.delete_ forest x
+ VM.write (unLevels l1) i (forest, HMS.delete x nt)
+ updateLevel (i + 1)
+
+ updateLevel 0
+ writeMutVar levels $ l1 {allEdges = newAllEdges, numVerts = numVerts l0 - 1}
+ return True
+
+-- | Version of 'delete' which ignores the result.
+delete_
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> m ()
+delete_ g x = void (delete g x)
+
+-- | Get all neighbours of the given vertex.
+neighbours
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> v -> m (HS.HashSet v)
+neighbours (Graph levels) x = do
+ l0 <- readMutVar levels
+ return $ fromMaybe HS.empty (HMS.lookup x (allEdges l0))
+
+-- | Obtain the current spanning forest.
+spanningForest
+ :: (Eq v, Hashable v, Tree t, PrimMonad m)
+ => Graph t (PrimState m) v -> m (DT.Forest v)
+spanningForest (Graph levels) = do
+ L {..} <- readMutVar levels
+ if VM.null unLevels
+ then return []
+ else do
+ (etf, _) <- VM.read unLevels 0
+ ET.spanningForest etf