auxprogs/DotToScc.hs

   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