Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- import Control.Monad
- import Control.Monad.Fix
- import Control.Monad.Primitive
- import Control.Monad.ST
- import Data.Primitive.MutVar
- import qualified Data.Vector as V
- import qualified Data.Vector.Generic.Mutable as VM
- import qualified Data.Vector.Unboxed.Mutable as VUM
- import qualified Data.Vector.Unboxed as VU
- import Data.List
- newtype LVector s a = LVector (VU.MVector s a, MutVar s Int)
- new :: (VU.Unbox a, PrimMonad m) => Int -> m (LVector (PrimState m) a)
- new n = do
- vec <- VUM.new n
- len <- newMutVar 0
- return $ LVector (vec, len)
- freeze
- :: (VU.Unbox a, PrimMonad m) => LVector (PrimState m) a -> m (VU.Vector a)
- freeze (LVector (v, mv)) = do
- m <- readMutVar mv
- fmap (VU.take m) $ VU.freeze v
- push :: (VU.Unbox a, PrimMonad m) => LVector (PrimState m) a -> a -> m ()
- push lv@(LVector (vec, mv)) a = do
- m <- readMutVar mv
- when (VUM.length vec == m) $ do
- VUM.grow vec (VUM.length vec)
- return ()
- VUM.write vec m a
- writeMutVar mv (m + 1)
- -------
- type Graph node = [(node,[node])]
- construct
- :: Eq node => Graph node -> (V.Vector node, GraphInternal, GraphInternal)
- construct gnode = runST $ do
- let ns = V.fromList $ map fst gnode
- let rs = V.foldl' (\acc (v, k) i -> if i == k then v else acc i) (\_ -> (-1))
- $ V.indexed ns
- g <- VM.replicateM (V.length ns) (new 10)
- gt <- VM.replicateM (V.length ns) (new 10)
- flip mapM_ (zip [0 ..] gnode) $ \(i, (_, es)) -> do
- flip mapM_ (map rs es) $ \e -> do
- gi <- VM.read g i
- push gi e
- gti <- VM.read gt e
- push gti i
- (,,)
- <$> pure ns
- <*> (V.mapM freeze =<< V.freeze g)
- <*> (V.mapM freeze =<< V.freeze gt)
- type GraphInternal = V.Vector (VU.Vector Int)
- scc :: Eq node => Graph node -> V.Vector (V.Vector node)
- scc gr = V.map (V.map (mapper V.!) . V.convert) build
- where
- (mapper, g, gt) = construct gr
- order :: VU.Vector Int
- order = VU.reverse $ runST $ do
- used <- VUM.replicate (V.length g) False
- order <- new 10
- flip fix (0 :: Int) $ \f i -> do
- b <- VM.read used i
- if b
- then return (-1)
- else do
- VM.write used i True
- VU.mapM_ f (g V.! i)
- push order i
- if i == V.length g - 1 then return 0 else f (i + 1)
- freeze order
- computed :: VU.Vector Int
- size :: Int
- (computed, size) = runST $ do
- comp <- VUM.replicate (V.length g) (-1)
- cnt <- newMutVar 0
- VU.forM_ order $ \o -> do
- b <- VUM.read comp o
- c <- readMutVar cnt
- when (b == -1) $ do
- go comp o c
- writeMutVar cnt (c + 1)
- (,) <$> VU.freeze comp <*> readMutVar cnt
- where
- go comp idx cnt = do
- b <- VUM.read comp idx
- when (b == -1) $ do
- VUM.write comp idx cnt
- VU.mapM_ (\to -> go comp to cnt) (gt V.! idx)
- build :: GraphInternal
- build = runST $ do
- comps <- VM.replicateM size $ new 10
- forM_ [0 .. V.length g - 1] $ \i -> do
- VU.forM_ (g V.! i) $ \to -> do
- let x = computed VU.! i
- let y = computed VU.! to
- when (x == y) $ do
- tx <- VM.read comps x
- push tx i
- V.mapM freeze =<< V.freeze comps
- example :: Graph String
- example =
- [ ("1", ["2"])
- , ("2", ["3", "5", "6"])
- , ("3", ["4", "7"])
- , ("4", ["3", "8"])
- , ("5", ["1", "6"])
- , ("6", ["7"])
- , ("7", ["6", "8"])
- , ("8", ["8"])
- ]
- main = print $ scc example
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement