Module : MaxMatching
Description : Maximum cardinality bipartite matching
Copyright : © 2012 Stefan Klinger
License : GNU AGPL 3
Maintainer : Stefan Klinger
Stability : unstable
Find a maximum cardinality matching on a bipartite graph, using an
augmenting path algorithm.
--------------------------------------------------------------------------------
> module MaxMatching ( matching ) where
> import qualified Data.Map as M
> import qualified Data.Set as S
Basics
------
A bipartite graph has “left” and “right” nodes, we assume the types α
and β for them. Each edge then is an (α,β) pair, i.e., there are no
edges between nodes on the same side.
A “matching” is a subset of the edges, so that each node is incident to
at most one edge that is in the matching. We are looking for a matching
that contains as many edges as possible. With respect to a fixed
matching, an edge is called “matched” iff it is part of the matching. A
node is called “free” iff it is not incident to any matched edge.
An “augmenting path” contains no cycles, starts at a free α-node,
terminates at a free β-node, and strictly alternately traverses
unmatched and matched edges. Exactly the first and last node of an
augmenting path are free, the inner nodes are not.
The algo is based on the idea of repeatedly finding an augmenting path
with respect to a current matching, starting from the empty matching,
similar to Hopcroft–Karp. When an augmenting path is found, all of its
matched edges become unmatched, and vice versa, thus incrementing the
matching's size by one.
Implementation
--------------
The input graph is of type `Set (α,β)` which implies being bipartite and
simple. It also denies isolated nodes, but they cannot be matched
anyways.
When looking for an augmenting path, travelling “right” to a β-node, is
always via an unmatched edge, and travelling “left” to an α-node is
always via a matched edge. Since a β-node can have at most one matched
edge, it is sufficient to store the matching in a map of type `Map β α`,
i.e., backwards. The invariant is being a proper matching, i.e., being
injective.
> matching :: (Ord a, Ord b) => S.Set (a,b) -> M.Map b a
> matching g = opt (M.keys fwd, []) fwd M.empty
> where
Travelling right, we can choose any unmatched edge. To this end, the
entire graph is maintained as a “forward mapping” of type `Map α [β]`,
listing all β-nodes adjacent to an α-node.
> fwd = foldr (\(x,y) -> M.insertWith (++) x [y]) M.empty $ S.toList g
Given two lists of (initially all) free and (initially no) failed
α-nodes, the forward mapping, and an (initially empty) matching, the
optimizer function…
> opt :: (Ord a, Ord b) => ([a],[a]) -> M.Map a [b] -> M.Map b a -> M.Map b a
…repeatedly calls `right` on each free α-node, i.e., starts a path
search from `x`, hoping to get a better matching back.
If no better matching is found, then `x` is is set aside as a failed
node for reconsideration in later iterations. Otherwise, `x` is part of
the matching and removed from the list of free nodes. Also, the failed
nodes set aside previously are appended to the free nodes, since they
may lead to an augmenting path with the new matching.
> opt (x:free,failed) fwd mat
> = either (flip (opt (free,x:failed)) mat) (opt (free++failed,[]) fwd)
> $ right fwd [] x
> where
`right` returns either `Right` a better matching if an augmenting path
starting at `x` was found, or `Left` a reduced forward mapping
otherwise. The rationale is, that if no augmenting path was found, then
all α-nodes traversed during this run of `opt` can be omitted from
further searches until the matching is modified: They cannot become part
of any augmenting path.
Note, that `opt` always applies `right` to a free node, and the complete
original forward mapping, while `left` always applies `right` to a
non-free node and a reduced forward mapping. The argument `path`
accumulates the augmenting path.
The remaining forward mapping `rem` yields a list of β-nodes that can be
reached from `x`. We try to walk left from these, without ever going
back to `x`, which is why it's deleted from `rem`.
> right rem path x
> = maybe (Left rem) (left $ M.delete x rem) $ M.lookup x rem
> where
> left rem [] = Left rem
> left rem (y:ys)
> = (\ e n j -> maybe n j e) -- for better readability
For the first reacheble β-node `y`, we check wheter it is free, i.e.,
not in the matching `mat`.
> (M.lookup y mat)
If so, then `path'` is used to augment the matching. We need to augment
anyways, so we can do this here and return a new matching instead of
returning a path and augment later. Also, we don't collect multiple
paths before augmentation, because that would require to protect the
still-free β-node `y` from being used in another augmenting path. Enjoy
this:
> (Right $ foldr (uncurry $ flip M.insert) mat path')
However, if `y` is not free, we try to continue where the matched edge
leads to, descending `right` from there. If that fails, we try one of
the remaining `ys`, recursing `left`.
> (either (flip left ys) Right . right rem path')
> where
The new path is made up of the currently last edge (x,y) and what we
have seen on the DFS so far,
> path' = (x,y):path
Finally, when no more improvements are found for any potential left
node, i.e., all free α-nodes failed, then the current matching is
returned.
> opt ([],failed) fwd mat = mat
================================================================================