auxprogs/DotToScc.hs

-- A program for extracting strongly connected components from a .dot
-- file created by auxprogs/gen-mdg.

-- How to use: one of the following:

-- compile to an exe:   ghc -o dottoscc DotToScc.hs
--    and then    ./dottoscc name_of_file.dot

-- or interpret with runhugs:
--    runhugs DotToScc.hs name_of_file.dot

-- or run within hugs:
--    hugs DotToScc.hs
--    Main> imain "name_of_file.dot"


module Main where

import System
import List ( sort, nub )

usage :: IO ()
usage = putStrLn "usage: dottoscc <name_of_file.dot>"

main :: IO ()
main = do args <- getArgs
          if length args /= 1
           then usage
           else imain (head args)

imain :: String -> IO ()
imain dot_file_name
   = do edges <- read_dot_file dot_file_name
        let sccs = gen_sccs edges
        let pretty = showPrettily sccs
        putStrLn pretty
     where
        showPrettily :: [[String]] -> String
        showPrettily = unlines . concatMap showScc

        showScc elems
           = let n = length elems 
             in
                [""]
                ++ (if n > 1 then ["   -- " 
                                   ++ show n ++ " modules in cycle"] 
                             else [])
                ++ map ("   " ++) elems


-- Read a .dot file and return a list of edges
read_dot_file :: String{-filename-} -> IO [(String,String)]
read_dot_file dot_file_name
   = do bytes <- readFile dot_file_name
        let linez = lines bytes
        let edges = [(s,d) | Just (s,d) <- map maybe_mk_edge linez]
        return edges
     where
        -- identify lines of the form "text1 -> text2" and return
        -- text1 and text2
        maybe_mk_edge :: String -> Maybe (String, String)
        maybe_mk_edge str
           = case words str of
                [text1, "->", text2] -> Just (text1, text2)
                other                -> Nothing


-- Take the list of edges and return a topologically sorted list of
-- sccs
gen_sccs :: [(String,String)] -> [[String]]
gen_sccs raw_edges
   = let clean_edges = sort (nub raw_edges)
         nodes       = nub (concatMap (\(s,d) -> [s,d]) clean_edges)
         ins  v      = [u | (u,w) <- clean_edges, v==w]
         outs v      = [w | (u,w) <- clean_edges, v==u]
         components  = map (sort.utSetToList) (deScc ins outs nodes)
     in
         components


--------------------------------------------------------------------
--------------------------------------------------------------------
--------------------------------------------------------------------

-- Graph-theoretic stuff that does the interesting stuff.

-- ==========================================================--
--
deScc :: (Ord a) =>
         (a -> [a]) -> -- The "ins"  map
         (a -> [a]) -> -- The "outs" map
         [a]        -> -- The root vertices
         [Set a]       -- The topologically sorted components

deScc ins outs
   = spanning . depthFirst
     where depthFirst = snd . deDepthFirstSearch outs (utSetEmpty, [])
           spanning   = snd . deSpanningSearch   ins  (utSetEmpty, [])


-- =========================================================--
--
deDepthFirstSearch :: (Ord a) =>
                      (a -> [a])   -> -- The map,
                      (Set a, [a]) -> -- state: visited set,
                                      --      current sequence of vertices
                      [a]          -> -- input vertices sequence
                      (Set a, [a])    -- final state

deDepthFirstSearch
   = foldl . search
     where
     search relation (visited, sequence) vertex
      | utSetElementOf vertex visited   = (visited,          sequence )
      | otherwise                       = (visited', vertex: sequence')
        where
        (visited', sequence')
         = deDepthFirstSearch relation
                           (utSetUnion visited (utSetSingleton vertex), sequence)
                           (relation vertex)


-- ==========================================================--
--
deSpanningSearch   :: (Ord a) =>
                      (a -> [a])       -> -- The map
                      (Set a, [Set a]) -> -- Current state: visited set,
                                          --  current sequence of vertice sets
                      [a]              -> -- Input sequence of vertices
                      (Set a, [Set a])    -- Final state

