line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Graph::TransitiveClosure::Matrix; |
2
|
|
|
|
|
|
|
|
3
|
6
|
|
|
6
|
|
38
|
use strict; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
184
|
|
4
|
6
|
|
|
6
|
|
28
|
use warnings; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
154
|
|
5
|
|
|
|
|
|
|
|
6
|
6
|
|
|
6
|
|
2924
|
use Graph::AdjacencyMatrix; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
162
|
|
7
|
6
|
|
|
6
|
|
47
|
use Graph::Matrix; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
120
|
|
8
|
6
|
|
|
6
|
|
28
|
use Scalar::Util qw(weaken); |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
389
|
|
9
|
6
|
|
|
6
|
|
38
|
use List::Util qw(min); |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
9728
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
sub _A() { 0 } # adjacency |
12
|
|
|
|
|
|
|
sub _D() { 1 } # distance |
13
|
|
|
|
|
|
|
sub _S() { 2 } # successors |
14
|
|
|
|
|
|
|
sub _V() { 3 } # vertices |
15
|
|
|
|
|
|
|
sub _G() { 4 } # the original graph (OG) |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub _new { |
18
|
70
|
|
|
70
|
|
202
|
my ($g, $class, $am_opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices, $want_path_count) = @_; |
19
|
70
|
|
|
|
|
373
|
my $m = Graph::AdjacencyMatrix->new($g, %$am_opt); |
20
|
70
|
|
|
|
|
217
|
my @V = $g->vertices; |
21
|
70
|
|
|
|
|
144
|
my %v2i; @v2i{ @V } = 0..$#V; # paths are in array -> stable ordering |
|
70
|
|
|
|
|
385
|
|
22
|
70
|
|
|
|
|
248
|
my $am = $m->adjacency_matrix; |
23
|
70
|
|
|
|
|
214
|
$am->[1] = \%v2i; |
24
|
70
|
|
|
|
|
190
|
my ($dm, @di); # The distance matrix. |
25
|
70
|
|
|
|
|
0
|
my ($sm, @si); # The successor matrix. |
26
|
|
|
|
|
|
|
# directly use (not via API) arrays of bit-vectors etc for speed. |
27
|
|
|
|
|
|
|
# the API is so low-level it adds no clarity anyway |
28
|
70
|
|
|
|
|
107
|
my @ai = @{ $am->[0] }; |
|
70
|
|
|
|
|
263
|
|
29
|
70
|
|
|
|
|
194
|
my $multi = $g->multiedged; |
30
|
70
|
100
|
|
|
|
171
|
unless ($want_transitive) { |
31
|
60
|
|
66
|
|
|
188
|
$dm = $m->distance_matrix || Graph::Matrix->new($g); # if no distance_matrix in AM, we make our own |
32
|
60
|
100
|
|
|
|
136
|
if ($want_path_count) { |
33
|
|
|
|
|
|
|
# force defined |
34
|
1
|
|
|
|
|
9
|
@di = map [ (0) x @V ], 0..$#V; |
35
|
|
|
|
|
|
|
} else { |
36
|
59
|
|
|
|
|
85
|
@di = @{ $dm->[0] }; |
|
59
|
|
|
|
|
152
|
|
37
|
|
|
|
|
|
|
} |
38
|
60
|
|
|
|
|
179
|
$sm = Graph::Matrix->new($g); |
39
|
60
|
|
|
|
|
219
|
$dm->[1] = $sm->[1] = \%v2i; |
40
|
60
|
|
|
|
|
109
|
@si = @{ $sm->[0] }; |
|
60
|
|
|
|
|
147
|
|
41
|
60
|
|
|
|
|
208
|
for (my $iu = $#V; $iu >= 0; $iu--) { |
42
|
433
|
100
|
|
|
|
1128
|
vec($ai[$iu], $iu, 1) = 1 if $want_reflexive; |
43
|
433
|
|
|
|
|
1019
|
for (my $iv = $#V; $iv >= 0; $iv--) { |
44
|
16349
|
100
|
|
|
|
33497
|
next unless vec($ai[$iu], $iv, 1); |
45
|
1158
|
100
|
100
|
|
|
3848
|
if ($want_path_count or !defined $di[$iu][$iv]) { |
|
|
100
|
100
|
|
|
|
|
46
|
231
|
100
|
|
|
|
409
|
$di[$iu][$iv] = $iu == $iv ? 0 : 1; |
47
|
|
|
|
|
|
|
} elsif ($multi and ref($di[$iu][$iv]) eq 'HASH') { |
48
|
4
|
|
|
|
|
6
|
$di[$iu][$iv] = min values %{ $di[$iu][$iv] }; |
|
4
|
|
|
|
|
22
|
|
49
|
|
|
|
|
|
|
} |
50
|
1158
|
100
|
|
|
|
3018
|
$si[$iu]->[$iv] = $V[$iv] unless $iu == $iv; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
# naming here is u = start, v = midpoint, w = endpoint |
55
|
70
|
|
|
|
|
235
|
for (my $iv = $#V; $iv >= 0; $iv--) { |
56
|
462
|
|
|
|
|
698
|
my $div = $di[$iv]; |
57
|
462
|
|
|
|
|
660
|
my $aiv = $ai[$iv]; |
58
|
462
|
|
|
|
|
969
|
for (my $iu = $#V; $iu >= 0; $iu--) { |
59
|
16453
|
|
|
|
|
22309
|
my $aiu = $ai[$iu]; |
60
|
16453
|
100
|
|
|
|
33981
|
next if !vec($aiu, $iv, 1); |
61
|
1903
|
100
|
|
|
|
3090
|
if ($want_transitive) { |
62
|
55
|
|
|
|
|
101
|
for (my $iw = $#V; $iw >= 0; $iw--) { |
63
|
195
|
100
|
100
|
|
|
676
|
return 0 |
|
|
|
100
|
|
|
|
|
64
|
|
|
|
|
|
|
if $iw != $iv && |
65
|
|
|
|
|
|
|
vec($aiv, $iw, 1) && |
66
|
|
|
|
|
|
|
!vec($aiu, $iw, 1); |
67
|
|
|
|
|
|
|
} |
68
|
51
|
|
|
|
|
104
|
next; |
69
|
|
|
|
|
|
|
} |
70
|
1848
|
|
|
|
|
2451
|
my $aiuo = $aiu; |
71
|
1848
|
|
|
|
|
2598
|
$aiu |= $aiv; |
72
|
1848
|
100
|
|
|
|
3065
|
if ($aiu ne $aiuo) { |
73
|
933
|
|
|
|
|
1286
|
$ai[$iu] = $aiu; |
74
|
933
|
50
|
|
|
|
1619
|
$aiv = $aiu if $iv == $iu; |
75
|
|
|
|
|
|
|
} |
76
|
1848
|
100
|
|
|
|
2945
|
next if !$want_path; |
77
|
1828
|
|
|
|
|
2397
|
my $diu = $di[$iu]; |
78
|
1828
|
|
|
|
|
2476
|
my $d1a = $diu->[$iv]; |
79
|
1828
|
|
|
|
|
3601
|
for (my $iw = $#V; $iw >= 0; $iw--) { |
80
|
81355
|
100
|
|
|
|
157506
|
next unless vec($aiv, $iw, 1); |
81
|
24347
|
100
|
|
|
|
37432
|
if ($want_path_count) { |
82
|
13
|
100
|
100
|
|
|
38
|
$diu->[$iw]++ if $iu != $iv and $iv != $iw and $iw != $iu; |
|
|
|
66
|
|
|
|
|
83
|
13
|
|
|
|
|
24
|
next; |
84
|
|
|
|
|
|
|
} |
85
|
24334
|
|
|
|
|
30996
|
my $d0 = $diu->[$iw]; |
86
|
24334
|
|
|
|
|
30074
|
my $d1b = $div->[$iw]; |
87
|
24334
|
|
|
|
|
30757
|
my $d1 = $d1a + $d1b; |
88
|
24334
|
100
|
100
|
|
|
65477
|
if (!defined $d0 || ($d1 < $d0)) { |
89
|
|
|
|
|
|
|
# print "d1 = $d1a ($V[$iu], $V[$iv]) + $d1b ($V[$iv], $V[$iw]) = $d1 ($V[$iu], $V[$iw]) (".(defined$d0?$d0:"-").") (propagate=".($aiu ne $aiuo?1:0).")\n"; |
90
|
6729
|
|
|
|
|
9523
|
$diu->[$iw] = $d1; |
91
|
6729
|
100
|
|
|
|
18192
|
$si[$iu]->[$iw] = $si[$iu]->[$iv] |
92
|
|
|
|
|
|
|
if $want_path_vertices; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
} |
97
|
66
|
100
|
|
|
|
259
|
return 1 if $want_transitive; |
98
|
60
|
|
|
|
|
115
|
my %V; @V{ @V } = @V; |
|
60
|
|
|
|
|
455
|
|
99
|
60
|
|
|
|
|
231
|
$am->[0] = \@ai; |
100
|
60
|
50
|
|
|
|
191
|
$dm->[0] = \@di if defined $dm; |
101
|
60
|
50
|
|
|
|
209
|
$sm->[0] = \@si if defined $sm; |
102
|
60
|
|
|
|
|
257
|
weaken(my $og = $g); |
103
|
60
|
|
|
|
|
730
|
bless [ $am, $dm, $sm, \%V, $og ], $class; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub new { |
107
|
70
|
|
|
70
|
1
|
247
|
my ($class, $g, %opt) = @_; |
108
|
70
|
|
|
|
|
211
|
my %am_opt = (distance_matrix => 1); |
109
|
|
|
|
|
|
|
$am_opt{attribute_name} = delete $opt{attribute_name} |
110
|
70
|
100
|
|
|
|
187
|
if exists $opt{attribute_name}; |
111
|
|
|
|
|
|
|
$am_opt{distance_matrix} = delete $opt{distance_matrix} |
112
|
70
|
50
|
|
|
|
155
|
if $opt{distance_matrix}; |
113
|
|
|
|
|
|
|
$opt{path_length} = $opt{path_vertices} = delete $opt{path} |
114
|
70
|
100
|
|
|
|
232
|
if exists $opt{path}; |
115
|
70
|
|
|
|
|
137
|
my $want_path_length = delete $opt{path_length}; |
116
|
70
|
|
|
|
|
117
|
my $want_path_count = delete $opt{path_count}; |
117
|
70
|
|
|
|
|
108
|
my $want_path_vertices = delete $opt{path_vertices}; |
118
|
70
|
|
|
|
|
110
|
my $want_reflexive = delete $opt{reflexive}; |
119
|
|
|
|
|
|
|
$am_opt{is_transitive} = my $want_transitive = delete $opt{is_transitive} |
120
|
70
|
100
|
|
|
|
175
|
if exists $opt{is_transitive}; |
121
|
70
|
|
|
|
|
223
|
Graph::_opt_unknown(\%opt); |
122
|
70
|
100
|
|
|
|
163
|
$want_reflexive = 1 unless defined $want_reflexive; |
123
|
70
|
|
66
|
|
|
279
|
my $want_path = $want_path_length || $want_path_vertices || $want_path_count; |
124
|
|
|
|
|
|
|
# $g->expect_dag if $want_path; |
125
|
70
|
100
|
|
|
|
173
|
$am_opt{distance_matrix} = 0 if $want_path_count; |
126
|
70
|
|
|
|
|
180
|
_new($g, $class, |
127
|
|
|
|
|
|
|
\%am_opt, |
128
|
|
|
|
|
|
|
$want_transitive, $want_reflexive, |
129
|
|
|
|
|
|
|
$want_path, $want_path_vertices, $want_path_count); |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub has_vertices { |
133
|
17238
|
|
|
17238
|
1
|
23047
|
my $tc = shift; |
134
|
17238
|
|
|
|
|
27584
|
for my $v (@_) { |
135
|
34470
|
100
|
|
|
|
68750
|
return 0 unless exists $tc->[ _V ]->{ $v }; |
136
|
|
|
|
|
|
|
} |
137
|
17229
|
|
|
|
|
31595
|
return 1; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub is_reachable { |
141
|
13854
|
|
|
13854
|
1
|
24661
|
my ($tc, $u, $v) = @_; |
142
|
13854
|
100
|
|
|
|
23537
|
return undef unless $tc->has_vertices($u, $v); |
143
|
13848
|
100
|
|
|
|
26554
|
return 1 if $u eq $v; |
144
|
12994
|
|
|
|
|
27368
|
$tc->[ _A ]->get($u, $v); |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub is_transitive { |
148
|
16
|
100
|
|
16
|
1
|
60
|
return __PACKAGE__->new($_[0], is_transitive => 1) if @_ == 1; # Any graph |
149
|
|
|
|
|
|
|
# A TC graph |
150
|
6
|
|
|
|
|
15
|
my ($tc, $u, $v) = @_; |
151
|
6
|
50
|
|
|
|
16
|
return undef unless $tc->has_vertices($u, $v); |
152
|
6
|
|
|
|
|
24
|
$tc->[ _A ]->get($u, $v); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub vertices { |
156
|
599
|
|
|
599
|
1
|
862
|
my $tc = shift; |
157
|
599
|
|
|
|
|
797
|
values %{ $tc->[3] }; |
|
599
|
|
|
|
|
3916
|
|
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub path_length { |
161
|
3007
|
|
|
3007
|
1
|
5041
|
my ($tc, $u, $v) = @_; |
162
|
3007
|
100
|
|
|
|
4954
|
return undef unless $tc->has_vertices($u, $v); |
163
|
3004
|
100
|
|
|
|
5959
|
return 0 if $u eq $v; |
164
|
2748
|
|
|
|
|
5846
|
$tc->[ _D ]->get($u, $v); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub path_successor { |
168
|
380
|
|
|
380
|
1
|
741
|
my ($tc, $u, $v) = @_; |
169
|
380
|
100
|
|
|
|
712
|
return undef if $u eq $v; |
170
|
371
|
50
|
|
|
|
672
|
return undef unless $tc->has_vertices($u, $v); |
171
|
371
|
|
|
|
|
899
|
$tc->[ _S ]->get($u, $v); |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
sub path_vertices { |
175
|
267
|
|
|
267
|
1
|
570
|
my ($tc, $u, $v) = @_; |
176
|
267
|
100
|
|
|
|
563
|
return unless $tc->is_reachable($u, $v); |
177
|
252
|
100
|
|
|
|
767
|
return wantarray ? () : 0 if $u eq $v; |
|
|
100
|
|
|
|
|
|
178
|
207
|
|
|
|
|
431
|
my @v = ( $u ); |
179
|
207
|
|
|
|
|
482
|
while ($u ne $v) { |
180
|
353
|
50
|
|
|
|
712
|
last unless defined($u = $tc->path_successor($u, $v)); |
181
|
353
|
|
|
|
|
929
|
push @v, $u; |
182
|
|
|
|
|
|
|
} |
183
|
207
|
50
|
|
|
|
920
|
$tc->[ _S ]->set($u, $v, [ @v ]) if @v; |
184
|
207
|
|
|
|
|
999
|
return @v; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
sub all_paths { |
188
|
29
|
|
|
29
|
1
|
69
|
my ($tc, $u, $v, $seen) = @_; |
189
|
29
|
50
|
|
|
|
94
|
return if $u eq $v; |
190
|
29
|
|
100
|
|
|
108
|
$seen ||= {}; |
191
|
29
|
100
|
|
|
|
62
|
return if exists $seen->{$u}; |
192
|
28
|
|
|
|
|
105
|
$seen = { %$seen, $u => undef }; # accumulate, but don't mutate |
193
|
28
|
|
|
|
|
44
|
my @found; |
194
|
28
|
100
|
|
|
|
84
|
push @found, [$u, $v] if $tc->[ _G ]->has_edge($u, $v); |
195
|
28
|
|
100
|
|
|
98
|
push @found, |
196
|
|
|
|
|
|
|
map [$u, @$_], |
197
|
|
|
|
|
|
|
map $tc->all_paths($_, $v, $seen), |
198
|
|
|
|
|
|
|
grep $tc->is_reachable($_, $v), |
199
|
|
|
|
|
|
|
grep $_ ne $v && $_ ne $u, $tc->[ _G ]->successors($u); |
200
|
28
|
|
|
|
|
142
|
@found; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
1; |
204
|
|
|
|
|
|
|
__END__ |