6
7:- module(scc, [nodes_arcs_sccs/3]). 8
30
31:- use_module(library(assoc)). 32:- use_module(library(apply)). 33:- use_module(library(pairs)). 34
35nodes_arcs_sccs(Ns, As, Ss) :-
36 37 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 47 throw(scc(Ss))),
48 scc(Ss),
49 true).
50
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
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
149
150state(S), [S] --> [S].
151
152state(S1, S), [S] --> [S1]