deSpanningSearch
   = foldl . search
     where
     search relation (visited, utSetSequence) vertex
      | utSetElementOf vertex visited   = (visited,          utSetSequence )
      | otherwise = (visited', utSetFromList (vertex: sequence): utSetSequence)
        where
         (visited', sequence)
            = deDepthFirstSearch relation
                          (utSetUnion visited (utSetSingleton vertex), [])
                          (relation vertex)





--------------------------------------------------------------------
--------------------------------------------------------------------
--------------------------------------------------------------------
-- Most of this set stuff isn't needed.


-- ====================================--
-- === set                          ===--
-- ====================================--

data Set e = MkSet [e]

-- ==========================================================--
--
unMkSet :: (Ord a) => Set a -> [a]

unMkSet (MkSet s) = s


-- ==========================================================--
--
utSetEmpty :: (Ord a) => Set a

utSetEmpty = MkSet []


-- ==========================================================--
--
utSetIsEmpty :: (Ord a) => Set a -> Bool

utSetIsEmpty (MkSet s) = s == []


-- ==========================================================--
--
utSetSingleton :: (Ord a) => a -> Set a

utSetSingleton x = MkSet [x]


-- ==========================================================--
--
utSetFromList :: (Ord a) => [a] -> Set a

utSetFromList x = (MkSet . rmdup . sort) x
                  where rmdup []       = []
                        rmdup [x]      = [x]
                        rmdup (x:y:xs) | x==y       = rmdup (y:xs)
                                       | otherwise  = x: rmdup (y:xs)


-- ==========================================================--
--
utSetToList :: (Ord a) => Set a -> [a]

utSetToList (MkSet xs) = xs



-- ==========================================================--
--
utSetUnion :: (Ord a) => Set a -> Set a -> Set a

utSetUnion (MkSet [])     (MkSet [])            = (MkSet [])
utSetUnion (MkSet [])     (MkSet (b:bs))        = (MkSet (b:bs))
utSetUnion (MkSet (a:as)) (MkSet [])            = (MkSet (a:as))
utSetUnion (MkSet (a:as)) (MkSet (b:bs))
    | a < b   = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet (b:bs)))))
    | a == b  = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet bs))))
    | a > b   = MkSet (b: (unMkSet (utSetUnion (MkSet (a:as)) (MkSet bs))))


-- ==========================================================--
--
utSetIntersection :: (Ord a) => Set a -> Set a -> Set a

utSetIntersection (MkSet [])     (MkSet [])     = (MkSet [])
utSetIntersection (MkSet [])     (MkSet (b:bs)) = (MkSet [])
utSetIntersection (MkSet (a:as)) (MkSet [])     = (MkSet [])
utSetIntersection (MkSet (a:as)) (MkSet (b:bs))
    | a < b   = utSetIntersection (MkSet as) (MkSet (b:bs))
    | a == b  = MkSet (a: (unMkSet (utSetIntersection (MkSet as) (MkSet bs))))
    | a > b   = utSetIntersection (MkSet (a:as)) (MkSet bs)


-- ==========================================================--
--
utSetSubtraction :: (Ord a) => Set a -> Set a -> Set a

utSetSubtraction (MkSet [])     (MkSet [])      = (MkSet [])
utSetSubtraction (MkSet [])     (MkSet (b:bs))  = (MkSet [])
utSetSubtraction (MkSet (a:as)) (MkSet [])      = (MkSet (a:as))
utSetSubtraction (MkSet (a:as)) (MkSet (b:bs))
    | a < b   = MkSet (a: (unMkSet (utSetSubtraction (MkSet as) (MkSet (b:bs)))))
    | a == b  = utSetSubtraction (MkSet as) (MkSet bs)
    | a > b   = utSetSubtraction (MkSet (a:as)) (MkSet bs)


-- ==========================================================--
--
utSetElementOf :: (Ord a) => a -> Set a -> Bool

utSetElementOf x (MkSet [])       = False
utSetElementOf x (MkSet (y:ys))   = x==y || (x>y && utSetElementOf x (MkSet ys))



-- ==========================================================--
--
utSetSubsetOf :: (Ord a) => Set a -> Set a -> Bool

utSetSubsetOf (MkSet [])        (MkSet bs) = True
utSetSubsetOf (MkSet (a:as))    (MkSet bs)
    = utSetElementOf a (MkSet bs) && utSetSubsetOf (MkSet as) (MkSet bs)


-- ==========================================================--
--
utSetUnionList :: (Ord a) => [Set a] -> Set a

utSetUnionList setList = foldl utSetUnion utSetEmpty setList