15.4.799  src/lib/graph/transitive-closure.pkg

# transitive-closure.pkg
#
# In place transitive closures.
#
# -- Allen Leung

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



###         "Images of broken light
###             which dance before me like a million eyes
###          that call me on and on
###             across the Universe.
###          Limitless undying love
###              which shines around me like a million suns,
###          it calls me on and on
###              across the Universe."
###
###                      -- The Beatles 1968


stipulate
    package odg =  oop_digraph;                                         # oop_digraph   is from   src/lib/graph/oop-digraph.pkg
herein

    api Transitive_Closure {
        #
        acyclic_transitive_closure
             :
             { plus:    (E, E) -> E,
               simple:  Bool
             }
             ->
             odg::Digraph(N,E,G)                                        # Here N,E,G stand stead for the types of client-package-supplied records associated with (respectively) nodes, edges and graphs.
             ->
             Void;

        acyclic_transitive_closure2
           :
           { plus: (E, E) -> E,
             max:  (E, E) -> E
           }
           ->
           odg::Digraph(N,E,G)
           ->
           Void;

        transitive_closure
           :
           ((E, E) -> E)
           ->
           odg::Digraph(N,E,G)
           ->
           Void;
    };
end;



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   transitive_closure
    : (weak)  Transitive_Closure                                        # Transitive_Closure    is from   src/lib/graph/transitive-closure.pkg
    {

        # Transitive closure for an acyclic graph.
        # Should probably use a better algorithm.               # XXX BUGGO FIXME

        fun acyclic_transitive_closure { plus, simple } (ggg' as odg::DIGRAPH ggg)
            =
            {   nnn   =  ggg.capacity ();
                reach =  rwv::make_rw_vector (nnn,-1);     #  reach[v] = u iff v -> u 

                fun visit u
                    =
                    {   fun visit_edge (v, u, e)
                            =
                            {   fun trans (w, v, e')
                                    =
                                    if  (rwv::get (reach, w)  !=  u)
                                         rwv::set (reach, w, u);
                                         ggg.add_edge (w, u, plus(e,e'));
                                    fi;

                                apply trans (ggg.in_edges v);
                            };

                        in_edges =   ggg.in_edges u;

                        if   simple
                             apply
                                 (\\ (v, _, _) =  rwv::set (reach, u, v))
                                 in_edges;
                        fi;

                        apply  visit_edge  in_edges;
                    };

                list =   graph_topological_sort::topological_sort ggg' (map #1 (ggg.nodes ()));

                apply visit list;
            };

        fun acyclic_transitive_closure2 { plus, max } (ggg' as odg::DIGRAPH ggg)
            =
            {   nnn    = ggg.capacity ();
                reach  = rwv::make_rw_vector (nnn,-1);  #  reach[v] = u iff v -> u 
                labels = rwv::make_rw_vector (nnn,[]);  #  l in labels[v] iff v ->l u 

                fun visit u
                    =
                    {   fun ins (v, e, nodes)
                            =
                            if   (rwv::get (reach, v)  ==  u)

                                 rwv::set (labels, v, e ! rwv::get (labels, v));
                                 nodes;
                            else 
                                 rwv::set (reach, v, u);
                                 rwv::set (labels, v,[e]);
                                 v ! nodes;
                            fi;

                        fun init ([], nodes) => nodes;
                            init((v, u, e) ! es, nodes) => init (es, ins (v, e, nodes));
                        end;

                        fun add_trans ([], nodes)
                                =>
                                nodes;

                            add_trans((v, u, e) ! es, nodes)
                                => 
                                {   fun trans ([], nodes)
                                            =>
                                            nodes;

                                        trans((w, v, e') ! es, nodes)
                                            =>
                                            trans (es, ins (w, plus(e, e'), nodes));
                                    end;

                                    add_trans (es, trans (ggg.in_edges v, nodes));
                                };
                        end;

                        in_edges =  ggg.in_edges u;

                        nodes =  init      (in_edges, []   );       #  insert v -> u 
                        nodes =  add_trans (in_edges, nodes);   #  insert w -> u if w -> v 

                        fun fold_all ([], es)
                                =>
                                es;

                            fold_all (v ! vs, es)
                                =>
                                case (rwv::get (labels, v))
                                    #
                                    []       =>  raise exception odg::BAD_GRAPH "acyclic_transitive_closure2";
                                    [e]      =>  fold_all (vs, (v, u, e) ! es);
                                    e' ! es' =>  fold_all (vs, (v, u, fold_backward max e' es') ! es);
                                esac;
                        end;

                        ggg.set_in_edges (u, fold_all (nodes,[])); 
                    };

                list =  graph_topological_sort::topological_sort ggg' (map #1 (ggg.nodes ()));

                apply visit list;
            };

        fun transitive_closure f (odg::DIGRAPH ggg)
            =
            raise exception odg::UNIMPLEMENTED;
    };
end;