File Coverage

blib/lib/Graph/TransitiveClosure/Matrix.pm
Criterion Covered Total %
statement 142 142 100.0
branch 81 90 90.0
condition 29 32 90.6
subroutine 16 16 100.0
pod 9 9 100.0
total 277 289 95.8


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__