15.4.766  src/lib/graph/graph-breadth-first-search.pkg

# graph-breadth-first-search.pkg
# Breadth first search.
#
# -- Allen Leung

# Compiled by:
#     src/lib/graph/graphs.lib



###               "Piloting on the Mississippi River was not work to me;
###                it was play -- delightful play, vigorous play,
###                adventurous play -- and I loved it ..."
###
###                                    -- Mark Twain in Eruption



stipulate
    package odg =  oop_digraph;                                                 # oop_digraph           is from   src/lib/graph/oop-digraph.pkg
    package bts =  bit_set;                                                     # bit_set                       is from   src/lib/graph/bit-set.pkg
    package rwv =  rw_vector;                                                   # rw_vector                     is from   src/lib/std/src/rw-vector.pkg
herein

    package   graph_breadth_first_search
    : (weak)  Graph_Breadth_First_Search                                        # Graph_Breadth_First_Search    is from   src/lib/graph/graph-breadth-first-search.api
    {



        # Breadth first search
        #
        fun bfs (odg::DIGRAPH ggg) f g roots
            =
            {   visited = bts::create (ggg.capacity ());

                fun visit ([],[])    =>  ();
                    visit([], r)     =>  visit (reverse r,[]);
                    visit (n ! l, r) =>  { f n;   visit_succ (ggg.out_edges n, l, r); };
                end 

                also
                fun visit_succ ([], l, r)
                        =>
                        visit (l, r);

                    visit_succ((e as (i, j, _)) ! es, l, r)
                        =>
                        if (bts::mark_and_test (visited, j))
                            #
                            visit_succ (es, l, r);
                        else
                            g e;
                            visit_succ (es, l, j ! r);
                        fi;
                end 

                also
                fun visit_roots ([], l, r)
                        =>
                        visit (l, r);

                    visit_roots (n ! ns, l, r)
                        => 
                        if (bts::mark_and_test (visited, n))
                            #   
                            visit_roots (ns, l, r);
                        else
                            f n;
                            visit_roots (ns, l, n ! r);
                        fi;
                end;

                visit_roots (roots,[],[]);
            };

        fun bfsdist (odg::DIGRAPH ggg) roots
            =
            dist
            where
                nnn = ggg.capacity ();

                dist = rwv::make_rw_vector (nnn,-1);

                fun visit ([],       []) =>   ();
                    visit([],       rrr) =>   visit (reverse rrr,[]);
                    visit (n ! lll, rrr) =>   visit_succ (ggg.out_edges n, lll, rrr);
                end 

                also
                fun visit_succ ([], lll, rrr)
                        =>
                        visit (lll, rrr);

                    visit_succ((e as (i, j, _)) ! es, lll, rrr)
                        =>
                        if  (rwv::get (dist, j) >= 0)
                            #
                            visit_succ (es, lll, rrr);
                        else
                            rwv::set (dist, j, rwv::get (dist, i)+1);
                            visit_succ (es, lll, j ! rrr);
                        fi;
                end 

                also
                fun visit_roots ([], lll, rrr)
                        =>
                        visit (lll, rrr);

                    visit_roots (n ! ns, lll, rrr)
                        => 
                        if  (rwv::get (dist, n) >= 0)
                        #
                            visit_roots (ns, lll, rrr);
                        else 
                            rwv::set (dist, n, 0);
                            visit_roots (ns, lll, n ! rrr);
                        fi;
                end;

                visit_roots (roots,[],[]);
            end;
    };
end;