NewSCC.hs

module NewSCC (sccEq,scc) where

{- A module to find strongly connected components 
 - and perform a topological sort on them.
 - This is Lennart Augusstoson's code (from hbc?)
 - converted to Haskell by Iavor Diatchki.  
 -}

import OpTypes
import Products((><))
import StateM
import Maybe (fromJust,listToMaybe)


sccEq               :: EqOp a -> Graph a -> [Graph a]
scc                 :: Eq a => Graph a -> [Graph a]


lkpEq eq x xs = listToMaybe [ v | (k,v) <- xs, x `eq` k ]
nonfailLkpEq eq x = fromJust . lkpEq eq x

type Graph a        = [(a, [a])]
type Numbering a    = [(a, Int)]

type RW a = (Int, Numbering a, Graph a, Int)
pushMany xs (x,ns,ss,y) = (x,ns,ss ++ xs,y)
minLast m (x,ns,ss,y)   = (x,ns,ss,min y m)
getNumbering (x,ns,ss,y) = ns


sccEq eq gG = concat $ withSt [] $ mapM (g eq gG) gG
scc         = sccEq (==)


g :: EqOp a -> Graph a -> (a,[a]) -> StateM (Numbering a) [Graph a]
g eq gG vv@(v,_)   = do 
    low <- getSt
    let found       = const (return [])
        notFound    = let (cs4, st) = searchC eq gG 1 low vv
                      in setSt (getNumbering st) >> return cs4
    maybe notFound found (lkpEq eq v low)




searchC :: EqOp a -> Graph a ->
            Int -> Numbering a -> (a,[a]) -> ([Graph a], RW a)
searchC eq g n low vv@(v, es) 
    | nonfailLkpEq eq v low' == min' =
            (cs' ++ [nstack],
             (n', map (id >< const maxBound) nstack ++ low', [], min'))
    | otherwise = (cs', (n', low', nstack, min'))
    where    
    cs'     = concat cs2
    (cs2, (n', low', nstack, min'))
        = let n1 = n + 1 
              initSt = (n1, (v,n1) : low , [vv], n1)
        in withStS initSt $ mapM (f eq g) es 



-- f :: EqOp a -> Graph a -> a -> StateM (RW a) [Graph a]
f eq g v = do
    (n, low, stack, min') <- getSt
    res <- case lkpEq eq v low of
        Nothing -> let (r,s) = searchC eq g n low (findVV eq g v)
                   in do setSt s; return r
        Just vm -> do setSt (n, low, [], vm); return []

    updSt (minLast min' . pushMany stack)
    return res


findVV :: EqOp a -> Graph a -> a -> (a, [a])
findVV eq g v = (v, nonfailLkpEq eq v g)



test = [('c', [])
       ,('a', ['b','c'])
       ,('b', ['a'])
       ]

test1 = [('a', "b")
        ,('c', "b")
        ,('b', "")
        ]