scc.icl

   1 implementation module scc
   2
   3 import StdEnv, StdMaybe
   4 import Data.Map => qualified updateAt
   5
   6 :: St a = {nextindex :: Int, stack :: [a], map :: Map a Annot, sccs :: [[a]]}
   7 :: Annot = {index :: Int, lowlink :: Int, onstack :: Bool}
   8
   9 scc :: [(a, [a])] -> [[a]] | Eq, Ord a
  10 scc nodes = (foldr strongconnect {nextindex=0,stack=[],map=newMap,sccs=[]} nodes).sccs
  11 where
  12 //      strongconnect :: (a, [a]) (St a) -> St a | Eq, Ord a
  13         strongconnect (v, suc) s
  14                 | isJust (get v s.map) = s
  15                 # s = foldr processSucc
  16                         { s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
  17                         , stack     = [v:s.stack]
  18                         , nextindex = s.nextindex + 1
  19                         } suc
  20                 # (Just a) = get v s.map
  21                 | a.index == a.lowlink
  22                         # (scc, [sl:stack]) = span ((<>) v) s.stack
  23                         # scc = scc ++ [sl]
  24                         = { s & sccs = [scc:s.sccs]
  25                           , stack    = stack
  26                           , map      = foldr (alter \(Just s)->Just {s & onstack=False}) s.map scc
  27                           }
  28                 = s
  29         where
  30 //              processSucc :: a (St a) -> St a | Eq, Ord a
  31                 processSucc w s = case get w s.map of
  32                         Nothing
  33                                 # s = strongconnect (hd [l\\l=:(n, _)<-nodes | n == w]) s
  34                                 # (Just aw) = get w s.map
  35                                 # (Just av) = get v s.map
  36                                 = {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}
  37                         Just aw=:{onstack=True}
  38                                 # (Just av) = get v s.map
  39                                 = {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map}
  40                         Just _ = s