-
Notifications
You must be signed in to change notification settings - Fork 0
/
edmonds.hs
209 lines (182 loc) · 7.12 KB
/
edmonds.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
import Data.List (minimumBy, partition, isPrefixOf)
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import System.Exit
import System.Environment
-- [Graph DATA STRUCTURE]
data Edge = Edge
{ src :: Integer
, dst :: Integer
, weight :: Float
} deriving (Eq, Show)
data Graph = Graph
{ vertices :: [Integer]
, edges :: [Edge]
, root :: Integer
} deriving (Eq, Show)
type Vertex = Integer
type Path = [Edge]
-- [PARSING & REPRESENTATION]
-- Given a string representation of an Edge, parse this line
readEdgeLine :: String -> Edge
readEdgeLine str = case words str of
[s,d,w] -> (Edge (read s) (read d) (read w))
_ -> error "Invalid edge line"
-- Given a string representation of (#vertices, #edges, root), parse this line
readHeaderLine :: String -> (Integer, Integer, Integer)
readHeaderLine l = case words l of
[a,b,c] -> ((read a), (read b), (read c))
_ -> error "Invalid header line"
-- helper function: dispatch line parsing
fromString' :: [String] -> Graph
fromString' [] = (Graph [] [] 0)
fromString' (l:ls) =
case readHeaderLine l of
(nrV, _, r) -> (Graph [1,2..nrV] es r)
where
es = map (readEdgeLine) ls
-- Given string representation of a graph, parse lines to retrieve graph
fromString :: String -> Graph
fromString str = fromString' (filter (\ l -> noHash l && noBLine l) (lines str))
where
noHash = (not . (isPrefixOf "#"))
noBLine = (not . (isPrefixOf "b "))
-- Given a set of Edges, represent edges as string
showEdges :: [Edge] -> String -> String
showEdges [] _ = ""
showEdges (e:es) prefix = prefix ++ (show $ src e) ++ " " ++ (show $ dst e) ++
" " ++ (show $ weight e) ++ "\n" ++ (showEdges es prefix)
-- Given a graph, represent as string
toString :: Graph -> String
toString (Graph vs es r) =
(show $ maxVertex vs) ++ " " ++
(show $ length es) ++ " " ++
(show r) ++ " " ++
(show $ totalGraphWeight) ++ "\n" ++
(showEdges es "")
where
maxVertex (v':vs') = if v' > maxVertex vs' then v' else maxVertex vs'
maxVertex [] = 0
totalGraphWeight = sum $ map weight es
-- [AUXILIARY FUNCTIONS]
-- Given a set of edges, determine the smallest weight occuring in this set
minWeightEdge :: [Edge] -> Edge
minWeightEdge [] = error "Missing an edge"
minWeightEdge es = minimumBy (comparing weight) es
-- Given a path, traverse this path backwards until given vertex is found
-- Returns a subset of the provided path
backTraversePath :: (Path, Vertex) -> Path
backTraversePath ([], _) = []
backTraversePath ((e:p), v) =
if src e == v
then (e:p)
else (e:(backTraversePath (p, v)))
-- Given a path, traverse it until we hit some vertex already visited
-- Returns the path traversed and the vertex hit again
traversePath :: Path -> Path -> Set Vertex -> (Path, Vertex)
traversePath [] _ _ = ([], -1)
traversePath (e:p) path visited =
if Set.member (src e) visited
then (e:path, src e)
else traversePath p (e:path) (Set.insert (src e) visited)
-- Given a path, retrieve some cycle traversed inside
getCycle :: Path -> Path
getCycle [] = []
getCycle p@(e:_) =
backTraversePath $ traversePath p [] (Set.fromList [dst e])
-- Given a set of edges, a path traversed so far and an initial vertex
-- Return set of paths leading to dead ends or cycles (subsets of edges)
dfs :: [Edge] -> Path -> Vertex -> [Path]
dfs es base r =
if null newEdges
then [base]
else
[e:base | e <- deadEdges] ++
(concat [(dfs es (e:base) (dst e)) | e <- nextEdges])
where
srcs = Set.fromList $ map src base
dsts = Set.fromList $ map dst base
reachedVertices = Set.union srcs dsts
start = if null base then r else (dst $ head base)
newEdges = filter (\ e -> (src e) == start && notElem e base) es
revisit e = Set.member (dst e) reachedVertices
(deadEdges, nextEdges) = partition revisit newEdges
-- [EDMONDS HELPERS]
-- Given arbitrary edges (s, d, w), return edges with unique (s, d) and w minimized
removeMultiEdges :: [Edge] -> [Edge]
removeMultiEdges [] = []
removeMultiEdges gedges@(e:_) =
minEdge:(removeMultiEdges different)
where
(alike, different) = partition (\ e' -> (src e, dst e) == (src e', dst e')) gedges
minEdge = minWeightEdge alike
-- Given a set of edges (s, d, w), retrieve a subset
-- such that d is unique and w minimized
cheapestEdges :: [Edge] -> [Edge]
cheapestEdges [] = []
cheapestEdges gedges@(e:_) =
cheapestEdge:(cheapestEdges different)
where
(alike, different) = partition ((== (dst e)) . dst) gedges
cheapestEdge = minWeightEdge alike
-- [EDMONDS BRANCHING ALGORITHM]
-- map edge to new problem according to EBA
edmondsEdge :: Edge -> [Edge] -> Set Vertex -> Vertex -> Edge
edmondsEdge edge@(Edge u v w) es cycleVertices contractVertex
| not uInC && vInC = (Edge u contractVertex (w - cheapW))
| uInC && not vInC = (Edge contractVertex v w)
| otherwise = edge
where
cheapW = minimum $ map weight $ filter ((== v) . dst) es
uInC = Set.member u cycleVertices
vInC = Set.member v cycleVertices
-- Given a graph and a cycle, retrieve a problem with a contracted vertex.
-- Call recursion and decontract result. Return this result solving the original problem.
edmondsCycle :: Graph -> Path -> Graph
edmondsCycle g' cy =
(Graph (vertices g') (concat [(filter (/= inCycleUv) cycleEdges), map unmapEdge (edges recurse)]) (root g'))
where
newVertex = (maximum $ vertices g') + 1
cycleVertices = Set.insert (src $ head cy) $ Set.fromList $ map dst cy
inCycle e = (Set.member (src e) cycleVertices && Set.member (dst e) cycleVertices)
(cycleEdges, otherEdges) = partition inCycle (edges g')
mapEdge e = edmondsEdge e (edges g') cycleVertices newVertex
associatedEdges = [(e, mapEdge e) | e <- otherEdges]
recurse = edmonds (Graph (newVertex:(vertices g')) (map snd associatedEdges) (root g'))
unmapEdge e = fst $ head $ filter ((== e) . snd) associatedEdges
uvc = head $ filter ((== newVertex) . dst) (edges recurse)
uv = unmapEdge uvc
inCycleUv = head $ filter ((== (dst uv)) . dst) cy
-- High-level call for EBA. Given a graph, return a min-weight arborescence
-- (GHCI example following)
-- :load *edmonds
-- let vs = [1,2,3,4,5,6]
-- let es = [(Edge 1 4 10.0), (Edge 1 2 10.0), (Edge 4 5 2.0), (Edge 1 3 2.0), (Edge 5 2 2.0), (Edge 3 4 4.0), (Edge 4 6 4.0), (Edge 2 3 1.0), (Edge 2 6 8.0)]
-- let arb = edmonds (Graph vs es 1)
-- arb
edmonds :: Graph -> Graph
edmonds g@(Graph vs es r) =
if null cycles
then (Graph vs cheapEdges r)
else (edmondsCycle g (head cycles))
where
notToRoot = filter ((/= r) . dst) es
reducedEdges = (removeMultiEdges notToRoot)
cheapEdges = (cheapestEdges reducedEdges)
paths = filter (not . null) $ concat $ map (\ v -> (dfs cheapEdges [] v)) vs
cycles = filter (not . null) (map getCycle paths)
-- [MAIN ROUTINE]
main :: IO ()
main = do
args <- getArgs
let argc = length args
let filepath = head args
if argc == 1
then do
putStrLn
=<< return . toString . edmonds . fromString
=<< readFile filepath
else do
putStrLn "usage: ./edmonds <di.graph>"
exitFailure