1/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    2   Strongly connected components of a graph.
    3   Written by Markus Triska (triska@gmx.at), May 2011
    4   Public domain code.
    5- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
    6
    7:- module(scc, [nodes_arcs_sccs/3]).    8
    9/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   10
   11   Usage:
   12
   13   nodes_arcs_sccs(+Ns, +As, -SCCs)
   14
   15   where:
   16
   17   Ns is a list of nodes. Each node must be a ground term.
   18   As is a list of arc(N1,N2) terms where N1 and N2 are nodes.
   19   SCCs is a list of lists of nodes that are in the same strongly
   20        connected component.
   21
   22   Running time is O(|V| + log(|V|)*|E|).
   23
   24   Example:
   25
   26   %?- nodes_arcs_sccs([a,b,c,d], [arc(a,b),arc(b,a),arc(b,c)], SCCs).
   27   %@ SCCs = [[a,b],[c],[d]].
   28
   29- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   30
   31:- use_module(library(assoc)).   32
   33nodes_arcs_sccs(Ns, As, Ss) :-
   34        % must_be(list(ground), Ns),
   35        % must_be(list(ground), As),
   36        catch((maplist(node_var_pair, Ns, Vs, Ps),
   37               list_to_assoc(Ps, Assoc),
   38               maplist(attach_arc(Assoc), As),
   39               scc(Vs, successors),
   40               maplist(v_with_lowlink, Vs, Ls1),
   41               keysort(Ls1, Ls2),
   42               group_pairs_by_key(Ls2, Ss1),
   43               pairs_values(Ss1, Ss),
   44               % reset all attributes
   45               throw(scc(Ss))),
   46              scc(Ss),
   47              true).
   48
   49% Associate a fresh variable with each node, so that attributes can be
   50% attached to variables that correspond to nodes.
   51
   52node_var_pair(N, V, N-V) :- put_attr(V, node, N).
   53
   54v_with_lowlink(V, L-N) :-
   55        get_attr(V, lowlink, L),
   56        get_attr(V, node, N).
   57
   58successors(V, Vs) :-
   59        (   get_attr(V, successors, Vs) -> true
   60        ;   Vs = []
   61        ).
   62
   63attach_arc(Assoc, arc(X,Y)) :-
   64        get_assoc(X, Assoc, VX),
   65        get_assoc(Y, Assoc, VY),
   66        successors(VX, Vs),
   67        put_attr(VX, successors, [VY|Vs]).
   68
   69/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   70   Tarjan's strongly connected components algorithm.
   71
   72   DCGs are used to implicitly pass around the global index, stack
   73   and the predicate relating a vertex to its successors.
   74- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   75
   76scc(Vs, Succ) :- phrase(scc(Vs), [s(0,[],Succ)], _).
   77
   78scc([])     --> [].
   79scc([V|Vs]) -->
   80        (   vindex_defined(V) -> scc(Vs)
   81        ;   scc_(V), scc(Vs)
   82        ).
   83
   84scc_(V) -->
   85        vindex_is_index(V),
   86        vlowlink_is_index(V),
   87        index_plus_one,
   88        s_push(V),
   89        successors(V, Tos),
   90        each_edge(Tos, V),
   91        (   { get_attr(V, index, VI),
   92              get_attr(V, lowlink, VI) } -> pop_stack_to(V, VI)
   93        ;   []
   94        ).
   95
   96vindex_defined(V) --> { get_attr(V, index, _) }.
   97
   98vindex_is_index(V) -->
   99        state(s(Index,_,_)),
  100        { put_attr(V, index, Index) }.
  101
  102vlowlink_is_index(V) -->
  103        state(s(Index,_,_)),
  104        { put_attr(V, lowlink, Index) }.
  105
  106index_plus_one -->
  107        state(s(I,Stack,Succ), s(I1,Stack,Succ)),
  108        { I1 is I+1 }.
  109
  110s_push(V)  -->
  111        state(s(I,Stack,Succ), s(I,[V|Stack],Succ)),
  112        { put_attr(V, in_stack, true) }.
  113
  114vlowlink_min_lowlink(V, VP) -->
  115        { get_attr(V, lowlink, VL),
  116          get_attr(VP, lowlink, VPL),
  117          VL1 is min(VL, VPL),
  118          put_attr(V, lowlink, VL1) }.
  119
  120successors(V, Tos) --> state(s(_,_,Succ)), { call(Succ, V, Tos) }.
  121
  122pop_stack_to(V, N) -->
  123        state(s(I,[First|Stack],Succ), s(I,Stack,Succ)),
  124        { del_attr(First, in_stack) },
  125        (   { First == V } -> []
  126        ;   { put_attr(First, lowlink, N) },
  127            pop_stack_to(V, N)
  128        ).
  129
  130each_edge([], _) --> [].
  131each_edge([VP|VPs], V) -->
  132        (   vindex_defined(VP) ->
  133            (   v_in_stack(VP) ->
  134                vlowlink_min_lowlink(V, VP)
  135            ;   []
  136            )
  137        ;   scc_(VP),
  138            vlowlink_min_lowlink(V, VP)
  139        ),
  140        each_edge(VPs, V).
  141
  142v_in_stack(V) --> { get_attr(V, in_stack, true) }.
  143
  144/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  145   DCG rules to access the state, using right-hand context notation.
  146- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  147
  148state(S), [S] --> [S].
  149
  150state(S1, S), [S] --> [S1]