Filename | /Users/ap13/perl5/lib/perl5/Graph/TransitiveClosure/Matrix.pm |
Statements | Executed 7 statements in 1.51ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 745µs | 2.66ms | BEGIN@5 | Graph::TransitiveClosure::Matrix::
1 | 1 | 1 | 12µs | 25µs | BEGIN@3 | Graph::TransitiveClosure::Matrix::
1 | 1 | 1 | 7µs | 7µs | BEGIN@6 | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | _new | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | has_vertices | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | is_reachable | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | is_transitive | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | new | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | path_length | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | path_predecessor | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | path_vertices | Graph::TransitiveClosure::Matrix::
0 | 0 | 0 | 0s | 0s | vertices | Graph::TransitiveClosure::Matrix::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Graph::TransitiveClosure::Matrix; | ||||
2 | |||||
3 | 2 | 23µs | 2 | 37µ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 # spent 25µs making 1 call to Graph::TransitiveClosure::Matrix::BEGIN@3
# spent 12µs making 1 call to strict::import |
4 | |||||
5 | 2 | 112µs | 1 | 2.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 # spent 2.66ms making 1 call to Graph::TransitiveClosure::Matrix::BEGIN@5 |
6 | 2 | 1.37ms | 1 | 7µ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 # spent 7µs making 1 call to Graph::TransitiveClosure::Matrix::BEGIN@6 |
7 | |||||
8 | sub _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 | |||||
213 | sub 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 | |||||
261 | sub has_vertices { | ||||
262 | my $tc = shift; | ||||
263 | for my $v (@_) { | ||||
264 | return 0 unless exists $tc->[3]->{ $v }; | ||||
265 | } | ||||
266 | return 1; | ||||
267 | } | ||||
268 | |||||
269 | sub 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 | |||||
276 | sub 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 | |||||
286 | sub vertices { | ||||
287 | my $tc = shift; | ||||
288 | values %{ $tc->[3] }; | ||||
289 | } | ||||
290 | |||||
291 | sub 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 | |||||
298 | sub 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 | |||||
305 | sub 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 | |||||
318 | 1 | 4µs | 1; | ||
319 | __END__ |