1 2 -- A program for extracting strongly connected components from a .dot 3 -- file created by auxprogs/gen-mdg. 4 5 -- How to use: one of the following: 6 7 -- compile to an exe: ghc -o dottoscc DotToScc.hs 8 -- and then ./dottoscc name_of_file.dot 9 10 -- or interpret with runhugs: 11 -- runhugs DotToScc.hs name_of_file.dot 12 13 -- or run within hugs: 14 -- hugs DotToScc.hs 15 -- Main> imain "name_of_file.dot" 16 17 18 module Main where 19 20 import System 21 import List ( sort, nub ) 22 23 usage :: IO () 24 usage = putStrLn "usage: dottoscc <name_of_file.dot>" 25 26 main :: IO () 27 main = do args <- getArgs 28 if length args /= 1 29 then usage 30 else imain (head args) 31 32 imain :: String -> IO () 33 imain dot_file_name 34 = do edges <- read_dot_file dot_file_name 35 let sccs = gen_sccs edges 36 let pretty = showPrettily sccs 37 putStrLn pretty 38 where 39 showPrettily :: [[String]] -> String 40 showPrettily = unlines . concatMap showScc 41 42 showScc elems 43 = let n = length elems 44 in 45 [""] 46 ++ (if n > 1 then [" -- " 47 ++ show n ++ " modules in cycle"] 48 else []) 49 ++ map (" " ++) elems 50 51 52 -- Read a .dot file and return a list of edges 53 read_dot_file :: String{-filename-} -> IO [(String,String)] 54 read_dot_file dot_file_name 55 = do bytes <- readFile dot_file_name 56 let linez = lines bytes 57 let edges = [(s,d) | Just (s,d) <- map maybe_mk_edge linez] 58 return edges 59 where 60 -- identify lines of the form "text1 -> text2" and return 61 -- text1 and text2 62 maybe_mk_edge :: String -> Maybe (String, String) 63 maybe_mk_edge str 64 = case words str of 65 [text1, "->", text2] -> Just (text1, text2) 66 other -> Nothing 67 68 69 -- Take the list of edges and return a topologically sorted list of 70 -- sccs 71 gen_sccs :: [(String,String)] -> [[String]] 72 gen_sccs raw_edges 73 = let clean_edges = sort (nub raw_edges) 74 nodes = nub (concatMap (\(s,d) -> [s,d]) clean_edges) 75 ins v = [u | (u,w) <- clean_edges, v==w] 76 outs v = [w | (u,w) <- clean_edges, v==u] 77 components = map (sort.utSetToList) (deScc ins outs nodes) 78 in 79 components 80 81 82 -------------------------------------------------------------------- 83 -------------------------------------------------------------------- 84 -------------------------------------------------------------------- 85 86 -- Graph-theoretic stuff that does the interesting stuff. 87 88 -- ==========================================================-- 89 -- 90 deScc :: (Ord a) => 91 (a -> [a]) -> -- The "ins" map 92 (a -> [a]) -> -- The "outs" map 93 [a] -> -- The root vertices 94 [Set a] -- The topologically sorted components 95 96 deScc ins outs 97 = spanning . depthFirst 98 where depthFirst = snd . deDepthFirstSearch outs (utSetEmpty, []) 99 spanning = snd . deSpanningSearch ins (utSetEmpty, []) 100 101 102 -- =========================================================-- 103 -- 104 deDepthFirstSearch :: (Ord a) => 105 (a -> [a]) -> -- The map, 106 (Set a, [a]) -> -- state: visited set, 107 -- current sequence of vertices 108 [a] -> -- input vertices sequence 109 (Set a, [a]) -- final state 110 111 deDepthFirstSearch 112 = foldl . search 113 where 114 search relation (visited, sequence) vertex 115 | utSetElementOf vertex visited = (visited, sequence ) 116 | otherwise = (visited', vertex: sequence') 117 where 118 (visited', sequence') 119 = deDepthFirstSearch relation 120 (utSetUnion visited (utSetSingleton vertex), sequence) 121 (relation vertex) 122 123 124 -- ==========================================================-- 125 -- 126 deSpanningSearch :: (Ord a) => 127 (a -> [a]) -> -- The map 128 (Set a, [Set a]) -> -- Current state: visited set, 129 -- current sequence of vertice sets 130 [a] -> -- Input sequence of vertices 131 (Set a, [Set a]) -- Final state 132 133 deSpanningSearch 134 = foldl . search 135 where 136 search relation (visited, utSetSequence) vertex 137 | utSetElementOf vertex visited = (visited, utSetSequence ) 138 | otherwise = (visited', utSetFromList (vertex: sequence): utSetSequence) 139 where 140 (visited', sequence) 141 = deDepthFirstSearch relation 142 (utSetUnion visited (utSetSingleton vertex), []) 143 (relation vertex) 144 145 146 147 148 149 -------------------------------------------------------------------- 150 -------------------------------------------------------------------- 151 -------------------------------------------------------------------- 152 -- Most of this set stuff isn't needed. 153 154 155 -- ====================================-- 156 -- === set ===-- 157 -- ====================================-- 158 159 data Set e = MkSet [e] 160 161 -- ==========================================================-- 162 -- 163 unMkSet :: (Ord a) => Set a -> [a] 164 165 unMkSet (MkSet s) = s 166 167 168 -- ==========================================================-- 169 -- 170 utSetEmpty :: (Ord a) => Set a 171 172 utSetEmpty = MkSet [] 173 174 175 -- ==========================================================-- 176 -- 177 utSetIsEmpty :: (Ord a) => Set a -> Bool 178 179 utSetIsEmpty (MkSet s) = s == [] 180 181 182 -- ==========================================================-- 183 -- 184 utSetSingleton :: (Ord a) => a -> Set a 185 186 utSetSingleton x = MkSet [x] 187 188 189 -- ==========================================================-- 190 -- 191 utSetFromList :: (Ord a) => [a] -> Set a 192 193 utSetFromList x = (MkSet . rmdup . sort) x 194 where rmdup [] = [] 195 rmdup [x] = [x] 196 rmdup (x:y:xs) | x==y = rmdup (y:xs) 197 | otherwise = x: rmdup (y:xs) 198 199 200 -- ==========================================================-- 201 -- 202 utSetToList :: (Ord a) => Set a -> [a] 203 204 utSetToList (MkSet xs) = xs 205 206 207 208 -- ==========================================================-- 209 -- 210 utSetUnion :: (Ord a) => Set a -> Set a -> Set a 211 212 utSetUnion (MkSet []) (MkSet []) = (MkSet []) 213 utSetUnion (MkSet []) (MkSet (b:bs)) = (MkSet (b:bs)) 214 utSetUnion (MkSet (a:as)) (MkSet []) = (MkSet (a:as)) 215 utSetUnion (MkSet (a:as)) (MkSet (b:bs)) 216 | a < b = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet (b:bs))))) 217 | a == b = MkSet (a: (unMkSet (utSetUnion (MkSet as) (MkSet bs)))) 218 | a > b = MkSet (b: (unMkSet (utSetUnion (MkSet (a:as)) (MkSet bs)))) 219 220 221 -- ==========================================================-- 222 -- 223 utSetIntersection :: (Ord a) => Set a -> Set a -> Set a 224 225 utSetIntersection (MkSet []) (MkSet []) = (MkSet []) 226 utSetIntersection (MkSet []) (MkSet (b:bs)) = (MkSet []) 227 utSetIntersection (MkSet (a:as)) (MkSet []) = (MkSet []) 228 utSetIntersection (MkSet (a:as)) (MkSet (b:bs)) 229 | a < b = utSetIntersection (MkSet as) (MkSet (b:bs)) 230 | a == b = MkSet (a: (unMkSet (utSetIntersection (MkSet as) (MkSet bs)))) 231 | a > b = utSetIntersection (MkSet (a:as)) (MkSet bs) 232 233 234 -- ==========================================================-- 235 -- 236 utSetSubtraction :: (Ord a) => Set a -> Set a -> Set a 237 238 utSetSubtraction (MkSet []) (MkSet []) = (MkSet []) 239 utSetSubtraction (MkSet []) (MkSet (b:bs)) = (MkSet []) 240 utSetSubtraction (MkSet (a:as)) (MkSet []) = (MkSet (a:as)) 241 utSetSubtraction (MkSet (a:as)) (MkSet (b:bs)) 242 | a < b = MkSet (a: (unMkSet (utSetSubtraction (MkSet as) (MkSet (b:bs))))) 243 | a == b = utSetSubtraction (MkSet as) (MkSet bs) 244 | a > b = utSetSubtraction (MkSet (a:as)) (MkSet bs) 245 246 247 -- ==========================================================-- 248 -- 249 utSetElementOf :: (Ord a) => a -> Set a -> Bool 250 251 utSetElementOf x (MkSet []) = False 252 utSetElementOf x (MkSet (y:ys)) = x==y || (x>y && utSetElementOf x (MkSet ys)) 253 254 255 256 -- ==========================================================-- 257 -- 258 utSetSubsetOf :: (Ord a) => Set a -> Set a -> Bool 259 260 utSetSubsetOf (MkSet []) (MkSet bs) = True 261 utSetSubsetOf (MkSet (a:as)) (MkSet bs) 262 = utSetElementOf a (MkSet bs) && utSetSubsetOf (MkSet as) (MkSet bs) 263 264 265 -- ==========================================================-- 266 -- 267 utSetUnionList :: (Ord a) => [Set a] -> Set a 268 269 utSetUnionList setList = foldl utSetUnion utSetEmpty setList 270 271 272
