module Base.SCC (scc) where
import qualified Data.Set as Set (empty, member, insert)
data Node a b = Node { Node a b -> Int
key :: Int, Node a b -> [b]
bvs :: [b], Node a b -> [b]
fvs :: [b], Node a b -> a
node :: a }
instance Eq (Node a b) where
n1 :: Node a b
n1 == :: Node a b -> Node a b -> Bool
== n2 :: Node a b
n2 = Node a b -> Int
forall a b. Node a b -> Int
key Node a b
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Node a b -> Int
forall a b. Node a b -> Int
key Node a b
n2
instance Ord (Node b a) where
n1 :: Node b a
n1 compare :: Node b a -> Node b a -> Ordering
`compare` n2 :: Node b a
n2 = Node b a -> Int
forall a b. Node a b -> Int
key Node b a
n1 Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Node b a -> Int
forall a b. Node a b -> Int
key Node b a
n2
scc :: Eq b => (a -> [b])
-> (a -> [b])
-> [a]
-> [[a]]
scc :: (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc bvs' :: a -> [b]
bvs' fvs' :: a -> [b]
fvs' = ([Node a b] -> [a]) -> [[Node a b]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ((Node a b -> a) -> [Node a b] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Node a b -> a
forall a b. Node a b -> a
node) ([[Node a b]] -> [[a]]) -> ([a] -> [[Node a b]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node a b] -> [[Node a b]]
forall b a. Eq b => [Node a b] -> [[Node a b]]
tsort' ([Node a b] -> [[Node a b]])
-> ([a] -> [Node a b]) -> [a] -> [[Node a b]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node a b] -> [Node a b]
forall b a. Eq b => [Node a b] -> [Node a b]
tsort ([Node a b] -> [Node a b])
-> ([a] -> [Node a b]) -> [a] -> [Node a b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> Node a b) -> [Int] -> [a] -> [Node a b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> a -> Node a b
wrap [0 ..]
where wrap :: Int -> a -> Node a b
wrap i :: Int
i n :: a
n = Int -> [b] -> [b] -> a -> Node a b
forall a b. Int -> [b] -> [b] -> a -> Node a b
Node Int
i (a -> [b]
bvs' a
n) (a -> [b]
fvs' a
n) a
n
tsort :: Eq b => [Node a b] -> [Node a b]
tsort :: [Node a b] -> [Node a b]
tsort xs :: [Node a b]
xs = (Set (Node a b), [Node a b]) -> [Node a b]
forall a b. (a, b) -> b
snd ([Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [Node a b]
xs Set (Node a b)
forall a. Set a
Set.empty []) where
dfs :: [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [] marks :: Set (Node a b)
marks stack :: [Node a b]
stack = (Set (Node a b)
marks,[Node a b]
stack)
dfs (x :: Node a b
x : xs' :: [Node a b]
xs') marks :: Set (Node a b)
marks stack :: [Node a b]
stack
| Node a b
x Node a b -> Set (Node a b) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Node a b)
marks = [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [Node a b]
xs' Set (Node a b)
marks [Node a b]
stack
| Bool
otherwise = [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs [Node a b]
xs' Set (Node a b)
marks' (Node a b
x Node a b -> [Node a b] -> [Node a b]
forall a. a -> [a] -> [a]
: [Node a b]
stack')
where (marks' :: Set (Node a b)
marks',stack' :: [Node a b]
stack') = [Node a b]
-> Set (Node a b) -> [Node a b] -> (Set (Node a b), [Node a b])
dfs (Node a b -> [Node a b]
forall a. Node a b -> [Node a b]
defs Node a b
x) (Node a b
x Node a b -> Set (Node a b) -> Set (Node a b)
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (Node a b)
marks) [Node a b]
stack
defs :: Node a b -> [Node a b]
defs x1 :: Node a b
x1 = (Node a b -> Bool) -> [Node a b] -> [Node a b]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> Bool) -> [b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (b -> [b] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Node a b -> [b]
forall a b. Node a b -> [b]
fvs Node a b
x1) ([b] -> Bool) -> (Node a b -> [b]) -> Node a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node a b -> [b]
forall a b. Node a b -> [b]
bvs) [Node a b]
xs
tsort' :: Eq b => [Node a b] -> [[Node a b]]
tsort' :: [Node a b] -> [[Node a b]]
tsort' xs :: [Node a b]
xs = (Set (Node a b), [[Node a b]]) -> [[Node a b]]
forall a b. (a, b) -> b
snd ([Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [Node a b]
xs Set (Node a b)
forall a. Set a
Set.empty []) where
dfs :: [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [] marks :: Set (Node a b)
marks stack :: [[Node a b]]
stack = (Set (Node a b)
marks,[[Node a b]]
stack)
dfs (x :: Node a b
x : xs' :: [Node a b]
xs') marks :: Set (Node a b)
marks stack :: [[Node a b]]
stack
| Node a b
x Node a b -> Set (Node a b) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Node a b)
marks = [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [Node a b]
xs' Set (Node a b)
marks [[Node a b]]
stack
| Bool
otherwise = [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs [Node a b]
xs' Set (Node a b)
marks' ((Node a b
x Node a b -> [Node a b] -> [Node a b]
forall a. a -> [a] -> [a]
: [[Node a b]] -> [Node a b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Node a b]]
stack') [Node a b] -> [[Node a b]] -> [[Node a b]]
forall a. a -> [a] -> [a]
: [[Node a b]]
stack)
where (marks' :: Set (Node a b)
marks',stack' :: [[Node a b]]
stack') = [Node a b]
-> Set (Node a b) -> [[Node a b]] -> (Set (Node a b), [[Node a b]])
dfs (Node a b -> [Node a b]
forall a. Node a b -> [Node a b]
uses Node a b
x) (Node a b
x Node a b -> Set (Node a b) -> Set (Node a b)
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set (Node a b)
marks) []
uses :: Node a b -> [Node a b]
uses x1 :: Node a b
x1 = (Node a b -> Bool) -> [Node a b] -> [Node a b]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> Bool) -> [b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (b -> [b] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Node a b -> [b]
forall a b. Node a b -> [b]
bvs Node a b
x1) ([b] -> Bool) -> (Node a b -> [b]) -> Node a b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node a b -> [b]
forall a b. Node a b -> [b]
fvs) [Node a b]
xs