-- 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 " 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