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 = reverse (foldr (strongconnect nodes) {nextindex=zero,stack=[],map=newMap,sccs=[]} nodes).sccs
where
	strongconnect :: ![(a, [a])] !(a, [a]) !(St a) -> St a | Eq, Ord a
	strongconnect nodes (v, suc) s
		| isJust (get v s.map) = s
		# s = foldr (processSucc nodes v)
			{ s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
			, stack     = [v:s.stack]
			, nextindex = inc s.nextindex
			} suc
		# (Just a) = get v s.map
		| a.index <> a.lowlink = s
		# (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
		  }
	where
		processSucc :: ![(a, [a])] !a !a !(St a) -> St a | Eq, Ord a
		processSucc nodes v w s = case get w s.map of
			Nothing
				# n = filter ((==)w o fst) nodes
				| n =: [] = s
				# s = strongconnect nodes (hd n) 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