6
7:- module(scc, [nodes_arcs_sccs/3]). 8
30
31:- use_module(library(assoc)). 32
33nodes_arcs_sccs(Ns, As, Ss) :-
34 35 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 45 throw(scc(Ss))),
46 scc(Ss),
47 true).
48
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
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
147
148state(S), [S] --> [S].
149
150state(S1, S), [S] --> [S1]