mirror of
https://github.com/ioacademy-jikim/debugging
synced 2025-06-08 00:16:11 +00:00
272 lines
8.5 KiB
Haskell
272 lines
8.5 KiB
Haskell
|
|
-- 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
|
|
|
|
|