1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
open Viz_types
let is_neighbor n =
match n.kind with
| NEIGHBOUR_IN
| NEIGHBOUR_OUT -> true
| _ -> false
let all_children_neighbors g n =
let rec proc acc = function
| [] -> acc
| (_, PARENT) :: tl -> proc acc tl
| (id, CHILD) :: tl ->
match
try Some (is_neighbor (NodeMap.find id g))
with Not_found -> None
with
| Some true -> proc (id :: acc) tl
| Some false -> []
| None -> proc acc tl in
proc [] n.family
let get_neighbors_of_leaves g =
NodeMap.fold
(fun id node acc ->
if is_neighbor node
then acc
else
(all_children_neighbors g node) @ acc)
g
[]
let explore get_children f start_node =
let rec explore_rec explored q =
match Q.pop q with
| None ->
()
| Some (node, tl) when IdSet.mem node explored ->
explore_rec explored tl
| Some (node, tl) ->
let explored = IdSet.add node explored in
match f node with
| `REJECT ->
explore_rec explored tl
| `CONTINUE ->
explore_rec explored
(get_children node tl) in
explore_rec
IdSet.empty
(get_children start_node Q.empty)
exception Found of string
let reconnect fetch_children agraph =
let disconnection_points = get_neighbors_of_leaves agraph.nodes in
if Viz_misc.debug "comp" then begin
Viz_misc.log "comp"
"disconnection points (%d):\n %s"
(List.length disconnection_points)
(String.concat "\n " disconnection_points)
end ;
let get_children id q = fetch_children id Q.push q in
let with_spanning_edges =
List.fold_left
(fun acc id ->
match
try
explore
get_children
(fun id ->
try
let n = NodeMap.find id agraph.nodes in
if n.kind = NEIGHBOUR_IN
then raise (Found id) ;
`REJECT
with Not_found -> `CONTINUE)
id ;
None
with Found target ->
Viz_misc.log "comp"
"found an edge: %s -> %s" id target ;
Some (id, target)
with
| None -> acc
| Some edge -> EdgeMap.add edge SPANNING acc)
agraph.ancestry
disconnection_points in
{ agraph with ancestry = with_spanning_edges }
|
