← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/pan_genome_post_analysis
  Run on Fri Mar 27 11:43:32 2015
Reported on Fri Mar 27 11:46:16 2015

Filename/Users/ap13/perl5/lib/perl5/Graph/TransitiveClosure/Matrix.pm
StatementsExecuted 7 statements in 1.51ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111745µs2.66msGraph::TransitiveClosure::Matrix::::BEGIN@5Graph::TransitiveClosure::Matrix::BEGIN@5
11112µs25µsGraph::TransitiveClosure::Matrix::::BEGIN@3Graph::TransitiveClosure::Matrix::BEGIN@3
1117µs7µsGraph::TransitiveClosure::Matrix::::BEGIN@6Graph::TransitiveClosure::Matrix::BEGIN@6
0000s0sGraph::TransitiveClosure::Matrix::::_newGraph::TransitiveClosure::Matrix::_new
0000s0sGraph::TransitiveClosure::Matrix::::has_verticesGraph::TransitiveClosure::Matrix::has_vertices
0000s0sGraph::TransitiveClosure::Matrix::::is_reachableGraph::TransitiveClosure::Matrix::is_reachable
0000s0sGraph::TransitiveClosure::Matrix::::is_transitiveGraph::TransitiveClosure::Matrix::is_transitive
0000s0sGraph::TransitiveClosure::Matrix::::newGraph::TransitiveClosure::Matrix::new
0000s0sGraph::TransitiveClosure::Matrix::::path_lengthGraph::TransitiveClosure::Matrix::path_length
0000s0sGraph::TransitiveClosure::Matrix::::path_predecessorGraph::TransitiveClosure::Matrix::path_predecessor
0000s0sGraph::TransitiveClosure::Matrix::::path_verticesGraph::TransitiveClosure::Matrix::path_vertices
0000s0sGraph::TransitiveClosure::Matrix::::verticesGraph::TransitiveClosure::Matrix::vertices
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Graph::TransitiveClosure::Matrix;
2
3223µs237µs
# spent 25µs (12+12) within Graph::TransitiveClosure::Matrix::BEGIN@3 which was called: # once (12µs+12µs) by Graph::TransitiveClosure::BEGIN@10 at line 3
use strict;
# spent 25µs making 1 call to Graph::TransitiveClosure::Matrix::BEGIN@3 # spent 12µs making 1 call to strict::import
4
52112µs12.66ms
# spent 2.66ms (745µs+1.91) within Graph::TransitiveClosure::Matrix::BEGIN@5 which was called: # once (745µs+1.91ms) by Graph::TransitiveClosure::BEGIN@10 at line 5
use Graph::AdjacencyMatrix;
# spent 2.66ms making 1 call to Graph::TransitiveClosure::Matrix::BEGIN@5
621.37ms17µs
# spent 7µs within Graph::TransitiveClosure::Matrix::BEGIN@6 which was called: # once (7µs+0s) by Graph::TransitiveClosure::BEGIN@10 at line 6
use Graph::Matrix;
# spent 7µs making 1 call to Graph::TransitiveClosure::Matrix::BEGIN@6
7
8sub _new {
9 my ($g, $class, $opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices) = @_;
10 my $m = Graph::AdjacencyMatrix->new($g, %$opt);
11 my @V = $g->vertices;
12 my $am = $m->adjacency_matrix;
13 my $dm; # The distance matrix.
14 my $pm; # The predecessor matrix.
15 my @di;
16 my %di; @di{ @V } = 0..$#V;
17 my @ai = @{ $am->[0] };
18 my %ai = %{ $am->[1] };
19 my @pi;
20 my %pi;
21 unless ($want_transitive) {
22 $dm = $m->distance_matrix;
23 @di = @{ $dm->[0] };
24 %di = %{ $dm->[1] };
25 $pm = Graph::Matrix->new($g);
26 @pi = @{ $pm->[0] };
27 %pi = %{ $pm->[1] };
28 for my $u (@V) {
29 my $diu = $di{$u};
30 my $aiu = $ai{$u};
31 for my $v (@V) {
32 my $div = $di{$v};
33 my $aiv = $ai{$v};
34 next unless
35 # $am->get($u, $v)
36 vec($ai[$aiu], $aiv, 1)
37 ;
38 # $dm->set($u, $v, $u eq $v ? 0 : 1)
39 $di[$diu]->[$div] = $u eq $v ? 0 : 1
40 unless
41 defined
42 # $dm->get($u, $v)
43 $di[$diu]->[$div]
44 ;
45 $pi[$diu]->[$div] = $v unless $u eq $v;
46 }
47 }
48 }
49 # XXX (see the bits below): sometimes, being nice and clean is the
50 # wrong thing to do. In this case, using the public API for graph
51 # transitive matrices and bitmatrices makes things awfully slow.
52 # Instead, we go straight for the jugular of the data structures.
53 for my $u (@V) {
54 my $diu = $di{$u};
55 my $aiu = $ai{$u};
56 my $didiu = $di[$diu];
57 my $aiaiu = $ai[$aiu];
58 for my $v (@V) {
59 my $div = $di{$v};
60 my $aiv = $ai{$v};
61 my $didiv = $di[$div];
62 my $aiaiv = $ai[$aiv];
63 if (
64 # $am->get($v, $u)
65 vec($aiaiv, $aiu, 1)
66 || ($want_reflexive && $u eq $v)) {
67 my $aivivo = $aiaiv;
68 if ($want_transitive) {
69 if ($want_reflexive) {
70 for my $w (@V) {
71 next if $w eq $u;
72 my $aiw = $ai{$w};
73 return 0
74 if vec($aiaiu, $aiw, 1) &&
75 !vec($aiaiv, $aiw, 1);
76 }
77 # See XXX above.
78 # for my $w (@V) {
79 # my $aiw = $ai{$w};
80 # if (
81 # # $am->get($u, $w)
82 # vec($aiaiu, $aiw, 1)
83 # || ($u eq $w)) {
84 # return 0
85 # if $u ne $w &&
86 # # !$am->get($v, $w)
87 # !vec($aiaiv, $aiw, 1)
88 # ;
89 # # $am->set($v, $w)
90 # vec($aiaiv, $aiw, 1) = 1
91 # ;
92 # }
93 # }
94 } else {
95 # See XXX above.
96 # for my $w (@V) {
97 # my $aiw = $ai{$w};
98 # if (
99 # # $am->get($u, $w)
100 # vec($aiaiu, $aiw, 1)
101 # ) {
102 # return 0
103 # if $u ne $w &&
104 # # !$am->get($v, $w)
105 # !vec($aiaiv, $aiw, 1)
106 # ;
107 # # $am->set($v, $w)
108 # vec($aiaiv, $aiw, 1) = 1
109 # ;
110 # }
111 # }
112 $aiaiv |= $aiaiu;
113 }
114 } else {
115 if ($want_reflexive) {
116 $aiaiv |= $aiaiu;
117 vec($aiaiv, $aiu, 1) = 1;
118 # See XXX above.
119 # for my $w (@V) {
120 # my $aiw = $ai{$w};
121 # if (
122 # # $am->get($u, $w)
123 # vec($aiaiu, $aiw, 1)
124 # || ($u eq $w)) {
125 # # $am->set($v, $w)
126 # vec($aiaiv, $aiw, 1) = 1
127 # ;
128 # }
129 # }
130 } else {
131 $aiaiv |= $aiaiu;
132 # See XXX above.
133 # for my $w (@V) {
134 # my $aiw = $ai{$w};
135 # if (
136 # # $am->get($u, $w)
137 # vec($aiaiu, $aiw, 1)
138 # ) {
139 # # $am->set($v, $w)
140 # vec($aiaiv, $aiw, 1) = 1
141 # ;
142 # }
143 # }
144 }
145 }
146 if ($aiaiv ne $aivivo) {
147 $ai[$aiv] = $aiaiv;
148 $aiaiu = $aiaiv if $u eq $v;
149 }
150 }
151 if ($want_path && !$want_transitive) {
152 for my $w (@V) {
153 my $aiw = $ai{$w};
154 next unless
155 # See XXX above.
156 # $am->get($v, $u)
157 vec($aiaiv, $aiu, 1)
158 &&
159 # See XXX above.
160 # $am->get($u, $w)
161 vec($aiaiu, $aiw, 1)
162 ;
163 my $diw = $di{$w};
164 my ($d0, $d1a, $d1b);
165 if (defined $dm) {
166 # See XXX above.
167 # $d0 = $dm->get($v, $w);
168 # $d1a = $dm->get($v, $u) || 1;
169 # $d1b = $dm->get($u, $w) || 1;
170 $d0 = $didiv->[$diw];
171 $d1a = $didiv->[$diu] || 1;
172 $d1b = $didiu->[$diw] || 1;
173 } else {
174 $d1a = 1;
175 $d1b = 1;
176 }
177 my $d1 = $d1a + $d1b;
178 if (!defined $d0 || ($d1 < $d0)) {
179 # print "d1 = $d1a ($v, $u) + $d1b ($u, $w) = $d1 ($v, $w) (".(defined$d0?$d0:"-").")\n";
180 # See XXX above.
181 # $dm->set($v, $w, $d1);
182 $didiv->[$diw] = $d1;
183 $pi[$div]->[$diw] = $pi[$div]->[$diu]
184 if $want_path_vertices;
185 }
186 }
187 # $dm->set($u, $v, 1)
188 $didiu->[$div] = 1
189 if $u ne $v &&
190 # $am->get($u, $v)
191 vec($aiaiu, $aiv, 1)
192 &&
193 # !defined $dm->get($u, $v);
194 !defined $didiu->[$div];
195 }
196 }
197 }
198 return 1 if $want_transitive;
199 my %V; @V{ @V } = @V;
200 $am->[0] = \@ai;
201 $am->[1] = \%ai;
202 if (defined $dm) {
203 $dm->[0] = \@di;
204 $dm->[1] = \%di;
205 }
206 if (defined $pm) {
207 $pm->[0] = \@pi;
208 $pm->[1] = \%pi;
209 }
210 bless [ $am, $dm, $pm, \%V ], $class;
211}
212
213sub new {
214 my ($class, $g, %opt) = @_;
215 my %am_opt = (distance_matrix => 1);
216 if (exists $opt{attribute_name}) {
217 $am_opt{attribute_name} = $opt{attribute_name};
218 delete $opt{attribute_name};
219 }
220 if ($opt{distance_matrix}) {
221 $am_opt{distance_matrix} = $opt{distance_matrix};
222 }
223 delete $opt{distance_matrix};
224 if (exists $opt{path}) {
225 $opt{path_length} = $opt{path};
226 $opt{path_vertices} = $opt{path};
227 delete $opt{path};
228 }
229 my $want_path_length;
230 if (exists $opt{path_length}) {
231 $want_path_length = $opt{path_length};
232 delete $opt{path_length};
233 }
234 my $want_path_vertices;
235 if (exists $opt{path_vertices}) {
236 $want_path_vertices = $opt{path_vertices};
237 delete $opt{path_vertices};
238 }
239 my $want_reflexive;
240 if (exists $opt{reflexive}) {
241 $want_reflexive = $opt{reflexive};
242 delete $opt{reflexive};
243 }
244 my $want_transitive;
245 if (exists $opt{is_transitive}) {
246 $want_transitive = $opt{is_transitive};
247 $am_opt{is_transitive} = $want_transitive;
248 delete $opt{is_transitive};
249 }
250 die "Graph::TransitiveClosure::Matrix::new: Unknown options: @{[map { qq['$_' => $opt{$_}]} keys %opt]}"
251 if keys %opt;
252 $want_reflexive = 1 unless defined $want_reflexive;
253 my $want_path = $want_path_length || $want_path_vertices;
254 # $g->expect_dag if $want_path;
255 _new($g, $class,
256 \%am_opt,
257 $want_transitive, $want_reflexive,
258 $want_path, $want_path_vertices);
259}
260
261sub has_vertices {
262 my $tc = shift;
263 for my $v (@_) {
264 return 0 unless exists $tc->[3]->{ $v };
265 }
266 return 1;
267}
268
269sub is_reachable {
270 my ($tc, $u, $v) = @_;
271 return undef unless $tc->has_vertices($u, $v);
272 return 1 if $u eq $v;
273 $tc->[0]->get($u, $v);
274}
275
276sub is_transitive {
277 if (@_ == 1) { # Any graph.
278 __PACKAGE__->new($_[0], is_transitive => 1); # Scary.
279 } else { # A TC graph.
280 my ($tc, $u, $v) = @_;
281 return undef unless $tc->has_vertices($u, $v);
282 $tc->[0]->get($u, $v);
283 }
284}
285
286sub vertices {
287 my $tc = shift;
288 values %{ $tc->[3] };
289}
290
291sub path_length {
292 my ($tc, $u, $v) = @_;
293 return undef unless $tc->has_vertices($u, $v);
294 return 0 if $u eq $v;
295 $tc->[1]->get($u, $v);
296}
297
298sub path_predecessor {
299 my ($tc, $u, $v) = @_;
300 return undef if $u eq $v;
301 return undef unless $tc->has_vertices($u, $v);
302 $tc->[2]->get($u, $v);
303}
304
305sub path_vertices {
306 my ($tc, $u, $v) = @_;
307 return unless $tc->is_reachable($u, $v);
308 return wantarray ? () : 0 if $u eq $v;
309 my @v = ( $u );
310 while ($u ne $v) {
311 last unless defined($u = $tc->path_predecessor($u, $v));
312 push @v, $u;
313 }
314 $tc->[2]->set($u, $v, [ @v ]) if @v;
315 return @v;
316}
317
31814µs1;
319__END__