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__ |