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 (file)
index 0000000..a94434f
--- /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 <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
+
+