510eca61039ba461df017cf2e5fe5b60e552c5a5
1 module ShouldSucceed where
3 -- import TheUtils
4 import qualified Data.Set as Set
5 import Data.Set (Set)
6 import Data.List (partition )
8 data Digraph vertex = MkDigraph [vertex]
10 type Edge vertex = (vertex, vertex)
11 type Cycle vertex = [vertex]
13 mkDigraph = MkDigraph
15 stronglyConnComp :: Eq vertex => [Edge vertex] -> [vertex] -> [[vertex]]
16 stronglyConnComp es vs
17 = snd (span_tree (new_range reversed_edges)
18 ([],[])
19 ( snd (dfs (new_range es) ([],[]) vs) )
20 )
21 where
22 reversed_edges = map swap es
24 swap :: Edge v -> Edge v
25 swap (x,y) = (y, x)
27 new_range [] w = []
28 new_range ((x,y):xys) w
29 = if x==w
30 then (y : (new_range xys w))
31 else (new_range xys w)
33 span_tree r (vs,ns) [] = (vs,ns)
34 span_tree r (vs,ns) (x:xs)
35 | x `elem` vs = span_tree r (vs,ns) xs
36 | otherwise = span_tree r (vs',(x:ns'):ns) xs
37 where
38 (vs',ns') = dfs r (x:vs,[]) (r x)
40 dfs r (vs,ns) [] = (vs,ns)
41 dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
42 | otherwise = dfs r (vs',(x:ns')++ns) xs
43 where
44 (vs',ns') = dfs r (x:vs,[]) (r x)
47 isCyclic :: Eq vertex => [Edge vertex] -> [vertex] -> Bool
48 isCyclic edges [v] = (v,v) `elem` edges
49 isCyclic edges vs = True
52 topSort :: (Eq vertex) => [Edge vertex] -> [vertex]
53 -> MaybeErr [vertex] [[vertex]]
56 topSort edges vertices
57 = case cycles of
58 [] -> Succeeded [v | [v] <- singletons]
59 _ -> Failed cycles
60 where
61 sccs = stronglyConnComp edges vertices
62 (cycles, singletons) = partition (isCyclic edges) sccs
65 type FlattenedDependencyInfo vertex name code
66 = [(vertex, Set name, Set name, code)]
68 mkVertices :: FlattenedDependencyInfo vertex name code -> [vertex]
69 mkVertices info = [ vertex | (vertex,_,_,_) <- info]
71 mkEdges :: (Ord name) =>
72 [vertex]
73 -> FlattenedDependencyInfo vertex name code
74 -> [Edge vertex]
76 mkEdges vertices flat_info
77 = [ (source_vertex, target_vertex)
78 | (source_vertex, _, used_names, _) <- flat_info,
79 target_name <- Set.toList used_names,
80 target_vertex <- vertices_defining target_name flat_info
81 ]
82 where
83 vertices_defining name flat_info
84 = [ vertex | (vertex, names_defined, _, _) <- flat_info,
85 name `Set.member` names_defined
86 ]
88 lookupVertex :: (Eq vertex) =>
89 FlattenedDependencyInfo vertex name code
90 -> vertex
91 -> code
93 lookupVertex flat_info vertex