+
+:: Node a :== (a, [a])
+:: SCCState a =
+ { index :: Int
+ , stack :: [a]
+ , map :: Map a (Int, Int, Bool)
+ , sccs :: [[a]]
+ }
+
+import StdDebug
+import Text.GenPrint
+scc :: [Node a] -> [[a]] | Eq, Ord a
+scc nodes = (foldr scc` {index=0,stack=[],map=newMap,sccs=[]} nodes).sccs
+where
+// scc` :: (Node a) (SCCState a) -> SCCState a | Eq, Ord a
+ scc` (v, suc) s = maybe (strongconnect s (v, suc)) (\_->s) $ get v s.map
+
+// strongconnect :: (SCCState a) (Node a)-> SCCState a | Eq, Ord a
+ strongconnect s (v, suc)
+ # s = flip (foldr processSucc) suc
+ { s
+ & map = 'Data.Map'.put v (s.index, s.index, True) s.map
+ , stack = [v:s.stack]
+ , index = s.index + 1
+ }
+ # (Just (iv, lv, lo)) = get v s.map
+ | iv == lv
+ # (scc, [sl:stack]) = span ((<>) v) s.stack
+ # scc = scc ++ [sl]
+ = { s
+ & sccs = [scc:s.sccs]
+ , stack= stack
+ , map = foldr (\w m->'Data.Map'.put w (appThd3 (\_->False) $ fromJust (get w m)) m) s.map scc
+ }
+ = s
+ where
+// processSucc :: a (SCCState a) -> SCCState a | Eq, Ord a
+ processSucc w s = case get w s.map of
+ Nothing
+ # s = strongconnect s $ hd [l\\l=:(n, _)<-nodes | n == w]
+ # (Just (iw, lw, ow)) = get w s.map
+ # (Just (iv, lv, ov)) = get v s.map
+ = {s & map='Data.Map'.put v (iv, min lv lw, ov) s.map}
+ Just (iw, lw, True)
+ # (Just (iv, lv, ov)) = get v s.map
+ = {s & map='Data.Map'.put v (iv, min iw lv, ov) s.map}
+ Just _ = s
+