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
18module Main where
19
20import System
21import List ( sort, nub )
22
23usage :: IO ()
24usage = putStrLn "usage: dottoscc <name_of_file.dot>"
25
26main :: IO ()
27main = do args <- getArgs
28          if length args /= 1
29           then usage
30           else imain (head args)
31
32imain :: String -> IO ()
33imain 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
53read_dot_file :: String{-filename-} -> IO [(String,String)]
54read_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
71gen_sccs :: [(String,String)] -> [[String]]
72gen_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--
90deScc :: (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
96deScc ins outs
97   = spanning . depthFirst
98     where depthFirst = snd . deDepthFirstSearch outs (utSetEmpty, [])
99           spanning   = snd . deSpanningSearch   ins  (utSetEmpty, [])
100
101
102-- =========================================================--
103--
104deDepthFirstSearch :: (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
111deDepthFirstSearch
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--
126deSpanningSearch   :: (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
133deSpanningSearch
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
159data Set e = MkSet [e]
160
161-- ==========================================================--
162--
163unMkSet :: (Ord a) => Set a -> [a]
164
165unMkSet (MkSet s) = s
166
167
168-- ==========================================================--
169--
170utSetEmpty :: (Ord a) => Set a
171
172utSetEmpty = MkSet []
173
174
175-- ==========================================================--
176--
177utSetIsEmpty :: (Ord a) => Set a -> Bool
178
179utSetIsEmpty (MkSet s) = s == []
180
181
182-- ==========================================================--
183--
184utSetSingleton :: (Ord a) => a -> Set a
185
186utSetSingleton x = MkSet [x]
187
188
189-- ==========================================================--
190--
191utSetFromList :: (Ord a) => [a] -> Set a
192
193utSetFromList 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--
202utSetToList :: (Ord a) => Set a -> [a]
203
204utSetToList (MkSet xs) = xs
205
206
207
208-- ==========================================================--
209--
210utSetUnion :: (Ord a) => Set a -> Set a -> Set a
211
212utSetUnion (MkSet [])     (MkSet [])            = (MkSet [])
213utSetUnion (MkSet [])     (MkSet (b:bs))        = (MkSet (b:bs))
214utSetUnion (MkSet (a:as)) (MkSet [])            = (MkSet (a:as))
215utSetUnion (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--
223utSetIntersection :: (Ord a) => Set a -> Set a -> Set a
224
225utSetIntersection (MkSet [])     (MkSet [])     = (MkSet [])
226utSetIntersection (MkSet [])     (MkSet (b:bs)) = (MkSet [])
227utSetIntersection (MkSet (a:as)) (MkSet [])     = (MkSet [])
228utSetIntersection (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--
236utSetSubtraction :: (Ord a) => Set a -> Set a -> Set a
237
238utSetSubtraction (MkSet [])     (MkSet [])      = (MkSet [])
239utSetSubtraction (MkSet [])     (MkSet (b:bs))  = (MkSet [])
240utSetSubtraction (MkSet (a:as)) (MkSet [])      = (MkSet (a:as))
241utSetSubtraction (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--
249utSetElementOf :: (Ord a) => a -> Set a -> Bool
250
251utSetElementOf x (MkSet [])       = False
252utSetElementOf x (MkSet (y:ys))   = x==y || (x>y && utSetElementOf x (MkSet ys))
253
254
255
256-- ==========================================================--
257--
258utSetSubsetOf :: (Ord a) => Set a -> Set a -> Bool
259
260utSetSubsetOf (MkSet [])        (MkSet bs) = True
261utSetSubsetOf (MkSet (a:as))    (MkSet bs)
262    = utSetElementOf a (MkSet bs) && utSetSubsetOf (MkSet as) (MkSet bs)
263
264
265-- ==========================================================--
266--
267utSetUnionList :: (Ord a) => [Set a] -> Set a
268
269utSetUnionList setList = foldl utSetUnion utSetEmpty setList
270
271
272