From 91da6da0545b05d79a21ed2ea40b3111d938aeb2 Mon Sep 17 00:00:00 2001 From: Shruti Umat Date: Mon, 27 Jul 2020 12:41:15 +0530 Subject: [PATCH 1/4] Begin tsort utility --- src/Streamly/Coreutils.hs | 3 +- src/Streamly/Coreutils/Tsort.hs | 73 +++++++++++++++++++++++++++++++++ streamly-coreutils.cabal | 3 +- 3 files changed, 77 insertions(+), 2 deletions(-) create mode 100644 src/Streamly/Coreutils/Tsort.hs diff --git a/src/Streamly/Coreutils.hs b/src/Streamly/Coreutils.hs index 2519a33..bf930dc 100644 --- a/src/Streamly/Coreutils.hs +++ b/src/Streamly/Coreutils.hs @@ -1,5 +1,6 @@ module Streamly.Coreutils - ( module Streamly.Coreutils.Uniq + ( module Streamly.Coreutils.Tsort + , module Streamly.Coreutils.Uniq ) where import Streamly.Coreutils.Uniq diff --git a/src/Streamly/Coreutils/Tsort.hs b/src/Streamly/Coreutils/Tsort.hs new file mode 100644 index 0000000..a85967b --- /dev/null +++ b/src/Streamly/Coreutils/Tsort.hs @@ -0,0 +1,73 @@ +module Streamly.Coreutils.Tsort + ( + , + , + , + , + , + , + , + ) where + +import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Fold as FL + +import Data.Char (isSpace, toLower) + +import Streamly + +vertices + :: (IsStream t, Monad m, Eq a) + => t m (a, a) + -- ^ Edges + -> t m (Int, a) + -- ^ Map each vertex to a unique integer +vertices strm = + S.indexed $ + S.uniq $ + S.concatMap (\(x, y) -> S.fromList [x, y]) strm + + +buildAdjList + :: (IsStream t, Monad m) + => t m (a, a) + -- ^ stream of edges + -> t m (Int, a) + -- ^ Map from @a@ to @Int@ + -> t m (t m Int) + -- ^ initial adj list + -> t m (t m Int) + -- ^ adj list now + + +dfs + :: (IsStream t, Monad m) + => Int + -- ^ root node to start dfs + -> t m (t m Int) + -- ^ adj list + -> t m Bool + -- ^ visited + -> t m Int + -- ^ parent + -> t m Int + -- ^ the stack + -> m () +dfs root adj vis par stck = do + strm <- S.(!!) adj root + case strm of + Just nbd -> S.filterM isVisited nbd + Nothing -> return () + + where + + isVisited + :: (IsStream t, Monad m) + -> t m Bool + -> Int + -> m Bool + isVisited vis n = do + ele <- S.(!!) vis n + case ele of + Just v -> return v + Nothing -> return True diff --git a/streamly-coreutils.cabal b/streamly-coreutils.cabal index de99b9e..3357cc9 100644 --- a/streamly-coreutils.cabal +++ b/streamly-coreutils.cabal @@ -41,7 +41,8 @@ library streamly , base >= 4.8 && < 5 hs-source-dirs: src - exposed-modules: Streamly.Coreutils.Uniq + exposed-modules: Streamly.Coreutils.Tsort + , Streamly.Coreutils.Uniq , Streamly.Coreutils default-language: Haskell2010 From a9fb669fef9bbfc389b73903b000d212a0d80ba5 Mon Sep 17 00:00:00 2001 From: Shruti Umat Date: Tue, 28 Jul 2020 00:28:56 +0530 Subject: [PATCH 2/4] Add dfs function --- src/Streamly/Coreutils.hs | 3 ++ src/Streamly/Coreutils/Tsort.hs | 92 +++++++++++++++++++++------------ 2 files changed, 61 insertions(+), 34 deletions(-) diff --git a/src/Streamly/Coreutils.hs b/src/Streamly/Coreutils.hs index bf930dc..fd211b9 100644 --- a/src/Streamly/Coreutils.hs +++ b/src/Streamly/Coreutils.hs @@ -1,6 +1,9 @@ module Streamly.Coreutils ( module Streamly.Coreutils.Tsort , module Streamly.Coreutils.Uniq + --, module Streamly.Coreutils.Common ) where +import Streamly.Coreutils.Tsort import Streamly.Coreutils.Uniq +--import Streamly.Coreutils.Common diff --git a/src/Streamly/Coreutils/Tsort.hs b/src/Streamly/Coreutils/Tsort.hs index a85967b..cbf09f4 100644 --- a/src/Streamly/Coreutils/Tsort.hs +++ b/src/Streamly/Coreutils/Tsort.hs @@ -1,12 +1,6 @@ module Streamly.Coreutils.Tsort - ( - , - , - , - , - , - , - , + ( vertices + --, dfs ) where import qualified Streamly.Prelude as S @@ -23,51 +17,81 @@ vertices -> t m (Int, a) -- ^ Map each vertex to a unique integer vertices strm = - S.indexed $ - S.uniq $ - S.concatMap (\(x, y) -> S.fromList [x, y]) strm + S.indexed + $ S.uniq + $ S.concatMap (\(x, y) -> S.fromList [x, y]) strm -buildAdjList - :: (IsStream t, Monad m) - => t m (a, a) - -- ^ stream of edges - -> t m (Int, a) - -- ^ Map from @a@ to @Int@ - -> t m (t m Int) - -- ^ initial adj list - -> t m (t m Int) - -- ^ adj list now +--buildAdjList +-- :: (IsStream t, Monad m) +-- => t m (a, a) +-- -- ^ stream of edges +-- -> t m (Int, a) +-- -- ^ Map from @a@ to @Int@ +-- -> t m (t m Int) +-- -- ^ initial adj list +-- -> t m (t m Int) +-- -- ^ adj list now dfs :: (IsStream t, Monad m) => Int -- ^ root node to start dfs - -> t m (t m Int) + -> SerialT m (SerialT m Int) -- ^ adj list - -> t m Bool + -> SerialT m Bool -- ^ visited -> t m Int -- ^ parent -> t m Int -- ^ the stack - -> m () + -> m (SerialT m Bool, t m Int, t m Int) + -- ^ (parent, stack) dfs root adj vis par stck = do - strm <- S.(!!) adj root + strm <- (S.!!) adj root case strm of - Just nbd -> S.filterM isVisited nbd - Nothing -> return () + Just nbd -> do + maybeTuple <- S.last + $ S.scanlM' + (\(visi, parent, stack) v -> dfs v adj + (markVisited visi v) (setParent parent v root) (S.cons v stck)) + (vis, par, stck) + $ S.filterM (unVisited vis) nbd + case maybeTuple of + Just ans -> return ans + Nothing -> return (vis, par, stck) where - isVisited - :: (IsStream t, Monad m) - -> t m Bool + unVisited + :: Monad m + => SerialT m Bool -> Int -> m Bool - isVisited vis n = do - ele <- S.(!!) vis n + unVisited vis n = do + ele <- (S.!!) vis n case ele of - Just v -> return v - Nothing -> return True + Just v -> return $ not v + Nothing -> return False + + markVisited + :: (IsStream t, Monad m) + => t m Bool + -> Int + -> t m Bool + markVisited strm vtx = do + S.map (\(_, v) -> v) + $ S.map (\(i, v) -> if i == vtx then (i, not v) else (i, v)) + $ S.indexed strm + + setParent + :: (IsStream t, Monad m) + => t m Int + -> Int + -> Int + -> t m Int + setParent strm u par = do + S.map (\(_, v) -> v) + $ S.map (\(i, v) -> if i == u then (i, par) else (i, v)) + $ S.indexed strm From 282a1521a46642d59ad7d5e11a870a8f24d3bea6 Mon Sep 17 00:00:00 2001 From: Shruti Umat Date: Tue, 28 Jul 2020 23:23:53 +0530 Subject: [PATCH 3/4] Add function to build Adjacency list --- src/Streamly/Coreutils/Tsort.hs | 106 +++++++++++++++++++++++--------- 1 file changed, 78 insertions(+), 28 deletions(-) diff --git a/src/Streamly/Coreutils/Tsort.hs b/src/Streamly/Coreutils/Tsort.hs index cbf09f4..ce21dbb 100644 --- a/src/Streamly/Coreutils/Tsort.hs +++ b/src/Streamly/Coreutils/Tsort.hs @@ -1,20 +1,22 @@ module Streamly.Coreutils.Tsort ( vertices - --, dfs + , buildAdjList + , dfs ) where import qualified Streamly.Prelude as S -import qualified Streamly.Internal.Data.Fold as FL +--import qualified Streamly.Internal.Data.Fold as FL -import Data.Char (isSpace, toLower) +--import Data.Char (isSpace, toLower) +import System.IO.Unsafe (unsafePerformIO) import Streamly vertices - :: (IsStream t, Monad m, Eq a) - => t m (a, a) + :: Eq a + => SerialT IO (a, a) -- ^ Edges - -> t m (Int, a) + -> SerialT IO (Int, a) -- ^ Map each vertex to a unique integer vertices strm = S.indexed @@ -22,32 +24,79 @@ vertices strm = $ S.concatMap (\(x, y) -> S.fromList [x, y]) strm ---buildAdjList --- :: (IsStream t, Monad m) --- => t m (a, a) --- -- ^ stream of edges --- -> t m (Int, a) --- -- ^ Map from @a@ to @Int@ --- -> t m (t m Int) --- -- ^ initial adj list --- -> t m (t m Int) --- -- ^ adj list now +buildAdjList + :: Eq a + => SerialT IO (a, a) + -- ^ stream of edges + -> SerialT IO (Int, a) + -- ^ Map from @a@ to @Int@ + -> SerialT IO (SerialT IO Int) + -- ^ initial adj list + -> SerialT IO (SerialT IO Int) + -- ^ adj list now +buildAdjList edges vtx adj = do + let maybeStrm = unsafePerformIO $ S.last $ S.scanl' (insertPair vtx) adj edges + case maybeStrm of + Just strm -> strm + Nothing -> S.nil + + where + + insertPair + :: Eq a + => SerialT IO (Int, a) + -> SerialT IO (SerialT IO Int) + -> (a, a) + -> SerialT IO (SerialT IO Int) + insertPair vtxMap adjl (xa, xb) = do + let indexA = unsafePerformIO $ getInt vtxMap xa + let indexB = unsafePerformIO $ getInt vtxMap xb + let maybeStrm = unsafePerformIO $ (S.!!) adjl indexA + case maybeStrm of + Just strm -> modifyNeighbours indexA (S.cons indexB $ strm) adjl + Nothing -> modifyNeighbours indexA (S.yield indexB) adjl + + + getInt + :: Eq a + => SerialT IO (Int, a) + -> a + -> IO Int + getInt vtxMap ele = do + maybeIndex <- S.findIndex (\(_, v) -> v == ele) vtxMap + case maybeIndex of + Just idx -> return idx + Nothing -> return (-1) -- won't ever equal any other index in a stream + + modifyNeighbours + :: Int + -> SerialT IO Int + -> SerialT IO (SerialT IO Int) + -> SerialT IO (SerialT IO Int) + modifyNeighbours idx newNbd adjStrm = + S.map (\(_, v) -> v) + $ S.map (\(i, v) -> do + if i == idx + then (i, newNbd) + else (i, v)) + $ S.indexed adjStrm +-- | dfs dfs - :: (IsStream t, Monad m) + :: IsStream t => Int -- ^ root node to start dfs - -> SerialT m (SerialT m Int) + -> SerialT IO (SerialT IO Int) -- ^ adj list - -> SerialT m Bool + -> SerialT IO Bool -- ^ visited - -> t m Int + -> t IO Int -- ^ parent - -> t m Int + -> t IO Int -- ^ the stack - -> m (SerialT m Bool, t m Int, t m Int) - -- ^ (parent, stack) + -> IO (SerialT IO Bool, t IO Int, t IO Int) + -- ^ (visited, parent, stack) dfs root adj vis par stck = do strm <- (S.!!) adj root case strm of @@ -55,11 +104,12 @@ dfs root adj vis par stck = do maybeTuple <- S.last $ S.scanlM' (\(visi, parent, stack) v -> dfs v adj - (markVisited visi v) (setParent parent v root) (S.cons v stck)) + (markVisited visi v) (setParent parent v root) (S.cons v stack)) (vis, par, stck) $ S.filterM (unVisited vis) nbd case maybeTuple of Just ans -> return ans + _ -> return (S.nil, S.nil, S.nil) Nothing -> return (vis, par, stck) where @@ -69,8 +119,8 @@ dfs root adj vis par stck = do => SerialT m Bool -> Int -> m Bool - unVisited vis n = do - ele <- (S.!!) vis n + unVisited visStream n = do + ele <- (S.!!) visStream n case ele of Just v -> return $ not v Nothing -> return False @@ -91,7 +141,7 @@ dfs root adj vis par stck = do -> Int -> Int -> t m Int - setParent strm u par = do + setParent strm u parent = do S.map (\(_, v) -> v) - $ S.map (\(i, v) -> if i == u then (i, par) else (i, v)) + $ S.map (\(i, v) -> if i == u then (i, parent) else (i, v)) $ S.indexed strm From 0754ce65fec17894961efbdc270a59ff43632aa6 Mon Sep 17 00:00:00 2001 From: Shruti Umat Date: Mon, 3 Aug 2020 00:58:34 +0530 Subject: [PATCH 4/4] DFS uses general monad m but buildAdjList works with IO only, general stream type Remove common module import Remove unnecessary imports, fix indentation --- src/Streamly/Coreutils.hs | 2 - src/Streamly/Coreutils/Tsort.hs | 94 ++++++++++++++++++--------------- 2 files changed, 51 insertions(+), 45 deletions(-) diff --git a/src/Streamly/Coreutils.hs b/src/Streamly/Coreutils.hs index fd211b9..ce373ca 100644 --- a/src/Streamly/Coreutils.hs +++ b/src/Streamly/Coreutils.hs @@ -1,9 +1,7 @@ module Streamly.Coreutils ( module Streamly.Coreutils.Tsort , module Streamly.Coreutils.Uniq - --, module Streamly.Coreutils.Common ) where import Streamly.Coreutils.Tsort import Streamly.Coreutils.Uniq ---import Streamly.Coreutils.Common diff --git a/src/Streamly/Coreutils/Tsort.hs b/src/Streamly/Coreutils/Tsort.hs index ce21dbb..3625ddf 100644 --- a/src/Streamly/Coreutils/Tsort.hs +++ b/src/Streamly/Coreutils/Tsort.hs @@ -5,18 +5,17 @@ module Streamly.Coreutils.Tsort ) where import qualified Streamly.Prelude as S ---import qualified Streamly.Internal.Data.Fold as FL ---import Data.Char (isSpace, toLower) +import Streamly import System.IO.Unsafe (unsafePerformIO) +import Streamly.Internal.Data.Stream.StreamK (adapt) -import Streamly vertices - :: Eq a - => SerialT IO (a, a) + :: (IsStream t, Eq a) + => t IO (a, a) -- ^ Edges - -> SerialT IO (Int, a) + -> t IO (Int, a) -- ^ Map each vertex to a unique integer vertices strm = S.indexed @@ -25,86 +24,95 @@ vertices strm = buildAdjList - :: Eq a - => SerialT IO (a, a) + :: (IsStream t, Eq a) + => t IO (a, a) -- ^ stream of edges - -> SerialT IO (Int, a) - -- ^ Map from @a@ to @Int@ - -> SerialT IO (SerialT IO Int) + -> t IO (Int, a) + -- ^ map from @a@ to @Int@ + -> t IO (t IO Int) -- ^ initial adj list - -> SerialT IO (SerialT IO Int) + -> t IO (t IO Int) -- ^ adj list now buildAdjList edges vtx adj = do - let maybeStrm = unsafePerformIO $ S.last $ S.scanl' (insertPair vtx) adj edges + let maybeStrm = + ( unsafePerformIO + $ S.last + $ adapt + $ S.scanl' (insertPair vtx) adj edges + ) case maybeStrm of - Just strm -> strm - Nothing -> S.nil + Just strm -> strm + Nothing -> S.nil where insertPair - :: Eq a - => SerialT IO (Int, a) - -> SerialT IO (SerialT IO Int) + :: (IsStream t, Eq a) + => t IO (Int, a) + -> t IO (t IO Int) -> (a, a) - -> SerialT IO (SerialT IO Int) + -> t IO (t IO Int) insertPair vtxMap adjl (xa, xb) = do let indexA = unsafePerformIO $ getInt vtxMap xa let indexB = unsafePerformIO $ getInt vtxMap xb - let maybeStrm = unsafePerformIO $ (S.!!) adjl indexA + let maybeStrm = unsafePerformIO $ (S.!!) (adapt adjl) indexA case maybeStrm of - Just strm -> modifyNeighbours indexA (S.cons indexB $ strm) adjl + Just strm -> modifyNeighbours indexA (S.cons indexB strm) adjl Nothing -> modifyNeighbours indexA (S.yield indexB) adjl + getInt - :: Eq a - => SerialT IO (Int, a) + :: (IsStream t, Eq a) + => t IO (Int, a) -> a -> IO Int getInt vtxMap ele = do - maybeIndex <- S.findIndex (\(_, v) -> v == ele) vtxMap + maybeIndex <- S.findIndex (\(_, v) -> v == ele) $ adapt vtxMap case maybeIndex of Just idx -> return idx Nothing -> return (-1) -- won't ever equal any other index in a stream modifyNeighbours - :: Int - -> SerialT IO Int - -> SerialT IO (SerialT IO Int) - -> SerialT IO (SerialT IO Int) + :: IsStream t + => Int + -> t IO Int + -> t IO (t IO Int) + -> t IO (t IO Int) modifyNeighbours idx newNbd adjStrm = S.map (\(_, v) -> v) $ S.map (\(i, v) -> do - if i == idx - then (i, newNbd) - else (i, v)) + if i == idx + then (i, newNbd) + else (i, v)) $ S.indexed adjStrm -- | dfs dfs - :: IsStream t + :: (IsStream t, Monad m) => Int -- ^ root node to start dfs - -> SerialT IO (SerialT IO Int) + -> t m (t m Int) -- ^ adj list - -> SerialT IO Bool + -> t m Bool -- ^ visited - -> t IO Int + -> t m Int -- ^ parent - -> t IO Int + -> t m Int -- ^ the stack - -> IO (SerialT IO Bool, t IO Int, t IO Int) + -> m (t m Bool, t m Int, t m Int) -- ^ (visited, parent, stack) dfs root adj vis par stck = do - strm <- (S.!!) adj root + strm <- (S.!!) (adapt adj) root case strm of Just nbd -> do maybeTuple <- S.last + $ adapt $ S.scanlM' - (\(visi, parent, stack) v -> dfs v adj - (markVisited visi v) (setParent parent v root) (S.cons v stack)) + (\(visi, parent, stack) v -> + dfs v adj (markVisited visi v) + (setParent parent v root) (S.cons v stack)) (vis, par, stck) $ S.filterM (unVisited vis) nbd case maybeTuple of @@ -115,12 +123,12 @@ dfs root adj vis par stck = do where unVisited - :: Monad m - => SerialT m Bool + :: (IsStream t, Monad m) + => t m Bool -> Int -> m Bool unVisited visStream n = do - ele <- (S.!!) visStream n + ele <- (S.!!) (adapt visStream) n case ele of Just v -> return $ not v Nothing -> return False