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 = reverse (foldr (strongconnect nodes) {nextindex=zero,stack=[],map=newMap,sccs=[]} nodes).sccs
  11 where
  12         strongconnect :: ![(a, [a])] !(a, [a]) !(St a) -> St a | Eq, Ord a
  13         strongconnect nodes (v, suc) s
  14                 | isJust (get v s.map) = s
  15                 # s = foldr (processSucc nodes v)
  16                         { s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
  17                         , stack     = [v:s.stack]
  18                         , nextindex = inc s.nextindex
  19                         } suc
  20                 # (Just a) = get v s.map
  21                 | a.index <> a.lowlink = s
  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         where
  29                 processSucc :: ![(a, [a])] !a !a !(St a) -> St a | Eq, Ord a
  30                 processSucc nodes v w s = case get w s.map of
  31                         Nothing
  32                                 # n = filter ((==)w o fst) nodes
  33                                 | n =: [] = s
  34                                 # s = strongconnect nodes (hd n) s
  35                                 # (Just aw) = get w s.map
  36                                 # (Just av) = get v s.map
  37                                 = {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}
  38                         Just aw=:{onstack=True}
  39                                 # (Just av) = get v s.map
  40                                 = {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map}
  41                         Just _ = s