   ### 15.4.689  src/lib/compiler/src/stuff/compute-minimum-feedback-vertex-set-of-digraph.pkg

`## compute-minimum-feedback-vertex-set-of-digraph.pkg`
`#`
`# Compute "minimum feedback vertex set" of a given directed graph:`
`# For definition and background see:`
`#`
`#     http://en.wikipedia.org/wiki/Feedback_vertex_set`
`# `
`# This algorithm is used in`
`#`
`#     `src/lib/compiler/back/low/main/nextcode/pick-nextcode-fns-for-heaplimit-checks.pkg
`#`
`# to select a minimal set of functions at which to insert heapcleaner ("garbage collector")`
`# heap-limit checks while still guaranteeing that every possible codeloop contains`
`# at least one such check.  This is currently the only use of the algorithm in the codebase.`
`#`
`# History:`
`#     Original version by: Andrew Appel (appel@cs.princeton.edu) (is this right?)`
`#     Recent cleanup by: Matthias Blume (blume@kurims.kyoto-u.ac.jp)`
`#         The cleanup involves getting rid of duplicate strongly-connected-component (SCC)`
`#         code using the library module graph_strongly_connected_components_g) and making`
`#         use of integer set- and map-modules (from the same library).  `
`#         The use of sorted_list has been eliminated.`
`#`

`# Compiled by:`
`#     `src/lib/compiler/core.sublib

`api Compute_Minimum_Feedback_Vertex_Set_Of_Digraph {`

`    # Input: A directed graph; that is, a list of vertex-numbers, `
`    #        each node with a list of out-edges which indicate other vertices.`
`    # Output:  A minimum feedback vertex set.`
`    #`
`    # Method: branch and bound`

`    Vertex =  Int;`
`    Node   =  (Vertex, List( Vertex )); #  vertex + outgoing edges `
`    Graph  =  List( Node );`

`    compute_minimum_feedback_vertex_set_of_digraph`
`        :`
`        Graph -> List(Vertex);`
`};`

`stipulate`
`    package err =  error_message;                                                       # error_message         is from   `src/lib/compiler/front/basics/errormsg/error-message.pkg
`    package im =   int_red_black_map;                                                   # int_red_black_map     is from   `src/lib/src/int-red-black-map.pkg
`    package is =   int_red_black_set;                                                   # int_red_black_set     is from   `src/lib/src/int-red-black-set.pkg

`    package nd`
`        =`
`        package {`
`            Key = Int;`
`            compare = int::compare;`
`        };`

`    package scc = digraph_strongly_connected_components_g( nd );                        # digraph_strongly_connected_components_g       is from   `src/lib/src/digraph-strongly-connected-components-g.pkg
`herein`

`    package compute_minimum_feedback_vertex_set_of_digraph`
`    :       Compute_Minimum_Feedback_Vertex_Set_Of_Digraph`
`    {`

`        # NOTE:  By setting MAXDEPTH=infinity, this algorithm will produce`
`        #        the exact minimum feedback vertex set.  With MAXDEPTH<infinity,`
`        #        the result will still be a feedback vertex set, but not`
`        #        always the minimum set.  However, on almost all real programs,`
`        #        MAXDEPTH=3 will give perfect and efficiently computed results.`
`        #        Increasing MAXDEPTH will not make the algorithm take longer or`
`        #        produce better results on "real" programs. `
`        maxdepth = 3;`

`        Vertex = Int;`
`        Node = (Vertex, List( Vertex ));        #  vertex + outgoing edges `
`        Graph = List( Node );`

`        fun bug s =   err::impossible ("Feedback::feedback: " + s);`

`        fun l2s l =   is::add_list (is::empty, l);`

`        s2l = is::vals_list;`

`        #  Normalize graph by eliminating edges that lead elsewhere:`
`        #`
`        fun normalize g`
`            =`
`            {   vs = l2s (map #1 g);`

`                fun prune (v, e)`
`                    =`
`                    (v, is::intersection (e, vs));`

`                map prune g;`
`            };`

`        fun scc g                                       # "scc" == "strongly connected component"`
`            =`
`            {   roots = map #1 g;`

`                fun add ((v, e), (sm, fm))`
`                    =`
`                    (im::set (sm, v, e), im::set (fm, v, s2l e));`

`                my (set_map, follow_map) = fold_forward add (im::empty, im::empty) g;`

`                fun follow v`
`                    =`
`                    the (im::get (follow_map, v));`

