File Coverage

blib/lib/Graph/AdjacencyMap.pm
Criterion Covered Total %
statement 286 288 99.3
branch 174 190 91.5
condition 71 81 87.6
subroutine 58 58 100.0
pod 19 19 100.0
total 608 636 95.6


line stmt bran cond sub pod time code
1             package Graph::AdjacencyMap;
2              
3 80     81   520 use strict;
  80         154  
  80         2253  
4 80     80   386 use warnings;
  80         154  
  80         11246  
5              
6             # $SIG{__DIE__ } = \&Graph::__carp_confess;
7             # $SIG{__WARN__} = \&Graph::__carp_confess;
8              
9             my $empty = {};
10 82     82   610 sub _empty () { $empty }
11              
12             my (@FLAGS, %FLAG_COMBOS, %FLAG2I, @FIELDS);
13             BEGIN {
14 80     80   444 @FLAGS = qw(_COUNT _MULTI _UNORD _REF _UNIONFIND _LIGHT _STR);
15 80         1001 %FLAG_COMBOS = (
16             _COUNTMULTI => [qw(_COUNT _MULTI)],
17             _REFSTR => [qw(_REF _STR)],
18             );
19             # Next id, Flags, Arity, Index to path, path to index,
20             # successors, predecessors: 2-level hashes to array-ref of path IDs
21             # attributes - two-level for MULTI, node/multi count
22 80         273 @FIELDS = qw(_n _f _arity _i _pi _s _p _attr _count);
23 80         526 for my $i (0..$#FLAGS) {
24 560         1070 my $n = $FLAGS[$i];
25 560         859 my $f = 1 << $i;
26 560         1114 $FLAG2I{$n} = $f;
27 80     80   630 no strict 'refs';
  80         166  
  80         12461  
28 560         4286 *$n = sub () { $f };
  0         0  
29 560     71082   2464 *{"_is$n"} = sub { $_[0]->[ 1 ] & $f }; # 1 = _f
  560     46706   2532  
  71082     9057   222175  
30             }
31 80         350 for my $k (keys %FLAG_COMBOS) {
32 160         332 my $f = 0;
33 160         263 $f |= $_ for map $FLAG2I{$_}, @{ $FLAG_COMBOS{$k} };
  160         781  
34 80     80   603 no strict 'refs';
  80         1932  
  80         8937  
35 160     1328   1128 *$k = sub () { return $f }; # return to dodge pointless 5.22 stricture
  1328         4134  
36 160     1   647 *{"_is$k"} = sub { $_[0]->[ 1 ] & $f }; # 1 = _f
  160         820  
  1         4  
37             }
38 80         356 for my $i (0..$#FIELDS) {
39 80     80   590 no strict 'refs';
  80         211  
  80         5887  
40 720         3243 *{ $FIELDS[$i] }= sub () { $i };
  720         13809  
  0         0  
41             }
42             }
43              
44             sub _new {
45 1798     1798   5976 my ($class, $flags, $arity) = @_;
46 1798         2790 my $hyper = !$arity;
47 1798         2766 my $need_s = $arity != 1;
48 1798   100     5171 my $need_p = $need_s && !($flags & _UNORD);
49 1798 100       10152 bless [
    100          
50             0, $flags, $arity, [], {},
51             ($need_s ? {} : undef), ($need_p ? {} : undef),
52             [], [],
53             ], $class;
54             }
55              
56             require Exporter;
57 80     80   673 use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
  80         205  
  80         352826  
