The unpac monorepo manager self-hosting as a monorepo using unpac
fixed Dfs.fold and Dfs.fold_component
these were embarassingly not depth-first traversal
see https://11011110.github.io/blog/2013/12/17/stack-based-graph-traversal.html
for an explanation
+100
-18
+3
CHANGES.md
+3
CHANGES.md
···
1
1
2
+
3
+
- :exclamation: [Traverse]: fixed [Dfs.fold] and [Dfs.fold_component],
4
+
which were not implementing a proper DFS
2
5
- [Classic]: new functions [cycle] and [grid]
3
6
- [Eulerian]: Eulerian paths (new module)
4
7
- [Components]: strong articulation points (see functors [Connectivity]
+19
-18
src/traverse.ml
+19
-18
src/traverse.ml
···
31
31
module Dfs(G : G) = struct
32
32
module H = Hashtbl.Make(G.V)
33
33
34
-
let fold f i g =
34
+
let fold f acc g =
35
35
let h = H.create 97 in
36
36
let s = Stack.create () in
37
-
let push v =
38
-
if not (H.mem h v) then begin H.add h v (); Stack.push v s end
39
-
in
40
37
let rec loop acc =
41
38
if not (Stack.is_empty s) then
42
39
let v = Stack.pop s in
43
-
let ns = f v acc in
44
-
G.iter_succ push g v;
45
-
loop ns
40
+
if not (H.mem h v) then begin
41
+
H.add h v ();
42
+
let acc = f v acc in
43
+
G.iter_succ (fun w -> Stack.push w s) g v;
44
+
loop acc
45
+
end else
46
+
loop acc
46
47
else
47
48
acc
48
49
in
49
-
G.fold_vertex (fun v s -> push v; loop s) g i
50
+
G.fold_vertex (fun v acc -> Stack.push v s; loop acc) g acc
50
51
51
52
let iter ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g =
52
53
let h = H.create 97 in
···
62
63
63
64
let postfix post g = iter ~post g
64
65
65
-
let fold_component f i g v0 =
66
+
let fold_component f acc g v0 =
66
67
let h = H.create 97 in
67
68
let s = Stack.create () in
68
-
(* invariant: [h] contains exactly the vertices which have been pushed *)
69
-
let push v =
70
-
if not (H.mem h v) then begin H.add h v (); Stack.push v s end
71
-
in
72
-
push v0;
69
+
Stack.push v0 s;
73
70
let rec loop acc =
74
71
if not (Stack.is_empty s) then
75
72
let v = Stack.pop s in
76
-
let ns = f v acc in
77
-
G.iter_succ push g v;
78
-
loop ns
73
+
if not (H.mem h v) then begin
74
+
H.add h v ();
75
+
let acc = f v acc in
76
+
G.iter_succ (fun w -> Stack.push w s) g v;
77
+
loop acc
78
+
end else
79
+
loop acc
79
80
else
80
81
acc
81
82
in
82
-
loop i
83
+
loop acc
83
84
84
85
let iter_component ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g v =
85
86
let h = H.create 97 in
+5
tests/dune
+5
tests/dune
+73
tests/test_dfs.ml
+73
tests/test_dfs.ml
···
1
+
2
+
(* Stack-based DFS is tricky to get right. See
3
+
https://11011110.github.io/blog/2013/12/17/stack-based-graph-traversal.html
4
+
5
+
On this graph,
6
+
7
+
0
8
+
/ \
9
+
/ \
10
+
v v
11
+
1---2---3 (All edges are undirected,
12
+
|\ /| apart from 0->1 0->3 1->5 and 3->6.)
13
+
| \ / |
14
+
| 4 |
15
+
| / \ |
16
+
v / \ v
17
+
5 6
18
+
19
+
an incorrect stack-based DFS starting from 0 would first mark 1 and 3,
20
+
and then would not go as deep as possible in the traversal.
21
+
22
+
In the following, we check that, whenever 2 and 4 are visited,
23
+
then necessarily both 1 and 3 are already visited.
24
+
*)
25
+
26
+
open Format
27
+
open Graph
28
+
open Pack.Digraph
29
+
30
+
let debug = false
31
+
32
+
let g = create ()
33
+
let v = Array.init 7 V.create
34
+
let () = Array.iter (add_vertex g) v
35
+
let adde x y = add_edge g v.(x) v.(y)
36
+
let addu x y = adde x y; adde y x
37
+
let () = adde 0 1; adde 0 3
38
+
let () = addu 1 2; addu 2 3
39
+
let () = adde 1 5; adde 3 6
40
+
let () = addu 1 4; addu 4 3; addu 5 4; addu 4 6
41
+
42
+
let () = assert (Dfs.has_cycle g)
43
+
44
+
let marked = Array.make 7 false
45
+
let reset () = Array.fill marked 0 7 false
46
+
let mark v =
47
+
let i = V.label v in
48
+
marked.(i) <- true;
49
+
if marked.(2) && marked.(4) then assert (marked.(1) && marked.(3))
50
+
51
+
let pre v = if debug then printf "pre %d@." (V.label v); mark v
52
+
let post v = if debug then printf "post %d@." (V.label v)
53
+
let f v () = if debug then printf "fold %d@." (V.label v); mark v
54
+
55
+
let () = reset (); Dfs.iter ~pre ~post g
56
+
let () = reset (); Dfs.prefix pre g
57
+
let () = reset (); Dfs.postfix post g
58
+
let () = reset (); Dfs.iter_component ~pre ~post g v.(0)
59
+
let () = reset (); Dfs.prefix_component pre g v.(0)
60
+
let () = reset (); Dfs.postfix_component post g v.(0)
61
+
let () = reset (); Dfs.fold f () g
62
+
let () = reset (); Dfs.fold_component f () g v.(0)
63
+
64
+
module D = Traverse.Dfs(Pack.Digraph)
65
+
66
+
let rec visit it =
67
+
let v = D.get it in
68
+
mark v;
69
+
visit (D.step it)
70
+
71
+
let () = try visit (D.start g) with Exit -> ()
72
+
73
+
let () = printf "All tests succeeded.@."