15.4.765  src/lib/graph/graph-bcc.pkg

#
#  Tarjan's algorithm for computing biconnected components.
#
#  -- Allen Leung

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

###            "Who is not satisfied with himself will grow;
###             who is not sure of his own correctness will learn many things."
###
###                                      -- Chinese proverb


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  graph_biconnected_components
    : (weak) Graph_Biconnected_Components                                       # Graph_Biconnected_Components  is from   src/lib/graph/graph-bcc.api
    {


        fun biconnected_components (odg::DIGRAPH ggg) process sss
            =
            {   nnn      = ggg.capacity ();

                dfsnum = rwv::make_rw_vector (nnn, -1);
                low    = rwv::make_rw_vector (nnn, -1);

                fun dfs_roots ([], stack, n, sss)
                        =>
                        (stack, n, sss);

                    dfs_roots((r, _) ! roots, stack, n, sss)
                        => 
                        if  (rwv::get (dfsnum, r) < 0)

                             my (stack, n, sss)
                                 =
                                 dfs (-1, r, stack, n, sss);

                             dfs_roots (roots, stack, n, sss);
                        else
                             dfs_roots (roots, stack, n, sss);
                        fi;
                end 

                also
                fun dfs (p, v, stack, n, sss)
                    =
                    {   rwv::set (dfsnum, v, n);

                        rwv::set (low, v, n);       

                        fun min k
                            =
                            {   v' = rwv::get (low, v);

                                if  (k < v')
                                     rwv::set (low, v, k); 
                                fi;
                            };

                        fun visit ([], stack, n, sss)
                                =>
                                (stack, n, sss);

                            visit((e as (_, w, _)) ! es, stack, n, sss)
                                => 
                                {   d_w = rwv::get (dfsnum, w);

                                    if  (rwv::get (dfsnum, w) < 0)

                                         my (stack, n, sss)
                                             =
                                             dfs (v, w, stack, n, sss);

                                         min (rwv::get (low, w)); visit (es, stack, n, sss);
                                    else
                                         min d_w; visit (es, stack, n, sss);
                                    fi;
                                };
                        end;

                        fun visit' ([], stack, n, sss)
                                =>
                                (stack, n, sss);

                            visit'((e as (w, _, _)) ! es, stack, n, sss)
                                => 
                                {   d_w = rwv::get (dfsnum, w);

                                    if  (rwv::get (dfsnum, w) < 0)

                                         my (stack, n, sss)
                                             =
                                             dfs (v, w, stack, n, sss);

                                         min (rwv::get (low, w)); visit'(es, stack, n, sss);
                                    else
                                         min d_w; visit'(es, stack, n, sss);
                                    fi;
                                };
                        end;

                        my (stack, n, sss) =  visit (ggg.out_edges v, v ! stack, n+1, sss);
                        my (stack, n, sss) =  visit'(ggg.in_edges v, stack, n, sss);

                        if  (p >= 0   and   rwv::get (low, v) == rwv::get (dfsnum, p))

                             fun loop ([], ccc)
                                     =>
                                     ([], ccc);

                                 loop (w ! stack, ccc)
                                     => 
                                     {   d_w = rwv::get (dfsnum, w);

                                         ccc   = fold_backward
                                                     (\\ (e as (_, w', _), ccc)
                                                         =
                                                         if (d_w > rwv::get (dfsnum, w')   )   e ! ccc;
                                                         else                                    ccc;
                                                         fi
                                                     ) 
                                                     ccc
                                                     (ggg.out_edges w);

                                         ccc   = fold_backward
                                                     (\\ (e as (w', _, _), ccc)
                                                         =
                                                         if (d_w > rwv::get (dfsnum, w')   )   e ! ccc;
                                                         else                                    ccc;
                                                         fi
                                                     ) 
                                                     ccc
                                                     (ggg.in_edges w);

                                         if   (w != v)      loop (stack, ccc);
                                         else                    (stack, ccc);
                                         fi;
                                     };
                              end;

                              my (stack, ccc)
                                  =
                                  loop (stack,[]);

                             (stack, n, process (ccc, sss));

                        else
                             (stack, n, sss);
                        fi;
                    };

                my (_, _, sss)
                    =
                    dfs_roots (ggg.nodes (),[], 0, sss);

                sss;
            };                  # fun biconnected_components
    };
end;