# bipartite-matching.pkg
# This module implenents max cardinality matching.
# Each edge of the matching are folded together with a user supplied
# function.
#
# Note: The graph must be a bipartite graph.
# Running time is O(|V||E|)
# From the book by Aho, Hopcroft, Ullman
#
# -- Allen Leung
# Compiled by:
# src/lib/graph/graphs.libstipulate
package odg = oop_digraph; # oop_digraph is from src/lib/graph/oop-digraph.pkg package rwv = rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkgherein
package bipartite_matching
: (weak) Bipartite_Matching # Bipartite_Matching is from src/lib/graph/bipartite-matching.api {
fun matching (odg::DIGRAPH ggg) f x
=
{ nnn = ggg.capacity ();
mate = rwv::make_rw_vector (nnn,-1);
fun married i
=
rwv::get (mate, i) >= 0;
fun match (i, j)
=
{ # print("match "$int::to_string i$" "$int::to_string j$"\n");
rwv::set (mate, i, j); rwv::set (mate, j, i);
};
# Simple greedy algorithm to find an initial matching
fun compute_initial_matching ()
=
{ fun edges [] => ();
edges((i, j, _) ! es)
=>
if (i == j or married j ) edges es;
else match (i, j); fi;
end;
ggg.forall_nodes
(\\ (i, _)
=
if (not (married i))
edges (ggg.out_edges i);
fi
);
};
visited = rwv::make_rw_vector (nnn,-1);
prior = rwv::make_rw_vector (nnn,-1); # Breadth-first-search spanning tree
# Build an augmenting path graph using breadth-first-search.
# Invariants:
# (1) the neighbors of an unmarried vertex must all be married
# (2) unmarried vertices on the queue are the roots of BFS
# Returns TRUE iff a new augmenting path is found
#
fun build_augmenting_path (phase, unmarried)
=
{ # print("Phase "$int::to_string phase$"\n");
fun neighbors u = ggg.next u @ ggg.prior u;
fun marked u = rwv::get (visited, u) == phase;
fun mark u = rwv::set (visited, u, phase);
fun edge (u, v) = rwv::set (prior, v, u);
fun bfs_roots [] => FALSE;
bfs_roots (r ! roots)
=>
if (marked r or married r)
bfs_roots roots;
else
mark r;
bfs_even (r, neighbors r,[],[], roots);
fi;
end
also
fun bfs ([],[], roots) => bfs_roots roots;
bfs ([], r, roots) => bfs (reverse r,[], roots);
bfs (u ! l, r, roots) => bfs_odd (u, neighbors u, l, r, roots);
end
# u is married, find an unmatched neighbor v
also
fun bfs_odd (u,[], l, r, roots)
=>
bfs (l, r, roots);
bfs_odd (u, v ! vs, l, r, roots)
=>
if (marked v)
bfs_odd (u, vs, l, r, roots);
else
w = rwv::get (mate, v);
if (u == w)
bfs_odd (u, vs, l, r, roots);
else
if (w < 0)
edge (u, v);
path v; # v is unmarried!
else
mark v;
mark w;
edge (u, v);
bfs_odd (u, vs, l, w ! r, roots);
fi;
fi;
fi;
end
# u is unmarried, all neighbors vs are married
also
fun bfs_even (u,[], l, r, roots)
=>
bfs (l, r, roots);
bfs_even (u, v ! vs, l, r, roots)
=>
if (marked v)
bfs_even (u, vs, l, r, roots);
else
w = rwv::get (mate, v);
mark v;
mark w;
edge (u, v);
bfs_even (u, vs, l, w ! r, roots);
fi;
end
# Found a path, backtrack and update the matching edges:
also
fun path -1 => TRUE;
path u
=>
{ v = rwv::get (prior, u);
w = rwv::get (mate, v);
match (u, v);
path w;
};
end;
bfs_roots unmarried;
};
# Main loop
#
fun iterate ()
=
loop 0
where
unmarried
=
list::fold_backward
(\\ ((u, _), l) = if (married u ) l; else u ! l;fi)
[]
(ggg.nodes ());
fun loop phase
=
if (build_augmenting_path (phase, unmarried))
loop (phase+1);
fi;
end;
# Fold result; make sure parallel
# and opposite edges are handled:
#
fun fold (f, x)
=
{ m = REF x;
k = REF 0;
ggg.forall_edges
(\\ e as (i, j, _)
=
if (rwv::get (mate, i) == j)
#
rwv::set (mate, i,-1);
rwv::set (mate, j,-1);
k := *k + 1;
m := f (e,*m);
fi
);
(*m,*k);
};
compute_initial_matching ();
iterate ();
fold (f, x);
};
};
end;