Version & licenses
Creative Commons License

naive_edmonds.ml

Guyslain Naves
  1. module type S =
  2. sig
  3. module M:Matching.S

  5. type kind =
  6. | Outer of M.P.G.edge option
  7. | Inner of M.P.G.edge
  8. | Away

  10. type forest

  12. val initial_forest : M.t -> forest
  13. val link : forest -> M.P.G.vertex -> kind
  14. val g : forest -> M.P.G.graph

  16. type augment_result =
  17. | Augmenting_Path of M.P.t
  18. | Blossom of M.P.t
  19. | Forest of forest

  21. val augment_forest : forest -> M.P.G.edge -> augment_result

  23. type edmonds_result =
  24. | Augment of M.P.t
  25. | Tutte of M.P.G.V.t

  27. val edmonds : M.t -> edmonds_result

  29. val maximum_matching: M.t -> (M.t * M.P.G.V.t)

  31. end

  33. module Make = functor (M : Matching.S) ->
  34. struct

  36. module M = M
  37. module G = M.P.G
  38. module P = M.P


  41. let equal u v = G.compare_vertex u v = 0


  44. type kind = (* for a matching M: *)
  45. | Outer of G.edge option (* Vertex at even distance from a root, covered by M or root *)
  46. | Inner of G.edge (* at odd distance, with father *)
  47. | Away (* vertex covered by M but not in the forest *)



  51. type forest =
  52. { matching : M.t;
  53. links : kind G.VMap.t;
  54. unscanned : G.E.t
  55. }

  57. let link forest v = try G.VMap.find v forest.links with Not_found -> Away


  60. let g forest = M.graph forest.matching (* helper to get the subjacent graph *)

  62. let rec get_path forest v path =
  63. match link forest v with
  64. | Outer None -> path
  65. | Outer (Some e)
  66. | Inner e -> get_path forest (G.opposite (g forest) e v) (P.add_last path e)
  67. | Away -> assert false

  69. let rec remove_common_suffix path1 path2 =
  70. if (P.is_empty path1) || (P.is_empty path2) ||
  71. (G.compare_edge (P.last_edge path1) (P.last_edge path2) <> 0)
  72. then (path1,path2)
  73. else remove_common_suffix (P.remove_last path1) (P.remove_last path2)

  75. (** computes the set of vertices covered by a path *)
  76. let vset_of_path p =
  77. P.fold (fun vset u e v -> G.V.add u vset) (G.V.singleton (P.last_vertex p)) p


  80. type augment_result = (* Possible result for adding an edge to an alternating forest *)
  81. | Augmenting_Path of P.t (* an augmenting path defined by its list of edges *)
  82. | Blossom of P.t (* a blossom, path starting at top-most vertex *)
  83. | Forest of forest (* a (possibly bigger) forest *)



  87. (* grows an alternating forest where [u] is outer, [v] is away, [u] and [v] are adjacent. *)
  88. let grow forest edge u v =
  89. match M.matched_to forest.matching v with
  90. | Some (e_in_m,w) ->
  91. Forest (
  92. { forest with
  93. links = G.VMap.add v (Inner edge) (G.VMap.add w (Outer (Some e_in_m)) forest.links);
  94. unscanned = G.E.remove edge (G.E.fold G.E.add (G.delta (g forest) w) forest.unscanned)
  95. })
  96. | None -> assert false (* if [v] is away, [v] must be matched *)


  99. (* function adding an [edge] to an alternating [forest] on matching [m]*)
  100. let augment_forest forest edge =
  101. let (u,v) = G.extremities (g forest) edge in
  102. let chain path1 edge path2 = P.rev_concat path1 (P.add_first edge path2) in
  103. if equal u v then Forest forest (* do not consider loops *)
  104. else match link forest u, link forest v with

  106. (* blossom if same tree, augmenting paths if distinct trees *)
  107. | Outer _, Outer _ ->
  108. let path1 = get_path forest u (P.empty (g forest) u) in
  109. let path2 = get_path forest v (P.empty (g forest) v) in
  110. if equal (P.last_vertex path1) (P.last_vertex path2)
  111. then (* Trees are the same: blossom *)
  112. let (subpath1, subpath2) = remove_common_suffix path1 path2 in
  113. Blossom (chain subpath1 edge subpath2)
  114. else (* distinct trees, we have an augmenting path *)
  115. Augmenting_Path (chain path1 edge path2)

  117. (* growing forest (two symmetric cases) *)
  118. | Outer _, Away -> grow forest edge u v
  119. | Away, Outer _ -> grow forest edge v u

  121. (* ignore: if one vertex is inner, or both are away (that last case cannot happen) *)
  122. | _ , Inner _
  123. | Inner _, _
  124. | Away, Away -> Forest { forest with unscanned = G.E.remove edge forest.unscanned }



  128. type edmonds_result =
  129. | Augment of P.t
  130. | Tutte of G.V.t



  134. (* initialize a forest given a matching. *)
  135. let initial_forest matching =
  136. let (links,to_scan) =
  137. G.V.fold (* uncovered vertices are root, others are away. Initialize the search. *)
  138. (fun v (l,r) -> (G.VMap.add v (Outer None) l,
  139. G.E.fold G.E.add (G.delta (M.graph matching) v) r)
  140. )
  141. (M.uncovered matching)
  142. (G.VMap.empty, G.E.empty)
  143. in
  144. { matching = matching;
  145. links = links;
  146. unscanned = to_scan
  147. }


  150. let cut_when f path =
  151. let rec iter path1 path2 =
  152. if (P.is_empty path2) || (f (P.first_vertex path2))
  153. then (path1, path2)
  154. else iter (P.add_last path1 (P.first_edge path2)) (P.remove_first path2)
  155. in iter (P.empty (P.graph path) (P.first_vertex path)) path


  158. (* functions to translate a path in G into a path in G' where this path also exists
  159. (as a sequence of incident edges) *)
  160. let translate_f graph path =
  161. P.fold (fun p _ e _ -> P.add_last p e) (P.empty graph (P.first_vertex path)) path
  162. let translate_b graph path =
  163. P.fold_backward (fun _ e _ p -> P.add_first e p) path (P.empty graph (P.last_vertex path))

  165. let uncontract_blossom forest m_c blossom path =
  166. (* path exists in the contracted graph, we want the result to be a path in the original graph *)
  167. let w = P.first_vertex blossom in
  168. let (p1,p2) = cut_when (fun u -> equal u w) path in
  169. if P.is_empty p2 then (* p does not contain w, as w cannot be an endpoint *)
  170. translate_f (g forest) path
  171. else
  172. let (path1,path2) = (translate_f (g forest) p1, translate_b (g forest) p2) in
  173. let (v1,v2) = (P.last_vertex path1, P.first_vertex path2) in
  174. let w' = if equal w v1 then v2 else v1 in
  175. let (c1,c2) = cut_when (fun u -> equal u w') blossom in
  176. match G.E.cardinal (P.edge_set c1) mod 2 = 0, equal w v1 with
  177. | false, true -> P.concat path1 (P.concat (P.reverse c2) path2)
  178. | false, false -> P.concat path1 (P.concat c2 path2)
  179. | true, true -> P.concat path1 (P.concat c1 path2)
  180. | true, false -> P.concat path1 (P.concat (P.reverse c1) path2)


  183. let rec edmonds_forest forest =
  184. if G.E.is_empty forest.unscanned

  186. then (* no more edges incident to outer to consider: matching is maximum *)
  187. Tutte (G.VMap.fold
  188. (fun v k vset -> match k with Inner _ -> G.V.add v vset | _ -> vset)
  189. forest.links G.V.empty
  190. )

  192. else (* there is an outer-something edge to check *)
  193. let edge = G.E.choose forest.unscanned in
  194. match augment_forest forest edge with
  195. | Augmenting_Path p -> Augment p
  196. | Blossom c ->
  197. begin
  198. let m_c = M.contract_blossom forest.matching c in
  199. match edmonds m_c with
  200. | Augment p -> Augment (uncontract_blossom forest m_c c p)
  201. | Tutte vset -> Tutte vset (* we take the same Tutte set *)

  203. end
  204. | Forest f -> edmonds_forest f
  205. and edmonds matching = edmonds_forest (initial_forest matching)


  208. let rec maximum_matching matching =
  209. match edmonds matching with
  210. | Tutte set -> (matching,set)
  211. | Augment p -> let matching = M.augment matching p in maximum_matching matching


  214. end