PreviousUpNext

15.4.757  src/lib/graph/bipartite-matching.pkg

#  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.lib


stipulate
    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.pkg
herein


    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
                            (fn (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
                                (fn ((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
                            (fn 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;



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext