15.4.772  src/lib/graph/graph-strongly-connected-components.pkg

# graph-strongly-connected-components.pkg
#
# Tarjan's algorithm
#
# This module computes strongly connected components
# (SCC) of a graph.
#
# Each SCC is represented as a list of nodes.
#
# All nodes are folded together with a user supplied function.
#
# -- Allen Leung
#
# See also:
#
#     src/lib/src/digraph-strongly-connected-components-g.pkg

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

###           "In ten years, computers will
###            just be bumps in cables."
###
###                      -- Gordon Bell, 1990 



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_strongly_connected_components
    : (weak)  Graph_Strongly_Connected_Components                       # Graph_Strongly_Connected_Components   is from   src/lib/graph/graph-strongly-connected-components.api
    {
        fun scc' { n, nodes, out_edges } process sss
            =
            dfs_all (nodes, sss)
            where
                onstack =  rw_vector_of_one_byte_unts::make_rw_vector (n, 0u0);
                dfsnum  =  rwv::make_rw_vector (n,-1);

                fun dfs (v, num, stack, sss)
                    =
                    {   dfsnum_v = num;

                        fun f ([], num, stack, low_v, sss)
                                =>
                                (num, stack, low_v, sss);

                            f ((_, w, _) ! es, num, stack, low_v, sss)
                                =>
                                {   dfsnum_w = rwv::get (dfsnum, w);

                                    if   (dfsnum_w == -1)
                                         my (num, stack, dfsnum_w, low_w, sss) = dfs (w, num, stack, sss);
                                         f (es, num, stack, int::min (low_v, low_w), sss);
                                    else
                                         if  (dfsnum_w < dfsnum_v   and 
                                              rw_vector_of_one_byte_unts::get (onstack, w) == 0u1
                                             )
                                             #
                                             f (es, num, stack, int::min (dfsnum_w, low_v), sss);
                                         else
                                             f (es, num, stack, low_v, sss);
                                         fi;
                                    fi;
                                };
                        end;

                        rwv::set (dfsnum, v, dfsnum_v);
                        rw_vector_of_one_byte_unts::set (onstack, v, 0u1);

                        my (num, stack, low_v, sss)
                            = 
                            f (out_edges v, num+1, v ! stack, dfsnum_v, sss);

                        fun pop ([], scc'', sss)
                                =>
                                ([], sss);

                            pop (x ! stack, scc'', sss)
                                =>
                                {   scc'' = x ! scc'';
                                    rw_vector_of_one_byte_unts::set (onstack, x, 0u0);

                                    if  (x == v)   (stack, process (scc'', sss)); 
                                    else           pop (stack, scc'', sss);
                                    fi;
                                };
                        end;

                        my (stack, sss)
                            =
                            if   (low_v == dfsnum_v)   pop (stack,[], sss); 
                            else                       (stack, sss);
                            fi;

                        (num, stack, dfsnum_v, low_v, sss);
                    };


                fun dfs_all ([], sss)
                        =>
                        sss;

                    dfs_all (n ! nodes, sss)
                        =>
                        if (rwv::get (dfsnum, n) == -1)
                             #
                             my (_, _, _, _, sss)
                                 =
                                 dfs (n, 0,[], sss);

                             dfs_all (nodes, sss);
                        else dfs_all (nodes, sss);
                        fi;
                end;
            end;

        fun scc (odg::DIGRAPH ggg)
            =
            scc' { n         =>  ggg.capacity (),
                   nodes     =>  map #1 (ggg.nodes ()), 
                   out_edges =>  ggg.out_edges
                 };

    };
end;