From: Julian Seward Date: Sat, 25 Jun 2005 14:42:34 +0000 (+0000) Subject: A small program to read .dot files created by auxprogs/gen-mdg and X-Git-Tag: svn/VALGRIND_3_0_0~302 X-Git-Url: http://git.ipfire.org/gitweb.cgi?a=commitdiff_plain;h=be47f84a2e7ce1962b78683a124dfb74a0b514ea;p=thirdparty%2Fvalgrind.git A small program to read .dot files created by auxprogs/gen-mdg and compute the strongly connected components in them. git-svn-id: svn://svn.valgrind.org/valgrind/trunk@4016 --- diff --git a/auxprogs/DotToScc.hs b/auxprogs/DotToScc.hs new file mode 100644 index 0000000000..a94434fd7b --- /dev/null +++ b/auxprogs/DotToScc.hs @@ -0,0 +1,271 @@ + +-- 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 + +