[m-rev.] for review: Fix digraph.tc and digraph.rtc.
Peter Wang
novalazy at gmail.com
Tue Jan 10 14:32:18 AEDT 2023
The implementation of digraph.rtc was incorrect (as demonstrated in the
new test case), which meant that digraph.tc was also incorrect.
library/digraph.m:
Fix the implementation of rtc (reflexive transitive closure):
- Following the algorithm used in digraph.cliques, it needs to
traverse the graph G in *reverse* depth-first order.
- To find the clique containing a vertex X, it needs to do a DFS on
the *reversed* graph to find the vertices with a path to X.
The vertices that were previously unvisited will be members of
the same clique as X.
- Previously it found the "followers" of the elements of the clique,
and the followers of those followers, then added edges from the
members of the current clique to those followers. However, that
only includes vertices two steps removed from the clique.
I have fixed it to add edges to *all* vertices reachable from
members of the clique.
Add straightforward implementations of tc and rtc for comparison.
Add some comments.
tests/hard_coded/Mmakefile:
tests/hard_coded/digraph_tc.exp:
tests/hard_coded/digraph_tc.inp:
tests/hard_coded/digraph_tc.m:
Add test case.
NEWS:
Announce the fixes.
---
NEWS | 2 +
library/digraph.m | 142 +++++++++++++++----
tests/hard_coded/Mmakefile | 1 +
tests/hard_coded/digraph_tc.exp | 99 +++++++++++++
tests/hard_coded/digraph_tc.inp | 8 ++
tests/hard_coded/digraph_tc.m | 240 ++++++++++++++++++++++++++++++++
6 files changed, 466 insertions(+), 26 deletions(-)
create mode 100644 tests/hard_coded/digraph_tc.exp
create mode 100644 tests/hard_coded/digraph_tc.inp
create mode 100644 tests/hard_coded/digraph_tc.m
diff --git a/NEWS b/NEWS
index 06723f143..866343d24 100644
--- a/NEWS
+++ b/NEWS
@@ -156,6 +156,8 @@ Changes to the Mercury standard library
- The `digraph_key(T)` type is now an instance of the `uenum` typeclass,
and is no longer an instance of the `enum` typeclass.
+* We have fixed the implementations of `digraph.tc` and `digraph.rtc`.
+
### Changes to the `enum` module
* The following typeclass has been added:
diff --git a/library/digraph.m b/library/digraph.m
index 3dd0d35cc..7529bd1f9 100644
--- a/library/digraph.m
+++ b/library/digraph.m
@@ -341,6 +341,9 @@
% rtc(G, RTC) is true if RTC is the reflexive transitive closure of G.
%
+ % RTC is the reflexive closure of the transitive closure of G,
+ % or, equivalently, the transitive closure of the reflexive closure of G.
+ %
:- func rtc(digraph(T)) = digraph(T).
:- pred rtc(digraph(T)::in, digraph(T)::out) is det.
@@ -362,6 +365,24 @@
:- implementation.
+% Everything below here is not intended to be part of the public interface,
+% and will not be included in the Mercury library reference manual.
+
+:- interface.
+
+ % Straightforward implementation of tc for debugging.
+ %
+:- pred slow_tc(digraph(T)::in, digraph(T)::out) is det.
+
+ % Straightforward implementation of rtc for debugging.
+ %
+:- pred slow_rtc(digraph(T)::in, digraph(T)::out) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
:- import_module bimap.
:- import_module uint.
:- import_module require.
@@ -1048,14 +1069,24 @@ tc(G, Tc) :-
% digraph.tc returns the transitive closure of a digraph.
% We use this procedure:
%
- % - Compute the reflexive transitive closure.
+ % - Compute the reflexive transitive closure, which is
+ % the reflexive closure of the transitive closure of G:
+ % G* = (G+)=
+ %
% - Find the "fake reflexives", that is, the set of vertices x for which
% (x,x) is not an edge in G+. This is done by noting that G+ = G . G*
% (where '.' denotes composition). Therefore x is a fake reflexive
% iff there is no y such that (x,y) is an edge in G and (y,x) is an edge
% in G*.
+ %
% - Remove those edges from the reflexive transitive closure
% computed above.
+ %
+ % XXX Despite being "easier to debug", digraph.rtc was buggy for a long
+ % time, so implementing digraph.tc in terms of digraph.rtc was of no
+ % benefit. We should implement TC using a known efficient algorithm,
+ % then RTC can be implemented trivially on top of TC.
+ %
digraph.rtc(G, Rtc),
% Find the fake reflexives.
@@ -1099,43 +1130,62 @@ rtc(G, !:Rtc) :-
% sorted order, compute the RTC for each element in the clique and then
% add the appropriate edges.
- digraph.dfs(G, Dfs),
+ % Start with G.
+ !:Rtc = G,
+
+ % Visit each clique in turn.
+ digraph.dfsrev(G, DfsRev),
+ digraph.inverse(G, GInv),
sparse_bitset.init(Vis),
+ digraph.rtc_2(DfsRev, G, GInv, Vis, !Rtc).
- % First start with all the vertices in G, but no edges.
- G = digraph(NextKey, VMap, _, _),
- map.init(FwdMap),
- map.init(BwdMap),
- !:Rtc = digraph(NextKey, VMap, FwdMap, BwdMap),
-
- digraph.rtc_2(Dfs, G, Vis, !Rtc).
-
-:- pred digraph.rtc_2(list(digraph_key(T))::in, digraph(T)::in,
+:- pred digraph.rtc_2(list(digraph_key(T))::in, digraph(T)::in, digraph(T)::in,
digraph_key_set(T)::in, digraph(T)::in, digraph(T)::out) is det.
-rtc_2([], _, _, !Rtc).
-rtc_2([X | Xs], G, !.Vis, !Rtc) :-
+rtc_2([], _, _, _, !Rtc).
+rtc_2([X | Xs], G, GInv, !.Vis, !Rtc) :-
( if sparse_bitset.contains(!.Vis, X) then
true
else
- digraph.dfs_2(G, X, !Vis, [], CliqList),
+ % Do a DFS on GInv, starting from X, but not including visited
+ % vertices. This gives the clique which includes X.
+ digraph.dfs_2(GInv, X, !Vis, [], CliqList),
sparse_bitset.list_to_set(CliqList, Cliq),
- sparse_bitset.foldl(find_followers(G), Cliq,
- Cliq, Followers0),
- sparse_bitset.foldl(find_followers(!.Rtc), Followers0,
- Cliq, Followers),
- digraph.add_cartesian_product(Cliq, Followers, !Rtc)
- ),
- digraph.rtc_2(Xs, G, !.Vis, !Rtc).
-:- pred find_followers(digraph(T)::in, digraph_key(T)::in,
+ % Every vertex in the clique is reachable from every other vertex in
+ % the clique.
+ Descendants0 = Cliq,
+
+ % For all vertices in the clique, the set of reachable vertices is the
+ % same.
+ (
+ CliqList = [],
+ Descendants = Descendants0
+ ;
+ CliqList = [Root | _],
+ find_descendants(G, Root, sparse_bitset.init, _Visited,
+ Descendants0, Descendants)
+ ),
+
+ digraph.add_cartesian_product(Cliq, Descendants, !Rtc)
+ ),
+ digraph.rtc_2(Xs, G, GInv, !.Vis, !Rtc).
+
+:- pred find_descendants(digraph(T)::in, digraph_key(T)::in,
+ digraph_key_set(T)::in, digraph_key_set(T)::out,
digraph_key_set(T)::in, digraph_key_set(T)::out) is det.
-find_followers(G, X, !Followers) :-
- digraph.lookup_key_set_from(G, X, SuccXs),
- sparse_bitset.union(SuccXs, !Followers).
+find_descendants(G, X, !Visited, !Reachable) :-
+ ( if sparse_bitset.contains(!.Visited, X) then
+ true
+ else
+ digraph.lookup_key_set_from(G, X, SuccXs),
+ sparse_bitset.insert(X, !Visited),
+ sparse_bitset.union(SuccXs, !Reachable),
+ sparse_bitset.foldl2(find_descendants(G), SuccXs, !Visited, !Reachable)
+ ).
-:- pred digraph.add_cartesian_product(digraph_key_set(T)::in,
+:- pred add_cartesian_product(digraph_key_set(T)::in,
digraph_key_set(T)::in, digraph(T)::in, digraph(T)::out) is det.
add_cartesian_product(KeySet1, KeySet2, !Rtc) :-
@@ -1175,6 +1225,46 @@ traverse_child(Graph, ProcessEdge, Parent, ChildKey, !Acc) :-
Child = digraph.lookup_vertex(Graph, ChildKey),
ProcessEdge(Parent, Child, !Acc).
+%---------------------------------------------------------------------------%
+
+slow_tc(G, TC) :-
+ % First start with all the vertices in G, but no edges.
+ G = digraph(NextKey, VMap, FwdMap, _BwdMap),
+ TC0 = digraph(NextKey, VMap, map.init, map.init),
+
+ map.keys(FwdMap, FwdKeys),
+ list.foldl(add_edges_to_reachable(G), FwdKeys, TC0, TC).
+
+:- pred add_edges_to_reachable(digraph(T)::in, uint::in,
+ digraph(T)::in, digraph(T)::out) is det.
+
+add_edges_to_reachable(G, XI, !TC) :-
+ X = digraph_key(XI),
+ find_descendants(G, X,
+ sparse_bitset.init, _Visited,
+ sparse_bitset.init, Reachable),
+ sparse_bitset.foldl(add_edge(X), Reachable, !TC).
+
+%---------------------------------------------------------------------------%
+
+slow_rtc(G, RTC) :-
+ slow_tc(G, TC),
+ rc(TC, RTC).
+
+ % Reflexive closure.
+ %
+:- pred rc(digraph(T)::in, digraph(T)::out) is det.
+
+rc(G, RC) :-
+ digraph.keys(G, Keys),
+ list.foldl(add_reflexive, Keys, G, RC).
+
+:- pred add_reflexive(digraph_key(T)::in,
+ digraph(T)::in, digraph(T)::out) is det.
+
+add_reflexive(X, !G) :-
+ add_edge(X, X, !G).
+
%---------------------------------------------------------------------------%
:- end_module digraph.
%---------------------------------------------------------------------------%
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 1f016ed78..22e781b9c 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -101,6 +101,7 @@ ORDINARY_PROGS = \
dense_lookup_switch_non \
dense_lookup_switch_non2 \
det_in_semidet_cntxt \
+ digraph_tc \
dir_fold \
direct_arg_partial_inst \
direct_arg_partial_inst2 \
diff --git a/tests/hard_coded/digraph_tc.exp b/tests/hard_coded/digraph_tc.exp
new file mode 100644
index 000000000..ad51afde8
--- /dev/null
+++ b/tests/hard_coded/digraph_tc.exp
@@ -0,0 +1,99 @@
+---- G ----
+digraph {
+ /* 6 edges */
+ A -> B;
+ A -> C;
+ B -> C;
+ B -> X;
+ C -> A;
+ X -> Y;
+}
+
+---- tc(G) ----
+digraph {
+ /* 16 edges */
+ A -> A;
+ A -> B;
+ A -> C;
+ A -> X;
+ A -> Y;
+ B -> A;
+ B -> B;
+ B -> C;
+ B -> X;
+ B -> Y;
+ C -> A;
+ C -> B;
+ C -> C;
+ C -> X;
+ C -> Y;
+ X -> Y;
+}
+
+---- slow_tc(G) ----
+digraph {
+ /* 16 edges */
+ A -> A;
+ A -> B;
+ A -> C;
+ A -> X;
+ A -> Y;
+ B -> A;
+ B -> B;
+ B -> C;
+ B -> X;
+ B -> Y;
+ C -> A;
+ C -> B;
+ C -> C;
+ C -> X;
+ C -> Y;
+ X -> Y;
+}
+
+---- rtc(G) ----
+digraph {
+ /* 18 edges */
+ A -> A;
+ A -> B;
+ A -> C;
+ A -> X;
+ A -> Y;
+ B -> A;
+ B -> B;
+ B -> C;
+ B -> X;
+ B -> Y;
+ C -> A;
+ C -> B;
+ C -> C;
+ C -> X;
+ C -> Y;
+ X -> X;
+ X -> Y;
+ Y -> Y;
+}
+
+---- slow_rtc(G) ----
+digraph {
+ /* 18 edges */
+ A -> A;
+ A -> B;
+ A -> C;
+ A -> X;
+ A -> Y;
+ B -> A;
+ B -> B;
+ B -> C;
+ B -> X;
+ B -> Y;
+ C -> A;
+ C -> B;
+ C -> C;
+ C -> X;
+ C -> Y;
+ X -> X;
+ X -> Y;
+ Y -> Y;
+}
+
diff --git a/tests/hard_coded/digraph_tc.inp b/tests/hard_coded/digraph_tc.inp
new file mode 100644
index 000000000..f204e4bd1
--- /dev/null
+++ b/tests/hard_coded/digraph_tc.inp
@@ -0,0 +1,8 @@
+[
+ "A" - "B",
+ "A" - "C",
+ "B" - "C",
+ "C" - "A",
+ "B" - "X",
+ "X" - "Y"
+].
diff --git a/tests/hard_coded/digraph_tc.m b/tests/hard_coded/digraph_tc.m
new file mode 100644
index 000000000..6c2d395a7
--- /dev/null
+++ b/tests/hard_coded/digraph_tc.m
@@ -0,0 +1,240 @@
+%---------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%---------------------------------------------------------------------------%
+%
+% Test digraph.tc and digraph.rtc.
+%
+%---------------------------------------------------------------------------%
+
+:- module digraph_tc.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%---------------------------------------------------------------------------%
+%---------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module array.
+:- import_module bool.
+:- import_module digraph.
+:- import_module int.
+:- import_module list.
+:- import_module maybe.
+:- import_module pair.
+:- import_module random.
+:- import_module random.sfc64.
+:- import_module random.system_rng.
+:- import_module string.
+
+%---------------------------------------------------------------------------%
+
+main(!IO) :-
+ io.command_line_arguments(Args, !IO),
+ ( if Args = [] then
+ load_graph("digraph_tc.inp", LoadRes, !IO),
+ Verbose = yes
+ else if Args = [FileName] then
+ load_graph(FileName, LoadRes, !IO),
+ Verbose = yes
+ else if
+ Args = ["random", SizeStr],
+ string.to_int(SizeStr, Size),
+ Size > 1
+ then
+ Verbose = no,
+ init_random(MaybeRNG, !IO),
+ (
+ MaybeRNG = ok(R0),
+ generate_graph(Size, G0, R0, _R),
+ LoadRes = ok(G0)
+ ;
+ MaybeRNG = error(RNGError),
+ LoadRes = error(RNGError)
+ )
+ else
+ LoadRes = error("wrong arguments"),
+ Verbose = no
+ ),
+ (
+ LoadRes = ok(G),
+ test_graph(G, Verbose, !IO)
+ ;
+ LoadRes = error(Error),
+ io.write_string(Error, !IO),
+ io.nl(!IO),
+ io.set_exit_status(1, !IO)
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- pred load_graph(string::in, maybe_error(digraph(string))::out,
+ io::di, io::uo) is det.
+
+load_graph(FileName, Res, !IO) :-
+ io.open_input(FileName, OpenRes, !IO),
+ (
+ OpenRes = ok(Stream),
+ io.read(Stream, ReadRes, !IO),
+ (
+ ReadRes = ok(AssocList),
+ digraph.from_assoc_list(AssocList, G),
+ Res = ok(G)
+ ;
+ ReadRes = eof,
+ Res = error("unexpected eof")
+ ;
+ ReadRes = error(Error, _),
+ Res = error(Error)
+ ),
+ io.close_input(Stream, !IO)
+ ;
+ OpenRes = error(Error),
+ Res = error(io.error_message(Error))
+ ).
+
+%---------------------------------------------------------------------------%
+
+:- some [R] pred init_random(maybe_error(R)::out, io::di, io::uo) is det
+ => random(R).
+
+init_random(Res, !IO) :-
+ open_system_rng(MaybeRNG, !IO),
+ (
+ MaybeRNG = ok(SystemRNG),
+ system_rng.generate_uint64(SystemRNG, A, !IO),
+ system_rng.generate_uint64(SystemRNG, B, !IO),
+ system_rng.generate_uint64(SystemRNG, C, !IO),
+ close_system_rng(SystemRNG, !IO),
+
+ sfc64.seed(A, B, C, Params, UState),
+ R = make_shared_random(Params, UState),
+ Res = ok(R)
+ ;
+ MaybeRNG = error(Error),
+ Res = error(Error)
+ ).
+
+:- pred generate_graph(int::in, digraph(string)::out,
+ R::in, R::out) is det <= random(R).
+
+generate_graph(Size, !:G, !R) :-
+ !:G = digraph.init,
+ generate_vertices(0, Size, [], RevKeys, !G),
+ array.from_reverse_list(RevKeys, KeysArray),
+
+ random.uniform_int_in_range(10, 30, Factor, !R),
+ NumEdges = Size * Factor / 10,
+
+ generate_edges(KeysArray, NumEdges, !G, !R).
+
+:- pred generate_vertices(int::in, int::in,
+ list(digraph_key(string))::in, list(digraph_key(string))::out,
+ digraph(string)::in, digraph(string)::out) is det.
+
+generate_vertices(I, Size, !RevKeys, !G) :-
+ ( if I >= Size then
+ true
+ else
+ generate_vertex(I, Key, !G),
+ !:RevKeys = [Key | !.RevKeys],
+ generate_vertices(I + 1, Size, !RevKeys, !G)
+ ).
+
+:- pred generate_vertex(int::in, digraph_key(string)::out,
+ digraph(string)::in, digraph(string)::out) is det.
+
+generate_vertex(N, Key, !G) :-
+ Name = "N" ++ string.from_int(N),
+ add_vertex(Name, Key, !G).
+
+:- pred generate_edges(array(digraph_key(string))::array_ui, int::in,
+ digraph(string)::in, digraph(string)::out,
+ R::in, R::out) is det <= random(R).
+
+generate_edges(KeysArray, RemEdges, !G, !R) :-
+ ( if RemEdges =< 0 then
+ true
+ else
+ generate_edge(KeysArray, !G, !R),
+ generate_edges(KeysArray, RemEdges - 1, !G, !R)
+ ).
+
+:- pred generate_edge(array(digraph_key(string))::array_ui,
+ digraph(string)::in, digraph(string)::out,
+ R::in, R::out) is det <= random(R).
+
+generate_edge(KeysArray, !G, !R) :-
+ array.size(KeysArray, NumKeys),
+ random.uniform_int_in_range(0, NumKeys, I, !R),
+ random.uniform_int_in_range(0, NumKeys, J, !R),
+ array.lookup(KeysArray, I, KeyI),
+ array.lookup(KeysArray, J, KeyJ),
+ digraph.add_edge(KeyI, KeyJ, !G).
+
+%---------------------------------------------------------------------------%
+
+:- pred test_graph(digraph(string)::in, bool::in, io::di, io::uo) is det.
+
+test_graph(G, Verbose, !IO) :-
+ tc(G, TC),
+ slow_tc(G, SlowTC),
+ rtc(G, RTC),
+ slow_rtc(G, SlowRTC),
+
+ io.print_line("---- G ----", !IO),
+ write_graph(G, !IO),
+ (
+ Verbose = yes,
+ io.print_line("---- tc(G) ----", !IO),
+ write_graph(TC, !IO),
+ io.print_line("---- slow_tc(G) ----", !IO),
+ write_graph(SlowTC, !IO),
+ io.print_line("---- rtc(G) ----", !IO),
+ write_graph(RTC, !IO),
+ io.print_line("---- slow_rtc(G) ----", !IO),
+ write_graph(SlowRTC, !IO)
+ ;
+ Verbose = no
+ ),
+
+ ( if same_graph(TC, SlowTC) then
+ true
+ else
+ io.write_string("** TC mismatch\n\n", !IO),
+ io.set_exit_status(1, !IO)
+ ),
+ ( if same_graph(RTC, SlowRTC) then
+ true
+ else
+ io.write_string("** RTC mismatch\n\n", !IO),
+ io.set_exit_status(1, !IO)
+ ).
+
+:- pred same_graph(digraph(T)::in, digraph(T)::in) is semidet.
+
+same_graph(A, B) :-
+ digraph.to_assoc_list(A, PairsA),
+ digraph.to_assoc_list(B, PairsB),
+ sort(PairsA, SortedPairsA),
+ sort(PairsB, SortedPairsB),
+ SortedPairsA = SortedPairsB.
+
+:- pred write_graph(digraph(string)::in, io::di, io::uo) is det.
+
+write_graph(G, !IO) :-
+ digraph.to_assoc_list(G, Edges),
+ io.write_string("digraph {\n", !IO),
+ io.format(" /* %d edges */\n", [i(length(Edges))], !IO),
+ list.foldl(write_edge, Edges, !IO),
+ io.write_string("}\n\n", !IO).
+
+:- pred write_edge(pair(string)::in, io::di, io::uo) is det.
+
+write_edge(A - B, !IO) :-
+ io.format(" %s -> %s;\n", [s(A), s(B)], !IO).
+
+%---------------------------------------------------------------------------%
--
2.39.0
More information about the reviews
mailing list