58             @ISA = qw(Exporter);
59             %EXPORT_TAGS =
60             (flags => [@FLAGS, keys %FLAG_COMBOS, qw(_GEN_ID)],
61             fields => \@FIELDS);
62             @EXPORT_OK = map @$_, values %EXPORT_TAGS;
63              
64             my $_GEN_ID = 0;
65              
66 168     168   746 sub _GEN_ID () { \$_GEN_ID }
67              
68             sub stringify {
69 24     24 1 4270 my ($f, $arity, $m) = (@{ $_[0] }[ _f, _arity ], $_[0]);
  24         81  
70 24         60 my ($multi, @rows) = $f & _MULTI;
71 24         70 my @p = $m->paths;
72             @p = $arity == 1 ? sort @p :
73 24 100 100     311 map $_->[0], sort { $a->[1] cmp $b->[1] }
  138 100       196  
74             ($arity == 0 && !($f & _UNORD))
75             ? map [$_, join '|', map "@$_", @$_], @p
76             : map [$_,"@$_"], @p; # use the Schwartz
77 24 100       89 if ($arity == 2) {
78 10         653 require Set::Object;
79 10         7904 my ($pre, $suc, @s) = (Set::Object->new(map $_->[0], @p), Set::Object->new(map $_->[1], @p));
80             @rows = ([ 'to:', @s = sort $suc->members ], map {
81 10         107 my $p = $_;
  24         44  
82             [ $p, map {
83 24 100       42 my $text = defined(my $id = $m->has_path([$p, $_])) ? 1 : '';
  93         290  
84 93 100       292 my $attrs = !$text ? undef :
    100          
85             $multi ? $m->[ _attr ][$id] : $m->_get_path_attrs([$p, $_]);
86 93 100       301 defined $attrs ? $m->_dumper($attrs) : $text;
87             } @s ];
88             } sort $pre->members);
89             } else {
90             @rows = map {
91 14 100       28 my $attrs = $multi
  33         242  
92             ? $m->[ _attr ][ $m->has_path($_) ] : $m->_get_path_attrs($_);
93 33 100       83 [ $m->_dumper($_),
94             ($m->get_ids_by_paths([ $_ ], 0))[0].
95             (!defined $attrs ? '' : ",".$m->_dumper($attrs)) ];
96             } @p;
97             }
98 24         248 join '',
99             map "$_\n",
100 24         101 "@{[ref $m]} arity=$arity flags: @{[_stringify_fields($m->[ _f ])]}",
  24         67  
101             map join(' ', map sprintf('%4s', $_), @$_),
102             @rows;
103             }
104              
105             sub _stringify_fields {
106 38 100   38   385 return '0' if !$_[0];
107 30         651 join '|', grep $_[0] & $FLAG2I{$_}, @FLAGS;
108             }
109              
110             sub _dumper {
111 58     58   162 my (undef, $got) = @_;
112 58 100 66     305 return $got if defined $got and !ref $got;
113 31         1798 require Data::Dumper;
114 31         15819 my $dumper = Data::Dumper->new([$got]);
115 31         943 $dumper->Indent(0)->Terse(1);
116 31 50       653 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
117 31         198 $dumper->Dump;
118             }
119              
120             sub has_any_paths {
121 90     90 1 19183 scalar keys %{ $_[0]->[ _pi ] };
  90         468  
122             }
123              
124             sub _set_path_attr_common {
125 125     125   302 push @_, 0;
126 125         229 my ($i) = &__set_path;
127 125         264 my $attr = (my $m = $_[0])->[ _attr ];
128 125 100       807 ($m->[ _f ] & _MULTI) ? \$attr->[ $i ]{ $_[2] } : \$attr->[ $i ];
129             }
130              
131             sub _set_path_attrs {
132 1127     1127   10592 ${ &{ $_[0]->can('_set_path_attr_common') } } = $_[-1];
  1127         1491  
  1127         3440  
133             }
134              
135             sub _set_path_attr {
136 4747     4747   17919 ${ &{ $_[0]->can('_set_path_attr_common') } }->{ $_[-2] } = $_[-1];
  4747         6267  
  4747         16377  
137             }
138              
139             sub set_paths {
140 333     333 1 1180 map +($_[0]->__set_path($_, 1))[0], @_[1..$#_];
141             }
142              
143             sub set_path_by_multi_id {
144 112     112 1 277 push @_, 1;
145 112         354 goto &__set_path;
146             }
147              
148             sub __set_path {
149 556     556   940 my $inc_if_exists = pop;
150 556         1250 &__arg;
151 556         922 my ($f, $a, $map_i, $pi, $map_s, $map_p, $m, $k, $id) = (@{ $_[0] }[ _f, _arity, _i, _pi, _s, _p ], @_);
  556         1825  
152 556         879 my $is_multi = $f & _MULTI;
153 556         810 my $k_orig = $k;
154 556 100 100     2104 $k = __strval($k, $f) if $a == 1 && ($f & _REF) && ref($k);
      100        
155 556 100 100     2363 my $l = ($a == 0 && !($f & _UNORD)) ? join '|', map join(' ', sort @$_), @$k : $a == 1 ? "$k" : "@$k";
    100          
156 556 100       1336 if (exists $pi->{ $l }) {
157 189 100 100     775 return ($pi->{ $l }) if !($inc_if_exists and ($f & _COUNTMULTI));
158 53         199 my $nc = \$m->[ _count ][ my $i = $pi->{ $l } ];
159 53 100       217 $$nc++, return ($i) if !$is_multi;
160 32         64 my $na = $m->[ _attr ][ $i ];
161 32 100       80 if ($id eq _GEN_ID) {
162 17         81 $$nc++ while exists $na->{ $$nc };
163 17         41 $id = $$nc;
164             }
165 32         85 $na->{ $id } = { };
166 32         133 return ($i, $id);
167             }
168 367         1230 $map_i->[ $pi->{ $l } = my $i = $m->[ _n ]++ ] = $k_orig;
169 367 100       825 $m->[ _attr ][ $i ] = { ($id = ($id eq _GEN_ID) ? 0 : $id) => {} } if $is_multi;
    100          
170 367 100       737 $m->[ _count ][ $i ] = $is_multi ? 0 : 1 if ($f & _COUNTMULTI);
    100          
171 367 100       962 _successors_add($f, $a, $map_s, $map_p, $i, $k) if $map_s; # dereffed
172 367         1405 ($i, $id);
173             }
174              
175             sub _successors_add {
176 117     117   265 my ($f, $a, $map_s, $map_p, $id, $path) = @_;
177 117         341 my $pairs = _successors_cartesian(($f & _UNORD), $a == 0, $path);
178 117         314 push @{ $map_s->{ $_->[0] }{ $_->[1] } }, $id for @$pairs;
  240         778  
179 117 100       371 return if !$map_p;
180 78         203 push @{ $map_p->{ $_->[1] }{ $_->[0] } }, $id for @$pairs;
  124         432  
181             }
182              
183             sub _successors_del {
184 24     24   64 my ($f, $a, $map_s, $map_p, $id, $path) = @_;
185 24         68 my $pairs = _successors_cartesian(($f & _UNORD), $a == 0, $path);
186 24         70 for (@$pairs) {
187 61         126 my ($p, $s) = @$_;
188 61         84 my @new = grep $_ != $id, @{ $map_s->{ $p }{ $s } };
  61         157  
189 61 100       141 if (@new) {
190 2         5 $map_s->{ $p }{ $s } = \@new;
191 2 50       9 $map_p->{ $s }{ $p } = \@new if $map_p;
192 2         4 next;
193             }
194 59         132 delete $map_s->{ $p }{ $s };
195 59 100       80 delete $map_s->{ $p } if !keys %{ $map_s->{ $p } };
  59         146  
196 59 100       140 next if !$map_p;
197 27         53 delete $map_p->{ $s }{ $p };
198 27 100       39 delete $map_p->{ $s } if !keys %{ $map_p->{ $s } };
  27         112  
199             }
200             }
201              
202             sub _successors_cartesian {
203 26618     26618   42117 my ($unord, $hyper, $seq) = @_;
204 26618 100 100     78724 return [ $seq ] if !$unord and !$hyper;
205 11905 100 100     35769 return [] if $unord and $hyper and !@$seq;
      100        
206 11900         17151 my ($allow_self, $p_s, $s_s, @pairs);
207 11900 100       18993 if ($unord) {
208 11884         68372 require Set::Object;
209 11884         324314 my @a = Set::Object->new(@$seq)->members;
210 11884         58934 ($allow_self, $p_s, $s_s) = (@a < 2, \@a, \@a);
211             } else {
212 16         35 ($allow_self, $p_s, $s_s) = (1, @$seq);
213             }
214 11900         24768 for my $p (@$p_s) {
215 23547 100       103471 push @pairs, map [$p, $_], $allow_self ? @$s_s : grep $p != $_, @$s_s;
216             }
217 11900         34187 \@pairs;
218             }
219              
220             sub _get_path_count {
221 217 100   217   7623 return 0 unless my ($i) = &__has_path;
222 194         429 my $f = (my $m = $_[0])->[ _f ];
223             return
224             ($f & _COUNT) ? $m->[ _count ][ $i ] :
225 194 100       739 ($f & _MULTI) ? scalar keys %{ $m->[ _attr ][ $i ] } : 1;
  90 100       480  
226             }
227              
228             sub has_path {
229 706     706 1 16411 ( &__has_path )[0];
230             }
231              
232             sub has_path_by_multi_id {
233 268 100   268 1 4683 return undef unless my ($i) = &__has_path;
234 235         1016 return exists $_[0]->[ _attr ][ $i ]{ $_[2] };
235             }
236              
237             sub del_path {
238 208 100   208 1 1276 return unless my ($i, $l) = &__has_path;
239 207 100 100     457 return 1 if &_is_COUNT and --$_[0][ _count ][ $i ] > 0;
240 195         596 $_[0]->_sequence_del($i, $l);
241 195         370 1;
242             }
243              
244             sub del_path_by_multi_id {
245 17 50   17 1 106 return unless my ($i, $l) = &__has_path;
246 17         70 delete((my $attrs = (my $m = $_[0])->[ _attr ][ $i ])->{ $_[2] });
247 17 100       76 return 1 if keys %$attrs;
248 9         40 $m->_sequence_del($i, $l);
249 9         30 1;
250             }
251              
252             sub get_multi_ids {
253 51 100 66 51 1 242 return unless ((my $m = $_[0])->[ _f ] & _MULTI) and my ($i) = &__has_path;
254 49         115 keys %{ $m->[ _attr ][ $i ] };
  49         268  
255             }
256              
257             sub rename_path {
258 32     32 1 2752 my ($m, $from, $to) = @_;
259 32 50       86 return 1 if $m->[ _arity ] != 1; # all integers, no names
260 32 50       69 return unless my ($i, $l) = $m->__has_path($from);
261 32         83 $m->[ _i ][ $i ] = $to;
262 32 100 66     103 $to = __strval($to, $m->[ _f ]) if ref($to) and ($m->[ _f ] & _REF);
263 32         74 $m->[ _pi ]{ $to } = delete $m->[ _pi ]{ $l };
264 32         98 return 1;
265             }
266              
267             sub _del_path_attrs {
268 38 50   38   91 return unless my ($i) = &__has_path;
269 38         100 my $attr = (my $m = $_[0])->[ _attr ];
270 38 100       141 return $attr->[ $i ]{ $_[2] } = undef, 1 if ($m->[ _f ] & _MULTI);
271 27         83 delete $attr->[ $i ];
272             }
273              
274             sub __has_path {
275 1892     1892   4287 &__arg;
276 1892         2844 my ($f, $a, $pi, $k) = (@{ $_[0] }[ _f, _arity, _pi ], $_[1]);
  1892         3773  
277 1892 100 100     8089 $k = __strval($k, $f) if $a == 1 && ($f & _REF) && ref($k);
      100        
278 1892 100 100     7269 my $l = ($a == 0 && !($f & _UNORD)) ? join '|', map join(' ', sort @$_), @$k : $a == 1 ? "$k" : "@$k";
    100          
279 1892         3342 my $id = $pi->{ $l };
280 1892 100       8033 (defined $id ? $id : return, $l);
281             }
282              
283             sub _get_path_attrs {
284 355 100   355   3275 return unless my ($i) = &__has_path;
285 346         712 my $attrs = (my $m = $_[0])->[ _attr ][ $i ];
286 346 100       2307 ($m->[ _f ] & _MULTI) ? $attrs->{ $_[2] } : $attrs;
287             }
288              
289             sub _has_path_attrs {
290 82 100   82   9026 keys %{ &{ $_[0]->can('_get_path_attrs') } || return undef } ? 1 : 0;
  82 100       144  
  82         366  
291             }
292              
293             sub _has_path_attr {
294 62   100 62   116 exists(( &{ $_[0]->can('_get_path_attrs') } || return )->{ $_[-1] });
295             }
296              
297             sub _get_path_attr {
298 11521   100 11521   16249 ( &{ $_[0]->can('_get_path_attrs') } || return )->{ $_[-1] };
299             }
300              
301             sub _get_path_attr_names {
302 78 100   78   215 keys %{ &{ $_[0]->can('_get_path_attrs') } || return };
  78         117  
  78         323  
303             }
304              
305             sub _get_path_attr_values {
306 26 100   26   59 values %{ &{ $_[0]->can('_get_path_attrs') } || return };
  26         44  
  26         127  
307             }
308              
309             sub _del_path_attr {
310 40 100   40   11548 return unless my $attrs = &{ $_[0]->can('_get_path_attrs') };
  40         189  
311 36 50       127 return 0 unless exists $attrs->{ my $attr = $_[-1] };
312 36         86 delete $attrs->{$attr};
313 36 100       128 return 1 if keys %$attrs;
314 15         37 &{ $_[0]->can('_del_path_attrs') };
  15         72  
315 15         43 1;
316             }
317              
318             sub _sequence_del {
319 204     204   455 my ($m, $id, $l) = @_;
320 204         600 my ($f, $a, $map_i, $pi, $map_s, $map_p) = @$m[ _f, _arity, _i, _pi, _s, _p ];
321 204         462 delete $pi->{ $l };
322 204         641 delete $m->[ $_ ][ $id ] for _count, _attr;
323 204         385 my $path = delete $map_i->[ $id ];
324 204 100       466 _successors_del($f, $a, $map_s, $map_p, $id, $path) if $map_s;
325 204         364 return 1;
326             }
327              
328             sub get_paths_by_ids {
329 23479     23479 1 36707 my ($i, undef, $list, $deep) = ( @{ $_[0] }[ _i ], @_ );
  23479         51973  
330 23479 100       164132 $deep ? map [ map [ @$i[ @$_ ] ], @$_ ], @$list : map [ @$i[ @$_ ] ], @$list;
331             }
332              
333             sub paths {
334 3924 50   3924 1 5655 grep defined, @{ $_[0]->[ _i ] || Graph::_empty_array() };
  3924         28073  
335             }
336              
337             sub get_ids_by_paths {
338 1230     1230 1 20166 my ($f, $a, $pi, $m, $list, $ensure, $deep) = ( @{ $_[0] }[ _f, _arity, _pi ], @_ );
  1230         3350  
339 1230   100     4471 $deep ||= 0;
340 1230         4129 my ($is_multi, $is_ref, $is_unord) = (map $f & $_, _MULTI, _REF, _UNORD);
341             return map { # Fast path
342 1230 100 100     4596 my @ret = map {
      100        
343 121 100       294 my $id = $pi->{ $a != 1 ? "@$_" : $_ };
  154 100       344  
344 154 100       495 defined $id ? $id :
    100          
    100          
345             !$ensure ? return :
346             ($is_multi ? $m->set_path_by_multi_id($_, _GEN_ID) : $m->set_paths($_))[0];
347             } $deep ? @$_ : $_;
348 108 100       510 $deep ? \@ret : @ret;
349             } @$list if $a and !$is_ref and $deep < 2;
350             map {
351 1106         1896 my @ret = map {
352 1165 100       2209 my @ret2 = map {
353 1276 100       2345 my $k = $_;
  1289         1971  
354 1289 100 100     5988 $k = __strval($k, $f) if $a == 1 && $is_ref && ref($k);
      100        
355 1289 100 100     4428 my $l = ($a == 0 && !$is_unord) ? join '|', map join(' ', sort @$_), @$k : $a == 1 ? "$k" : "@$k";
    100          
356 1289         2271 my $id = $pi->{ $l };
357 1289 50       6124 defined $id ? $id :
    100          
    100          
358             !$ensure ? return :
359             ($is_multi ? $m->set_path_by_multi_id($_, _GEN_ID) : $m->set_paths($_))[0];
360             } $deep > 1 ? @$_ : $_;
361 1115 100       2774 $deep > 1 ? \@ret2 : @ret2;
362             } $deep ? @$_ : $_;
363 1004 100       3822 $deep ? \@ret : @ret;
364             } @$list;
365             }
366              
367             sub _paths_fromto {
368 46     46   111 my $offset = pop;
369 46         82 my ($i, $map_x, @v) = ( @{ $_[0] }[ _i, $offset ], @_[1..$#_] );
  46         164  
370 46 50       202 Graph::__carp_confess("undefined vertex") if grep !defined, @v;
371 46         235 require Set::Object;
372 46 100       102 map $i->[ $_ ], Set::Object->new(map @$_, map values %{ $map_x->{ $_ } || _empty }, @v)->members;
  52         622  
373             }
374 31     31 1 9352 sub paths_from { push @_, _s; goto &_paths_fromto }
  31         104  
375 15     15 1 4594 sub paths_to { push @_, _p; goto &_paths_fromto }
  15         52  
376              
377             sub _cessors {
378 181     181   280 my $offset = pop;
379 181         291 my ($map_x, @v) = ( @{ $_[0] }[ $offset ], @_[1..$#_] );
  181         486  
380 181 50       493 Graph::__carp_confess("undefined vertex") if grep !defined, @v;
381 181         1373 require Set::Object;
382 181 100       7967 Set::Object->new(map keys %{ $map_x->{ $_ } || _empty }, @v)->members;
  187         1473  
383             }
384 140     140 1 7384 sub successors { push @_, _s; goto &_cessors }
  140         334  
385 41     41 1 5748 sub predecessors { push @_, _p; goto &_cessors }
  41         132  
386              
387             sub has_successor {
388 72     72 1 10081 my ($map_s, $u, $v) = ( @{ $_[0] }[ _s ], @_[1, 2] );
  72         240  
389 72 50       270 Graph::__carp_confess("undefined vertex") if grep !defined, $u, $v;
390 72 100       103 exists ${ $map_s->{ $u } || _empty }{ $v };
  72         349  
391             }
392              
393             sub __strval {
394 2079     2079   3744 my ($k, $f) = @_;
395 2079 50 33     6028 return $k unless ref $k && ($f & _REF);
396 2079 100       3688 return "$k" if ($f & _STR);
397 2075         8594 require Scalar::Util;
398 2075         5383 Scalar::Util::refaddr($k);
399             }
400              
401             sub __arg {
402 2448     2448   3497 my ($f, $a, $m, $k) = (@{ $_[0] }[ _f, _arity ], @_[0, 1]);
  2448         6272  
403 2448 50 66     7450 Graph::__carp_confess(sprintf "arguments %d (%s) expected %d for\n".$m->stringify,
404             scalar @$k, "@$k", $a)
405             if $a > 1 and @$k != $a;
406             }
407              
408             sub reindex {
409 3     3 1 551 my ($f, $a, $i2p, $m) = (@{ $_[0] }[ _f, _arity, _i ], $_[0]);
  3         13  
410 3   33     21 my $is_ref = $a == 1 && ($f & _REF);
411 3         12 my $pi = $m->[ _pi ] = {};
412 3         8 for my $i ( 0..$#{ $i2p } ) {
  3         12  
413 4 50       15 next if !defined(my $k = $i2p->[ $i ]); # deleted
414 4 50 33     24 $k = __strval($k, $f) if $is_ref && ref($k);
415 4         18 $pi->{ $k } = $i;
416             }
417             }
418              
419             1;
420             __END__