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:- use_module(library(apply)).   33:- use_module(library(pairs)).   34
   35nodes_arcs_sccs(Ns, As, Ss) :-
   36        % must_be(list(ground), Ns),
   37        % must_be(list(ground), As),
   38        catch((maplist(node_var_pair, Ns, Vs, Ps),
   39               list_to_assoc(Ps, Assoc),
   40               maplist(attach_arc(Assoc), As),
   41               scc(Vs, successors),
   42               maplist(v_with_lowlink, Vs, Ls1),
   43               keysort(Ls1, Ls2),
   44               group_pairs_by_key(Ls2, Ss1),
   45               pairs_values(Ss1, Ss),
   46               % reset all attributes
   47               throw(scc(Ss))),
   48              scc(Ss),
   49              true).
   50
   51% Associate a fresh variable with each node, so that attributes can be
   52% attached to variables that correspond to nodes.
   53
   54node_var_pair(N, V, N-V) :- put_attr(V, node, N).
   55
   56v_with_lowlink(V, L-N) :-
   57        get_attr(V, lowlink, L),
   58        get_attr(V, node, N).
   59
   60successors(V, Vs) :-
   61        (   get_attr(V, successors, Vs) -> true
   62        ;   Vs = []
   63        ).
   64
   65attach_arc(Assoc, arc(X,Y)) :-
   66        get_assoc(X, Assoc, VX),
   67        get_assoc(Y, Assoc, VY),
   68        successors(VX, Vs),
   69        put_attr(VX, successors, [VY|Vs]).
   70
   71/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   72   Tarjan's strongly connected components algorithm.
   73
   74   DCGs are used to implicitly pass around the global index, stack
   75   and the predicate relating a vertex to its successors.
   76- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   77
   78scc(Vs, Succ) :- phrase(scc(Vs), [s(0,[],Succ)], _).
   79
   80scc([])     --> [].
   81scc([V|Vs]) -->
   82        (   vindex_defined(V) -> scc(Vs)
   83        ;   scc_(V), scc(Vs)
   84        ).
   85
   86scc_(V) -->
   87        vindex_is_index(V),
   88        vlowlink_is_index(V),
   89        index_plus_one,
   90        s_push(V),
   91        successors(V, Tos),
   92        each_edge(Tos, V),
   93        (   { get_attr(V, index, VI),
   94              get_attr(V, lowlink, VI) } -> pop_stack_to(V, VI)
   95        ;   []
   96        ).
   97
   98vindex_defined(V) --> { get_attr(V, index, _) }.
   99
  100vindex_is_index(V) -->
  101        state(s(Index,_,_)),
  102        { put_attr(V, index, Index) }.
  103
  104vlowlink_is_index(V) -->
  105        state(s(Index,_,_)),
  106        { put_attr(V, lowlink, Index) }.
  107
  108index_plus_one -->
  109        state(s(I,Stack,Succ), s(I1,Stack,Succ)),
  110        { I1 is I+1 }.
  111
  112s_push(V)  -->
  113        state(s(I,Stack,Succ), s(I,[V|Stack],Succ)),
  114        { put_attr(V, in_stack, true) }.
  115
  116vlowlink_min_lowlink(V, VP) -->
  117        { get_attr(V, lowlink, VL),
  118          get_attr(VP, lowlink, VPL),
  119          VL1 is min(VL, VPL),
  120          put_attr(V, lowlink, VL1) }.
  121
  122successors(V, Tos) --> state(s(_,_,Succ)), { call(Succ, V, Tos) }.
  123
  124pop_stack_to(V, N) -->
  125        state(s(I,[First|Stack],Succ), s(I,Stack,Succ)),
  126        { del_attr(First, in_stack) },
  127        (   { First == V } -> []
  128        ;   { put_attr(First, lowlink, N) },
  129            pop_stack_to(V, N)
  130        ).
  131
  132each_edge([], _) --> [].
  133each_edge([VP|VPs], V) -->
  134        (   vindex_defined(VP) ->
  135            (   v_in_stack(VP) ->
  136                vlowlink_min_lowlink(V, VP)
  137            ;   []
  138            )
  139        ;   scc_(VP),
  140            vlowlink_min_lowlink(V, VP)
  141        ),
  142        each_edge(VPs, V).
  143
  144v_in_stack(V) --> { get_attr(V, in_stack, true) }.
  145
  146/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  147   DCG rules to access the state, using right-hand context notation.
  148- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  149
  150state(S), [S] --> [S].
  151
  152state(S1, S), [S] --> [S1]