separate

[minfp.git] / scc.icl

diff --git a/scc.icl b/scc.icl
new file mode 100644 (file)
index 0000000..7803f8b
--- /dev/null
+++ b/scc.icl
@@ -0,0 +1,40 @@
+implementation module scc
+
+import StdEnv, StdMaybe
+import Data.Map => qualified updateAt
+
+:: St a = {nextindex :: Int, stack :: [a], map :: Map a Annot, sccs :: [[a]]}
+:: Annot = {index :: Int, lowlink :: Int, onstack :: Bool}
+
+scc :: [(a, [a])] -> [[a]] | Eq, Ord a
+scc nodes = (foldr strongconnect {nextindex=0,stack=[],map=newMap,sccs=[]} nodes).sccs
+where
+//     strongconnect :: (a, [a]) (St a) -> St a | Eq, Ord a
+       strongconnect (v, suc) s
+               | isJust (get v s.map) = s
+               # s = foldr processSucc
+                       { s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
+                       , stack     = [v:s.stack]
+                       , nextindex = s.nextindex + 1
+                       } suc
+               # (Just a) = get v s.map
+               | a.index == a.lowlink
+                       # (scc, [sl:stack]) = span ((<>) v) s.stack
+                       # scc = scc ++ [sl]
+                       = { s & sccs = [scc:s.sccs]
+                         , stack= stack
+                         , map  = foldr (alter \(Just s)->Just {s & onstack=False}) s.map scc
+                         }
+               = s
+       where
+//             processSucc :: a (St a) -> St a | Eq, Ord a
+               processSucc w s = case get w s.map of
+                       Nothing
+                               # s = strongconnect (hd [l\\l=:(n, _)<-nodes | n == w]) s
+                               # (Just aw) = get w s.map
+                               # (Just av) = get v s.map
+                               = {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}
+                       Just aw=:{onstack=True}
+                               # (Just av) = get v s.map
+                               = {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map}
+                       Just _ = s