`                # Do the actual scc calculation.`
`                #`
`                # For a sanity check we could`
`                # match the result against (scc::SIMPLE root ! _),`
`                # but we trust the SCC module and "nontrivial"`
`                # (below) will take care of the root node.`
`                #`
`                sccres = scc::topological_order' { roots, follow };`

`                # At this point we have already eliminated`
`                # all trivial (= SIMPLE) components.`

`                fun to_node v`
`                    =`
`                    (   v,`
`                        the (im::get (set_map, v))`
`                    );`

`                fun nontrivial (scc::SIMPLE _, a) => a;`
`                    nontrivial (scc::RECURSIVE l, a) => map to_node l ! a;`
`                end;`

`                ntcomps = fold_backward nontrivial [] sccres;`

`                # Finally, We make each component "self-contained"`
`                # by pruning away all edges that lead out of it:`

`                map normalize ntcomps;`
`            };`

`        fun compute_minimum_feedback_vertex_set_of_digraph   graph0`
`            =`
`            {   # Make edges into vertex sets: `
`                #`
`                graph = map (\\ (v, e) = (v, l2s e))`
`                            graph0;`

`                # Any node with an edge to itself`
`                # MUST be in the minimum feedback`
`                # vertex set.`
`                # Remove these "selfnodes" first`
`                # to simplify the problem.`
`                #`
`                fun has_self_loop (v, e)`
`                    =`
`                    is::member (e, v);`

`                my (selfnodes, rest) = list::partition has_self_loop graph;`

`                # The following value is part 1`
`                # of the final result:`
`                #`
`                selfvertices = l2s (map #1 selfnodes);`

`                # With missing nodes, the rest`
`                # needs to be normalized: `
`                #`
`                rest = normalize rest;`

`                # Here is the branch-and-bound algorithm`
`                # that is used for the rest:`
`                #`
`                fun feedb (limit, graph, depth)`
`                    =`
`                    if (depth <= 0)`
`                        #                    `
`                        if (limit >= length graph)`
`                            #`
`                            THE (l2s (map #1 graph));                     #  Approximate! `
`                        else`
`                            # Note: the original algorithm would have continued`
`                            # here when depth < 0; but that seems wrong.       XXX BUGGO FIXME`
`                            #`
`                            NULL;`
`                        fi;`
`                    else`
`                        comps = scc graph;`

`                        fun g (lim, set, c ! comps)`
`                                =>`
`                                if (lim <= 0)`
`                                    #`
`                                    NULL;`
`                                else`
`                                    case (try (lim, c, depth))`
`                                        #`
`                                        THE vs => g (   lim - is::vals_count vs + 1,`
`                                                             is::union (vs, set),`
`                                                             comps`
`                                                         );`
`                                        NULL => NULL;`
`                                    esac;`
`                                  fi;`

`                            g (lim, set, [])`
`                                =>`
`                                THE set;`
`                        end;`

`                        g (limit - length comps + 1, is::empty, comps);`
`                    fi`

`                also`
`                fun try (limit, nodes, depth)`
`                    =`
`                    f (NULL, int::min (limit, length nodes), [], nodes)`
`                    where`
`                        fun f (best, lim, left, [])`
`                                =>`
`                                best;`

`                            f (best, lim, left, (node as (x, e)) ! right)`
`                                =>`
`                                if (not (list::null left) and is::vals_count e == 1)`
`                                    #   `
`                                    # A node with only one out-edge can't be part of`
`                                    # a unique minimum feedback vertex set, unless they`
`                                    # all have one out-edge.`
`                                    #`
`                                    f (best, lim, node ! left, right);`
`                                else`
`                                    fun prune (n, es)`
`                                        =`
`                                        (n, is::drop (es, x));`

`                                    reduced = map prune (list::reverse_and_prepend (left, right));`

`                                    case (feedb (lim - 1, reduced, depth - 1))`
`                                        #`
`                                        THE vs`
`                                            =>`
`                                            f (THE (is::add (vs, x)),`
`                                                         is::vals_count vs,`
`                                                         node ! left, right);`

`                                        NULL =>   f (best, lim, node ! left, right);`
`                                    esac;`
`                                fi;`
`                        end;`
`                    end;`

`                fun bab g`
`                    =`
`                    case (feedb (length g, g, maxdepth))`
`                        #`
`                        THE solution =>   solution;`
`                        NULL         =>   bug "no solution";`
`                    esac;`

`                s2l (is::union (selfvertices, bab rest));`
`            };`
`    };`
`end;`   