File Coverage

blib/lib/Graph/BitMatrix.pm
Criterion Covered Total %
statement 62 62 100.0
branch 16 22 72.7
condition n/a
subroutine 13 13 100.0
pod 8 9 88.8
total 99 106 93.4


line stmt bran cond sub pod time code
1             package Graph::BitMatrix;
2              
3 8     8   552 use strict;
  8         16  
  8         216  
4 8     8   36 use warnings;
  8         17  
  8         7405  
5              
6             # $SIG{__DIE__ } = \&Graph::__carp_confess;
7             # $SIG{__WARN__} = \&Graph::__carp_confess;
8              
9             sub _E () { 3 } # Graph::_E()
10             sub _i () { 3 } # Index to path.
11              
12             sub new {
13 78     78 1 206 my ($class, $g, %opt) = @_;
14 78         248 my @V = $g->vertices;
15 78         145 my $V = @V;
16 78         269 my $Z = "\0" x (($V + 7) / 8);
17 78         128 my %V; @V{ @V } = 0 .. $#V;
  78         380  
18 78         392 my $bm = bless [ [ ( $Z ) x $V ], \%V ], $class;
19 78         165 my $bm0 = $bm->[0];
20 78         141 my $connect_edges = delete $opt{connect_edges};
21 78 50       201 $connect_edges = 1 unless defined $connect_edges;
22 78         129 my $transpose = delete $opt{transpose};
23 78         212 Graph::_opt_unknown(\%opt);
24 77 50       191 return $bm if !$connect_edges;
25             # for (my $i = 0; $i <= $#V; $i++) {
26             # my $u = $V[$i];
27             # for (my $j = 0; $j <= $#V; $j++) {
28             # vec($bm0->[$i], $j, 1) = 1 if $g->has_edge($u, $V[$j]);
29             # }
30             # }
31 77         231 my $undirected = $g->is_undirected;
32 77         288 for my $e ($g->edges) {
33 712         1637 my ($i0, $j0) = map $V{$_}, @$e;
34 712 100       1253 ($j0, $i0) = ($i0, $j0) if $transpose;
35 712         1344 vec($bm0->[$i0], $j0, 1) = 1;
36 712 100       1550 vec($bm0->[$j0], $i0, 1) = 1 if $undirected;
37             }
38 77         412 $bm;
39             }
40              
41             sub stringify {
42 3     3 0 11 my ($m) = @_;
43 3         9 my @V = sort keys %{ $m->[1] };
  3         28  
44 3         34 my $top = join ' ', map sprintf('%4s', $_), 'to:', @V;
45 3         18 my @indices = map $m->[1]{$_}, @V;
46 3         5 my @rows;
47 3         9 for my $n (@V) {
48 16         41 my @vals = $m->get_row($n, @V);
49 16 50       160 push @rows, join ' ', map sprintf('%4s', defined()?$_:''), $n, @vals;
50             }
51 3         57 join '', map "$_\n", $top, @rows;
52             }
53              
54 1     1 1 4 sub set { push @_, 1; goto &_get_set }
  1         4  
55 1     1 1 4 sub unset { push @_, 0; goto &_get_set }
  1         3  
56 13021     13021 1 19485 sub get { push @_, undef; goto &_get_set }
  13021         26019  
57             sub _get_set {
58 13023     13023   17186 my $val = pop;
59 13023         21342 my ($m, $u, $v) = @_;
60 13023         19969 my ($m0, $m1) = @$m[0, 1];
61 13023 100       37225 return if grep !defined, my ($i, $j) = @$m1{ $u, $v };
62 13022 100       36916 defined $val ? vec($m0->[$i], $j, 1) = $val : vec($m0->[$i], $j, 1);
63             }
64              
65             sub _set_row {
66 2     2   4 my $val = pop;
67 2         6 my ($m, $u) = splice @_, 0, 2;
68 2         6 my ($m0, $m1) = @$m[0, 1];
69 2 50       7 return unless defined(my $i = $m1->{ $u });
70 2         18 vec($m0->[$i], $_, 1) = $val for grep defined, @$m1{ @_ };
71             }
72 1     1 1 4 sub set_row { push @_, 1; goto &_set_row }
  1         4  
73 1     1 1 4 sub unset_row { push @_, 0; goto &_set_row }
  1         5  
74              
75             sub get_row {
76 22     22 1 46 my ($m, $u) = splice @_, 0, 2;
77 22         40 my ($m0, $m1) = @$m[0, 1];
78 22 50       53 return () x @_ unless defined(my $i = $m1->{ $u });
79 22 100       214 map defined() ? (vec($m0->[$i], $_, 1) ? 1 : 0) : undef, @$m1{ @_ };
    50          
80             }
81              
82             sub vertices {
83 3     3 1 1289 keys %{ $_[0]->[1] };
  3         34  
84             }
85              
86             1;
87             __END__