line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package List::Gen;
|
2
|
10
|
|
|
10
|
|
235800
|
use warnings;
|
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
492
|
|
3
|
10
|
|
|
10
|
|
54
|
use strict;
|
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
314
|
|
4
|
10
|
|
|
10
|
|
51
|
use Carp;
|
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
936
|
|
5
|
10
|
|
|
10
|
|
8555
|
use Symbol qw/delete_package/;
|
|
10
|
|
|
|
|
10132
|
|
|
10
|
|
|
|
|
818
|
|
6
|
10
|
|
|
10
|
|
64
|
use Scalar::Util qw/reftype weaken openhandle blessed/;
|
|
10
|
|
|
|
|
16
|
|
|
10
|
|
|
|
|
1445
|
|
7
|
|
|
|
|
|
|
our @list_util;
|
8
|
|
|
|
|
|
|
use List::Util
|
9
|
10
|
|
|
10
|
|
74
|
@list_util = qw/first max maxstr min minstr reduce shuffle sum/;
|
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
3740
|
|
10
|
|
|
|
|
|
|
our @EXPORT = qw/mapn by every range gen cap filter cache apply
|
11
|
|
|
|
|
|
|
zip min max reduce glob iterate list/;
|
12
|
|
|
|
|
|
|
our %EXPORT_TAGS = (
|
13
|
|
|
|
|
|
|
base => \@EXPORT,
|
14
|
|
|
|
|
|
|
'List::Util' => \@list_util,
|
15
|
|
|
|
|
|
|
map {s/==//g; s/#.*//g;
|
16
|
|
|
|
|
|
|
/:(\w+)\s+(.+)/s ? ($1 => [split /\s+/ => $2]) : ()
|
17
|
|
|
|
|
|
|
} split /\n{2,}/ => q(
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
:utility mapn by every apply min max reduce mapab
|
20
|
|
|
|
|
|
|
mapkey d deref slide curse remove
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
:source range glob makegen list array vecgen repeat file
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
:modify gen cache expand contract collect slice flip overlay
|
25
|
|
|
|
|
|
|
test recursive sequence scan scan_stream == scanS
|
26
|
|
|
|
|
|
|
cartesian transpose stream strict
|
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
:zip zip zipgen tuples zipwith zipwithab unzip unzipn
|
29
|
|
|
|
|
|
|
zipmax zipgenmax zipwithmax
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
:iterate iterate
|
32
|
|
|
|
|
|
|
iterate_multi == iterateM
|
33
|
|
|
|
|
|
|
iterate_stream == iterateS
|
34
|
|
|
|
|
|
|
iterate_multi_stream == iterateMS
|
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
:gather gather
|
37
|
|
|
|
|
|
|
gather_stream == gatherS
|
38
|
|
|
|
|
|
|
gather_multi == gatherM
|
39
|
|
|
|
|
|
|
gather_multi_stream == gatherMS
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
:mutable mutable done done_if done_unless
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
:filter filter
|
44
|
|
|
|
|
|
|
filter_stream == filterS
|
45
|
|
|
|
|
|
|
filter_ # non-lookahead version
|
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
:while take_while == While
|
48
|
|
|
|
|
|
|
take_until == Until
|
49
|
|
|
|
|
|
|
while_ until_ # non-lookahead versions
|
50
|
|
|
|
|
|
|
drop_while drop_until
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
:numeric primes
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
:deprecated genzip
|
55
|
|
|
|
|
|
|
));
|
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
our @EXPORT_OK = keys %{{map {$_ => 1} map @$_, values %EXPORT_TAGS}};
|
58
|
|
|
|
|
|
|
$EXPORT_TAGS{all} = \@EXPORT_OK;
|
59
|
|
|
|
|
|
|
BEGIN {
|
60
|
10
|
|
|
10
|
|
52
|
require Exporter;
|
61
|
10
|
|
|
|
|
22359
|
require overload;
|
62
|
10
|
|
|
|
|
11981
|
require B;
|
63
|
10
|
|
|
|
|
5536
|
*List::Generator:: = *List::Gen::;
|
64
|
|
|
|
|
|
|
}
|
65
|
|
|
|
|
|
|
sub import {
|
66
|
12
|
50
|
66
|
12
|
|
2230
|
if (@_ == 2 and !$_[1] || $_[1] eq '*') {
|
|
|
|
66
|
|
|
|
|
67
|
6
|
|
|
|
|
28
|
splice @_, 1, 1, ':all', '\\'
|
68
|
|
|
|
|
|
|
}
|
69
|
12
|
100
|
|
|
|
54
|
push @_, '\\' if @_ == 1;
|
70
|
12
|
100
|
|
|
|
33
|
@_ = grep {/^&?\\$/ ? do {*\ = \∩ 0} : 1} @_;
|
|
30
|
|
|
|
|
144
|
|
|
12
|
|
|
|
|
46
|
|
|
12
|
|
|
|
|
48
|
|
71
|
12
|
50
|
|
|
|
30
|
@_ = map {/^<.*>$/ ? 'glob' : $_} @_;
|
|
18
|
|
|
|
|
85
|
|
72
|
12
|
|
|
|
|
27
|
goto &{Exporter->can('import')}
|
|
12
|
|
|
|
|
14465
|
|
73
|
|
|
|
|
|
|
}
|
74
|
|
|
|
|
|
|
sub VERSION {
|
75
|
3
|
100
|
66
|
3
|
0
|
34
|
goto &{@_ > 1 && $_[1] == 0 ? *import : *UNIVERSAL::VERSION}
|
|
3
|
|
|
|
|
71
|
|
76
|
|
|
|
|
|
|
}
|
77
|
|
|
|
|
|
|
|
78
|
973
|
|
|
973
|
0
|
2414
|
sub DEBUG () {}
|
79
|
|
|
|
|
|
|
DEBUG or $Carp::Internal{(__PACKAGE__)}++;
|
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
our $LIST = 0; # deprecated
|
82
|
|
|
|
|
|
|
our $LOOKAHEAD = 1;
|
83
|
|
|
|
|
|
|
our $DWIM_CODE_STRINGS = 0;
|
84
|
|
|
|
|
|
|
our $SAY_EVAL = 0;
|
85
|
|
|
|
|
|
|
our $STREAM = 0;
|
86
|
|
|
|
|
|
|
our $STRICT = 0;
|
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my $MAX_IDX = eval {require POSIX; POSIX::DBL_MAX()} || 2**53 - 1;
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
our $VERSION = '0.974';
|
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=head1 NAME
|
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
List::Gen - provides functions for generating lists
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=head1 VERSION
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
version 0.974
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=head1 SYNOPSIS
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
this module provides higher order functions, list comprehensions, generators,
|
103
|
|
|
|
|
|
|
iterators, and other utility functions for working with lists. walk lists
|
104
|
|
|
|
|
|
|
with any step size you want, create lazy ranges and arrays with a map like
|
105
|
|
|
|
|
|
|
syntax that generate values on demand. there are several other hopefully useful
|
106
|
|
|
|
|
|
|
functions, and all functions from List::Util are available.
|
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
use List::Gen;
|
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
print "@$_\n" for every 5 => 1 .. 15;
|
111
|
|
|
|
|
|
|
# 1 2 3 4 5
|
112
|
|
|
|
|
|
|
# 6 7 8 9 10
|
113
|
|
|
|
|
|
|
# 11 12 13 14 15
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
print mapn {"$_[0]: $_[1]\n"} 2 => %myhash;
|
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
my $ints = <0..>;
|
118
|
|
|
|
|
|
|
my $squares = gen {$_**2} $ints;
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
say "@$squares[2 .. 6]"; # 4 9 16 25 36
|
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
$ints->zip('.', -$squares)->say(6); # 0-0 1-1 2-4 3-9 4-16 5-25
|
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
list(1, 2, 3)->gen('**2')->say; # 1 4 9
|
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
my $fib = ([0, 1] + iterate {fib($_, $_ + 1)->sum})->rec('fib');
|
127
|
|
|
|
|
|
|
my $fac = iterate {$_ < 2 or $_ * self($_ - 1)}->rec;
|
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
say "@$fib[0 .. 15]"; # 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610
|
130
|
|
|
|
|
|
|
say "@$fac[0 .. 10]"; # 1 1 2 6 24 120 720 5040 40320 362880 3628800
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
say <0, 1, * + * ...>->take(10)->str; # 0 1 1 2 3 5 8 13 21 34
|
133
|
|
|
|
|
|
|
say <[..*] 1, 1..>->str(8); # 1 1 2 6 24 120 720 5040
|
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
<**2 for 1..10 if even>->say; # 4 16 36 64 100
|
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
<1..>->map('**2')->grep(qr/1/)->say(5); # 1 16 81 100 121
|
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
=head1 EXPORT
|
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
use List::Gen; # is the same as
|
142
|
|
|
|
|
|
|
use List::Gen qw/mapn by every range gen cap \ filter cache apply zip
|
143
|
|
|
|
|
|
|
min max reduce glob iterate list/;
|
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
the following export tags are available:
|
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
:utility mapn by every apply min max reduce mapab
|
148
|
|
|
|
|
|
|
mapkey d deref slide curse remove
|
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
:source range glob makegen list array vecgen repeat file
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
:modify gen cache expand contract collect slice flip overlay
|
153
|
|
|
|
|
|
|
test recursive sequence scan scan_stream == scanS
|
154
|
|
|
|
|
|
|
cartesian transpose stream strict
|
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
:zip zip zipgen tuples zipwith zipwithab unzip unzipn
|
157
|
|
|
|
|
|
|
zipmax zipgenmax zipwithmax
|
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
:iterate iterate
|
160
|
|
|
|
|
|
|
iterate_multi == iterateM
|
161
|
|
|
|
|
|
|
iterate_stream == iterateS
|
162
|
|
|
|
|
|
|
iterate_multi_stream == iterateMS
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
:gather gather
|
165
|
|
|
|
|
|
|
gather_stream == gatherS
|
166
|
|
|
|
|
|
|
gather_multi == gatherM
|
167
|
|
|
|
|
|
|
gather_multi_stream == gatherMS
|
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
:mutable mutable done done_if done_unless
|
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
:filter filter
|
172
|
|
|
|
|
|
|
filter_stream == filterS
|
173
|
|
|
|
|
|
|
filter_ # non-lookahead version
|
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
:while take_while == While
|
176
|
|
|
|
|
|
|
take_until == Until
|
177
|
|
|
|
|
|
|
while_ until_ # non-lookahead versions
|
178
|
|
|
|
|
|
|
drop_while drop_until
|
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
:numeric primes
|
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
:deprecated genzip
|
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
:List::Util first max maxstr min minstr reduce shuffle sum
|
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
use List::Gen '*'; # everything
|
187
|
|
|
|
|
|
|
use List::Gen 0; # everything
|
188
|
|
|
|
|
|
|
use List::Gen ':all'; # everything
|
189
|
|
|
|
|
|
|
use List::Gen ':base'; # same as 'use List::Gen;'
|
190
|
|
|
|
|
|
|
use List::Gen (); # no exports
|
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=cut
|
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub mapn (&$@);
|
195
|
|
|
|
|
|
|
#my @packages; END {print "package $_;\n" for sort @packages}
|
196
|
|
|
|
|
|
|
sub packager {
|
197
|
280
|
|
|
280
|
0
|
759
|
unshift @_, split /\s+/ => shift;
|
198
|
280
|
|
|
|
|
425
|
my $pkg = shift;
|
199
|
280
|
|
|
|
|
571
|
my @isa = deref(shift);
|
200
|
|
|
|
|
|
|
|
201
|
280
|
50
|
|
|
|
521
|
for ($pkg, @isa) {/:/ or s/^/List::Gen::/}
|
|
560
|
|
|
|
|
2782
|
|
202
|
|
|
|
|
|
|
#push @packages, $pkg;
|
203
|
10
|
|
|
10
|
|
71
|
no strict 'refs';
|
|
10
|
|
|
|
|
35
|
|
|
10
|
|
|
|
|
2603
|
|
204
|
280
|
|
|
|
|
390
|
*{$pkg.'::ISA'} = \@isa;
|
|
280
|
|
|
|
|
5315
|
|
205
|
280
|
|
|
560
|
|
1753
|
mapn {*{$pkg.'::'.$_} = pop} 2 => @_;
|
|
560
|
|
|
|
|
575
|
|
|
560
|
|
|
|
|
4064
|
|
206
|
280
|
|
|
|
|
1085
|
1
|
207
|
|
|
|
|
|
|
}
|
208
|
|
|
|
|
|
|
sub generator {
|
209
|
220
|
50
|
|
220
|
0
|
1034
|
splice @_, 1, 0, 'Base', @_ > 1 ? 'TIEARRAY' : ();
|
210
|
220
|
|
|
|
|
597
|
goto &packager
|
211
|
|
|
|
|
|
|
}
|
212
|
|
|
|
|
|
|
sub mutable_gen {
|
213
|
60
|
50
|
|
60
|
0
|
249
|
splice @_, 1, 0, 'Mutable', @_ > 1 ? 'TIEARRAY' : ();
|
214
|
60
|
|
|
|
|
143
|
goto &packager
|
215
|
|
|
|
|
|
|
}
|
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
require Sub::Name if DEBUG;
|
218
|
|
|
|
|
|
|
{my %id;
|
219
|
|
|
|
|
|
|
sub curse {
|
220
|
197
|
|
|
197
|
1
|
311
|
my ($obj, $class) = @_;
|
221
|
197
|
|
33
|
|
|
430
|
my $pkg = $class || caller;
|
222
|
197
|
|
|
|
|
539
|
$pkg .= '::_'.++$id{$pkg};
|
223
|
|
|
|
|
|
|
|
224
|
10
|
|
|
10
|
|
55
|
no strict 'refs';
|
|
10
|
|
|
|
|
29
|
|
|
10
|
|
|
|
|
4133
|
|
225
|
197
|
50
|
|
|
|
205
|
croak "package $pkg not empty" if %{$pkg.'::'};
|
|
197
|
|
|
|
|
2138
|
|
226
|
|
|
|
|
|
|
|
227
|
197
|
|
|
|
|
814
|
my $destroy = delete $$obj{DESTROY};
|
228
|
197
|
|
|
|
|
919
|
*{$pkg.'::DESTROY'} = sub {
|
229
|
187
|
50
|
|
187
|
|
18399
|
{&{ $destroy or next}}
|
|
187
|
|
|
|
|
204
|
|
|
187
|
|
|
|
|
445
|
|
230
|
187
|
100
|
50
|
|
|
189
|
{&{($class or next)->can('DESTROY') or next}}
|
|
187
|
|
|
|
|
202
|
|
|
187
|
|
|
|
|
1575
|
|
231
|
187
|
|
|
|
|
537
|
delete_package $pkg
|
232
|
197
|
|
|
|
|
608
|
};
|
233
|
197
|
50
|
|
|
|
473
|
@{$pkg.'::ISA'} = $class if $class;
|
|
197
|
|
|
|
|
3290
|
|
234
|
|
|
|
|
|
|
|
235
|
197
|
100
|
|
|
|
648
|
for my $name (grep {not /^-/ and ref $$obj{$_} eq 'CODE'} keys %$obj) {
|
|
856
|
|
|
|
|
3891
|
|
236
|
804
|
50
|
33
|
|
|
1321
|
DEBUG and B::svref_2object($$obj{$name})->GV->NAME =~ /__ANON__/
|
237
|
|
|
|
|
|
|
and Sub::Name::subname("$class\::$name", $$obj{$name});
|
238
|
804
|
|
|
|
|
962
|
*{$pkg.'::'.$name} = $$obj{$name}
|
|
804
|
|
|
|
|
3611
|
|
239
|
|
|
|
|
|
|
}
|
240
|
197
|
50
|
|
|
|
627
|
if ($$obj{-overload}) {
|
241
|
0
|
|
|
|
|
0
|
eval 'package '.$pkg.'; use overload @{$$obj{-overload}}'
|
242
|
|
|
|
|
|
|
}
|
243
|
197
|
|
66
|
|
|
2511
|
bless $$obj{-bless} || $obj => $pkg
|
244
|
|
|
|
|
|
|
}}
|
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
sub looks_like_number ($) {
|
247
|
10
|
|
|
|
|
2929
|
Scalar::Util::looks_like_number($_[0])
|
248
|
10
|
|
|
10
|
|
61
|
or do {no warnings 'numeric'; $_[0] >= 9**9**9}
|
|
10
|
|
|
|
|
16
|
|
|
16
|
|
|
|
|
176
|
|
249
|
104
|
50
|
66
|
104
|
0
|
577
|
or do {
|
250
|
16
|
50
|
0
|
|
|
462
|
ref $_[0]
|
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
251
|
|
|
|
|
|
|
and blessed $_[0]
|
252
|
|
|
|
|
|
|
and $_[0]->isa('Math::BigInt')
|
253
|
|
|
|
|
|
|
|| $_[0]->isa('Math::BigRat')
|
254
|
|
|
|
|
|
|
|| $_[0]->isa('Math::BigFloat')
|
255
|
|
|
|
|
|
|
}
|
256
|
|
|
|
|
|
|
}
|
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
our $sv2cv;
|
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
my $cv_caller = sub {
|
261
|
|
|
|
|
|
|
reftype($_[0]) eq 'CODE' or croak "not code: $_[0]";
|
262
|
|
|
|
|
|
|
B::svref_2object($_[0])->STASH->NAME
|
263
|
|
|
|
|
|
|
};
|
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
my $cv_local = sub {
|
266
|
|
|
|
|
|
|
my $caller = shift->$cv_caller;
|
267
|
10
|
|
|
10
|
|
54
|
no strict 'refs';
|
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
10211
|
|
268
|
|
|
|
|
|
|
my @ret = map \*{$caller.'::'.$_} => @_;
|
269
|
|
|
|
|
|
|
wantarray ? @ret : pop @ret
|
270
|
|
|
|
|
|
|
};
|
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
my $cv_ab_ref = sub {
|
273
|
|
|
|
|
|
|
$_[0]->$cv_local(qw(a b))
|
274
|
|
|
|
|
|
|
};
|
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
my $cv_wants_2_args = sub {
|
277
|
|
|
|
|
|
|
(prototype $_[0] or '') eq '$$'
|
278
|
|
|
|
|
|
|
};
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
my $any_mutable = sub {
|
281
|
|
|
|
|
|
|
for (@_) {return 1 if ref and isagen($_) and $_->is_mutable}
|
282
|
|
|
|
|
|
|
''
|
283
|
|
|
|
|
|
|
};
|
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
my $external_package = sub {
|
286
|
|
|
|
|
|
|
my $up = @_ ? $_[0] : 1;
|
287
|
|
|
|
|
|
|
$up++ while (substr caller $up, 0 => 9) eq 'List::Gen';
|
288
|
|
|
|
|
|
|
scalar caller $up
|
289
|
|
|
|
|
|
|
};
|
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
my $isagen = \&isagen;
|
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
my $is_array_or_gen = sub {ref $_[0] eq 'ARRAY' or &isagen};
|
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
my $say_eval = sub {Carp::cluck "eval ($_[0]): '$_[1]'"};
|
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
my $eval = sub {
|
298
|
|
|
|
|
|
|
my $pkg = $external_package->(2);
|
299
|
|
|
|
|
|
|
my ($msg, $code) = @_;
|
300
|
|
|
|
|
|
|
&$say_eval if $SAY_EVAL or DEBUG;
|
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
my $say = $code =~ /(?:\b|^)say(?:\b|$)/
|
303
|
|
|
|
|
|
|
? "use feature 'say';"
|
304
|
|
|
|
|
|
|
: '';
|
305
|
|
|
|
|
|
|
$code = "[do {$code}]" if wantarray;
|
306
|
|
|
|
|
|
|
local @$;
|
307
|
|
|
|
|
|
|
my $ret = eval "package $pkg; $say \\do {$code}"
|
308
|
|
|
|
|
|
|
or croak "$msg code error: $@\n$say $code\n";
|
309
|
|
|
|
|
|
|
wantarray ? @$$ret : $$ret
|
310
|
|
|
|
|
|
|
};
|
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head1 FUNCTIONS
|
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=over 4
|
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=item mapn C< {CODE} NUM LIST >
|
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
this function works like the builtin C< map > but takes C< NUM > sized steps
|
320
|
|
|
|
|
|
|
over the list, rather than one element at a time. inside the C< CODE > block,
|
321
|
|
|
|
|
|
|
the current slice is in C< @_ > and C< $_ > is set to C< $_[0] >. slice elements
|
322
|
|
|
|
|
|
|
are aliases to the original list. if C< mapn > is called in void context, the
|
323
|
|
|
|
|
|
|
C< CODE > block will be executed in void context for efficiency.
|
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
print mapn {$_ % 2 ? "@_" : " [@_] "} 3 => 1..20;
|
326
|
|
|
|
|
|
|
# 1 2 3 [4 5 6] 7 8 9 [10 11 12] 13 14 15 [16 17 18] 19 20
|
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
print "student grades: \n";
|
329
|
|
|
|
|
|
|
mapn {
|
330
|
|
|
|
|
|
|
print shift, ": ", &sum / @_, "\n";
|
331
|
|
|
|
|
|
|
} 5 => qw {
|
332
|
|
|
|
|
|
|
bob 90 80 65 85
|
333
|
|
|
|
|
|
|
alice 75 95 70 100
|
334
|
|
|
|
|
|
|
eve 80 90 80 75
|
335
|
|
|
|
|
|
|
};
|
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
=cut
|
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub mapn (&$@) {
|
340
|
285
|
|
|
285
|
1
|
608
|
my ($sub, $n, @ret) = splice @_, 0, 2;
|
341
|
285
|
50
|
|
|
|
605
|
croak '$_[1] must be >= 1' unless $n >= 1;
|
342
|
|
|
|
|
|
|
|
343
|
285
|
50
|
|
|
|
527
|
return map $sub->($_) => @_ if $n == 1;
|
344
|
|
|
|
|
|
|
|
345
|
285
|
|
|
|
|
392
|
my $want = defined wantarray;
|
346
|
285
|
|
|
|
|
630
|
while (@_) {
|
347
|
570
|
|
|
|
|
963
|
local *_ = \$_[0];
|
348
|
570
|
50
|
|
|
|
954
|
if ($want) {push @ret =>
|
|
0
|
|
|
|
|
0
|
|
|
570
|
|
|
|
|
1181
|
|
349
|
|
|
|
|
|
|
$sub->(splice @_, 0, $n)}
|
350
|
|
|
|
|
|
|
else {$sub->(splice @_, 0, $n)}
|
351
|
|
|
|
|
|
|
}
|
352
|
|
|
|
|
|
|
@ret
|
353
|
285
|
|
|
|
|
464
|
}
|
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=item by C< NUM LIST >
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=item every C< NUM LIST >
|
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
C< by > and C< every > are exactly the same, and allow you to add variable step
|
361
|
|
|
|
|
|
|
size to any other list control structure with whichever reads better to you.
|
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
for (every 2 => @_) {do something with pairs in @$_}
|
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
grep {do something with triples in @$_} by 3 => @list;
|
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
the functions generate an array of array references to C< NUM > sized slices of
|
368
|
|
|
|
|
|
|
C< LIST >. the elements in each slice are aliases to the original list.
|
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
in list context, returns a real array.
|
371
|
|
|
|
|
|
|
in scalar context, returns a generator.
|
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
my @slices = every 2 => 1 .. 10; # real array
|
374
|
|
|
|
|
|
|
my $slices = every 2 => 1 .. 10; # generator
|
375
|
|
|
|
|
|
|
for (every 2 => 1 .. 10) { ... } # real array
|
376
|
|
|
|
|
|
|
for (@{every 2 => 1 .. 10}) { ... } # generator
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
if you plan to use all the slices, the real array is probably better. if you
|
379
|
|
|
|
|
|
|
only need a few, the generator won't need to compute all of the other slices.
|
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
print "@$_\n" for every 3 => 1..9;
|
382
|
|
|
|
|
|
|
# 1 2 3
|
383
|
|
|
|
|
|
|
# 4 5 6
|
384
|
|
|
|
|
|
|
# 7 8 9
|
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
my @a = 1 .. 10;
|
387
|
|
|
|
|
|
|
for (every 2 => @a) {
|
388
|
|
|
|
|
|
|
@$_[0, 1] = @$_[1, 0] # flip each pair
|
389
|
|
|
|
|
|
|
}
|
390
|
|
|
|
|
|
|
print "@a";
|
391
|
|
|
|
|
|
|
# 2 1 4 3 6 5 8 7 10 9
|
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
print "@$_\n" for grep {$$_[0] % 2} by 3 => 1 .. 9;
|
394
|
|
|
|
|
|
|
# 1 2 3
|
395
|
|
|
|
|
|
|
# 7 8 9
|
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=cut
|
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
sub by ($@) {
|
400
|
0
|
0
|
|
0
|
1
|
0
|
croak '$_[0] must be >= 1' unless $_[0] >= 1;
|
401
|
0
|
0
|
|
|
|
0
|
if (wantarray) {
|
402
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 2 and ref $_[1] and isagen($_[1])) {
|
|
|
|
0
|
|
|
|
|
403
|
0
|
|
|
|
|
0
|
return &mapn(\&cap, $_[0], $_[1]->all)
|
404
|
|
|
|
|
|
|
} else {
|
405
|
0
|
|
|
|
|
0
|
unshift @_, \∩
|
406
|
0
|
|
|
|
|
0
|
goto &mapn
|
407
|
|
|
|
|
|
|
}
|
408
|
|
|
|
|
|
|
}
|
409
|
0
|
|
|
|
|
0
|
tie my @ret => 'List::Gen::By', shift, \@_;
|
410
|
0
|
|
|
|
|
0
|
List::Gen::erator->new(\@ret)
|
411
|
|
|
|
|
|
|
}
|
412
|
10
|
|
|
10
|
|
15665
|
BEGIN {*every = \&by}
|
413
|
|
|
|
|
|
|
generator By => sub {
|
414
|
10
|
|
|
10
|
|
27
|
my ($class, $n, $source) = @_;
|
415
|
10
|
0
|
33
|
|
|
65
|
if (@$source == 1 and ref $$source[0] and isagen($$source[0])) {
|
|
|
|
33
|
|
|
|
|
416
|
0
|
|
|
|
|
0
|
$source = $$source[0];
|
417
|
|
|
|
|
|
|
}
|
418
|
10
|
|
|
|
|
64
|
my $size = @$source / $n;
|
419
|
10
|
|
|
|
|
31
|
my $last = $#$source;
|
420
|
|
|
|
|
|
|
|
421
|
10
|
50
|
|
|
|
60
|
$size ++ if $size > int $size;
|
422
|
10
|
|
|
|
|
22
|
$size = int $size;
|
423
|
10
|
|
|
|
|
26
|
my %cache;
|
424
|
|
|
|
|
|
|
curse {
|
425
|
|
|
|
|
|
|
FETCH => isagen($source)
|
426
|
|
|
|
|
|
|
? do {
|
427
|
0
|
|
|
|
|
0
|
my $fetch = tied(@$source)->can('FETCH');
|
428
|
0
|
|
|
|
|
0
|
my $src_size = $source->size;
|
429
|
0
|
0
|
|
|
|
0
|
$source->tail_size($src_size) if $source->is_mutable;
|
430
|
|
|
|
|
|
|
sub {
|
431
|
0
|
|
|
0
|
|
0
|
my $i = $n * $_[1];
|
432
|
0
|
0
|
0
|
|
|
0
|
$cache{$i} ||= $i < $src_size
|
433
|
|
|
|
|
|
|
? cap (map $fetch->(undef, $_) => $i .. min($last, $i + $n - 1))
|
434
|
0
|
|
|
|
|
0
|
: croak "index $_[1] out of bounds [0 .. @{[int( $#$source / $n )]}]"
|
435
|
|
|
|
|
|
|
}
|
436
|
0
|
|
|
|
|
0
|
} : sub {
|
437
|
0
|
|
|
0
|
|
0
|
my $i = $n * $_[1];
|
438
|
0
|
0
|
0
|
|
|
0
|
$cache{$i} ||= $i < @$source
|
439
|
|
|
|
|
|
|
? cap (@$source[$i .. min($last, $i + $n - 1)])
|
440
|
0
|
|
|
|
|
0
|
: croak "index $_[1] out of bounds [0 .. @{[int( $#$source / $n )]}]"
|
441
|
|
|
|
|
|
|
},
|
442
|
10
|
|
|
10
|
|
28
|
fsize => sub {$size}
|
443
|
10
|
50
|
|
|
|
60
|
} => $class
|
444
|
|
|
|
|
|
|
};
|
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
=item apply C< {CODE} LIST >
|
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
apply a function that modifies C< $_ > to a shallow copy of C< LIST > and
|
450
|
|
|
|
|
|
|
returns the copy
|
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
print join ", " => apply {s/$/ one/} "this", "and that";
|
453
|
|
|
|
|
|
|
> this one, and that one
|
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=cut
|
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
sub apply (&@) {
|
458
|
0
|
|
|
0
|
1
|
0
|
my ($sub, @ret) = splice @_;
|
459
|
0
|
|
|
|
|
0
|
&$sub for @ret;
|
460
|
0
|
0
|
|
|
|
0
|
wantarray ? @ret : pop @ret
|
461
|
|
|
|
|
|
|
}
|
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=item zip C< LIST >
|
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
C< zip > takes a list of array references and generators. it interleaves the
|
467
|
|
|
|
|
|
|
elements of the passed in sequences to create a new list. C< zip > continues
|
468
|
|
|
|
|
|
|
until the end of the shortest sequence. C< LIST > can be any combination of
|
469
|
|
|
|
|
|
|
array references and generators.
|
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
%hash = zip [qw/a b c/], [1..3]; # same as
|
472
|
|
|
|
|
|
|
%hash = (a => 1, b => 2, c => 3);
|
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
in scalar context, C< zip > returns a generator, produced by C< zipgen >
|
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
if the first argument to C< zip > is not an array or generator, it is assumed
|
477
|
|
|
|
|
|
|
to be code or a code like string. that code will be used to join the elements
|
478
|
|
|
|
|
|
|
from the remaining arguments.
|
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
my $gen = zip sub {$_[0] . $_[1]}, [1..5], ;
|
481
|
|
|
|
|
|
|
# or = zip '.' => [1..5], ;
|
482
|
|
|
|
|
|
|
# or = zipwith {$_[0] . $_[1]} [1..5], ;
|
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
$gen->str; # '1a 2b 3c 4d 5e'
|
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
=cut
|
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub zip {
|
489
|
0
|
|
|
0
|
1
|
0
|
my $code;
|
490
|
0
|
0
|
|
|
|
0
|
unless ($_[0]->$is_array_or_gen) {
|
491
|
0
|
|
|
|
|
0
|
$code = shift;
|
492
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
493
|
0
|
|
|
|
|
0
|
unshift @_, $code;
|
494
|
|
|
|
|
|
|
}
|
495
|
0
|
0
|
|
|
|
0
|
local *zipgen = *zipwith if $code;
|
496
|
0
|
0
|
|
|
|
0
|
goto &zipgen unless wantarray;
|
497
|
0
|
0
|
|
|
|
0
|
return &zipgen->all if &$any_mutable;
|
498
|
0
|
0
|
|
|
|
0
|
if ($code) {
|
499
|
0
|
|
|
|
|
0
|
shift @_;
|
500
|
0
|
|
|
|
|
0
|
map {my $i = $_;
|
|
0
|
|
|
|
|
0
|
|
501
|
0
|
|
|
|
|
0
|
$code->(map $$_[$i] => @_)
|
502
|
|
|
|
|
|
|
} 0 .. min map $#$_ => @_
|
503
|
|
|
|
|
|
|
}
|
504
|
|
|
|
|
|
|
else {
|
505
|
0
|
|
|
|
|
0
|
map {my $i = $_;
|
|
0
|
|
|
|
|
0
|
|
506
|
0
|
|
|
|
|
0
|
map $$_[$i] => @_
|
507
|
|
|
|
|
|
|
} 0 .. min map $#$_ => @_
|
508
|
|
|
|
|
|
|
}
|
509
|
|
|
|
|
|
|
}
|
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
=item zipmax C< LIST >
|
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
interleaves the passed in lists to create a new list. C< zipmax > continues
|
515
|
|
|
|
|
|
|
until the end of the longest list, C< undef > is returned for missing elements
|
516
|
|
|
|
|
|
|
of shorter lists. C< LIST > can be any combination of array references and
|
517
|
|
|
|
|
|
|
generators.
|
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
%hash = zipmax [qw/a b c d/], [1..3]; # same as
|
520
|
|
|
|
|
|
|
%hash = (a => 1, b => 2, c => 3, d => undef);
|
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
in scalar context, C< zipmax > returns a generator, produced by C< zipgenmax >
|
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
C< zipmax > provides the same functionality as C< zip > did in versions before
|
525
|
|
|
|
|
|
|
0.90
|
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=cut
|
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
sub zipmax {
|
530
|
0
|
|
|
0
|
1
|
0
|
my $code;
|
531
|
0
|
0
|
|
|
|
0
|
unless ($_[0]->$is_array_or_gen) {
|
532
|
0
|
|
|
|
|
0
|
$code = shift;
|
533
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
534
|
0
|
|
|
|
|
0
|
unshift @_, $code;
|
535
|
|
|
|
|
|
|
}
|
536
|
0
|
0
|
|
|
|
0
|
local *zipgenmax = *zipwithmax if $code;
|
537
|
0
|
0
|
|
|
|
0
|
goto &zipgenmax unless wantarray;
|
538
|
0
|
0
|
|
|
|
0
|
return &zipgenmax->all if &$any_mutable;
|
539
|
0
|
0
|
|
|
|
0
|
if ($code) {
|
540
|
0
|
|
|
|
|
0
|
shift @_;
|
541
|
0
|
|
|
|
|
0
|
map {my $i = $_;
|
|
0
|
|
|
|
|
0
|
|
542
|
0
|
0
|
|
|
|
0
|
$code->(map {$i < @$_ ? $$_[$i] : undef} @_)
|
|
0
|
|
|
|
|
0
|
|
543
|
|
|
|
|
|
|
} 0 .. max map $#$_ => @_
|
544
|
|
|
|
|
|
|
}
|
545
|
|
|
|
|
|
|
else {
|
546
|
0
|
|
|
|
|
0
|
map {my $i = $_;
|
|
0
|
|
|
|
|
0
|
|
547
|
0
|
0
|
|
|
|
0
|
map {$i < @$_ ? $$_[$i] : undef} @_
|
|
0
|
|
|
|
|
0
|
|
548
|
|
|
|
|
|
|
} 0 .. max map $#$_ => @_
|
549
|
|
|
|
|
|
|
}
|
550
|
|
|
|
|
|
|
}
|
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
=item tuples C< LIST >
|
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
interleaves the passed in lists to create a new list of arrays. C< tuples >
|
556
|
|
|
|
|
|
|
continues until the end of the shortest list. C< LIST > can be any combination
|
557
|
|
|
|
|
|
|
of array references and generators.
|
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
@list = tuples [qw/a b c/], [1..3]; # same as
|
560
|
|
|
|
|
|
|
@list = ([a => 1], [b => 2], [c => 3]);
|
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
in scalar context, C< tuples > returns a generator:
|
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
tuples(...) ~~ zipwith {\@_} ...
|
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
=cut
|
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
sub tuples {
|
569
|
0
|
0
|
|
0
|
1
|
0
|
unless (wantarray) {
|
570
|
0
|
|
|
|
|
0
|
unshift @_, \∩
|
571
|
0
|
|
|
|
|
0
|
goto &zipwith
|
572
|
|
|
|
|
|
|
}
|
573
|
0
|
0
|
|
|
|
0
|
if (&$any_mutable) {
|
574
|
0
|
|
|
|
|
0
|
unshift @_, \∩
|
575
|
0
|
|
|
|
|
0
|
return &zipwith->all
|
576
|
|
|
|
|
|
|
}
|
577
|
0
|
|
|
|
|
0
|
map {my $i = $_;
|
|
0
|
|
|
|
|
0
|
|
578
|
0
|
|
|
|
|
0
|
cap (map $$_[$i] => @_)
|
579
|
|
|
|
|
|
|
} 0 .. min map $#$_ => @_
|
580
|
|
|
|
|
|
|
}
|
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
=item cap C< LIST >
|
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
C< cap > captures a list, it is exactly the same as C<< sub{\@_}->(LIST) >>
|
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
note that this method of constructing an array ref from a list is roughly 40%
|
588
|
|
|
|
|
|
|
faster than C< [ LIST ]>, but with the caveat and feature that elements are
|
589
|
|
|
|
|
|
|
aliases to the original list
|
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
=item C< &\(LIST) >
|
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
a synonym for C< cap >, the symbols C< &\(...) > will perform the same action.
|
594
|
|
|
|
|
|
|
it could be read as taking the subroutine style reference of a list. like all
|
595
|
|
|
|
|
|
|
symbol variables, once imported, C< &\ > is global across all packages.
|
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
my $capture = & \(my $x, my $y); # a space between & and \ is fine
|
598
|
|
|
|
|
|
|
# and it looks a bit more syntactic
|
599
|
|
|
|
|
|
|
($x, $y) = (1, 2);
|
600
|
|
|
|
|
|
|
say "@$capture"; # 1 2
|
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
=cut
|
603
|
|
|
|
|
|
|
|
604
|
51
|
|
|
51
|
1
|
169
|
sub cap {\@_}
|
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
=back
|
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
=head2 generators
|
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=over 4
|
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
in this document, a generator is an object similar to an array that generates
|
614
|
|
|
|
|
|
|
its elements on demand. generators can be used as iterators in perl's list
|
615
|
|
|
|
|
|
|
control structures such as C< for/foreach > and C< while >. generators, like
|
616
|
|
|
|
|
|
|
programmers, are lazy. unless they have to, they will not calculate or store
|
617
|
|
|
|
|
|
|
anything. this laziness allows infinite generators to be created. you can
|
618
|
|
|
|
|
|
|
choose to explicitly cache a generator, and several generators have implicit
|
619
|
|
|
|
|
|
|
caches for efficiency.
|
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
there are source generators, which can be numeric ranges, arrays, or iterative
|
622
|
|
|
|
|
|
|
subroutines. these can then be modified by wrapping each element with a
|
623
|
|
|
|
|
|
|
subroutine, filtering elements, or combining generators with other generators.
|
624
|
|
|
|
|
|
|
all of this behavior is lazy, only resolving generator elements at the latest
|
625
|
|
|
|
|
|
|
possible time.
|
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
all generator functions return a blessed and overloaded reference to a tied
|
628
|
|
|
|
|
|
|
array. this may sound a bit magical, but it just means that you can access
|
629
|
|
|
|
|
|
|
the generator in a variety of ways, all which remain lazy.
|
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
given the generator:
|
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
my $gen = gen {$_**2} range 0, 100;
|
634
|
|
|
|
|
|
|
or gen {$_**2} 0, 100;
|
635
|
|
|
|
|
|
|
or range(0, 100)->map(sub {$_**2});
|
636
|
|
|
|
|
|
|
or <0..100>->map('**2');
|
637
|
|
|
|
|
|
|
or <**2 for 0..100>;
|
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
which describes the sequence of C< n**2 for n from 0 to 100 by 1 >:
|
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
0 1 4 9 16 25 ... 9604 9801 10000
|
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
the following lines are equivalent (each prints C<'25'>):
|
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
say $gen->get(5);
|
646
|
|
|
|
|
|
|
say $gen->(5);
|
647
|
|
|
|
|
|
|
say $gen->[5];
|
648
|
|
|
|
|
|
|
say $gen->drop(5)->head;
|
649
|
|
|
|
|
|
|
say $gen->('5..')->head;
|
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
as are these (each printing C<'25 36 49 64 81 100'>):
|
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
say "@$gen[5 .. 10]";
|
654
|
|
|
|
|
|
|
say join ' ' => $gen->slice(5 .. 10);
|
655
|
|
|
|
|
|
|
say join ' ' => $gen->(5 .. 10);
|
656
|
|
|
|
|
|
|
say join ' ' => @$gen[5 .. 10];
|
657
|
|
|
|
|
|
|
say $gen->slice(range 5 => 10)->str;
|
658
|
|
|
|
|
|
|
say $gen->drop(5)->take(6)->str;
|
659
|
|
|
|
|
|
|
say $gen->(<5..10>)->str;
|
660
|
|
|
|
|
|
|
say $gen->('5..10')->str;
|
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
=back
|
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
=head3 generators as arrays
|
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
=over 4
|
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
you can access generators as if they were array references. only the requested
|
669
|
|
|
|
|
|
|
indicies will be generated.
|
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
my $range = range 0, 1_000_000, 0.2;
|
672
|
|
|
|
|
|
|
# will produce 0, 0.2, 0.4, ... 1000000
|
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
say "@$range[10 .. 15]"; # calculates 6 values: 2 2.2 2.4 2.6 2.8 3
|
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
my $gen = gen {$_**2} $range; # attaches a generator function to a range
|
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
say "@$gen[10 .. 15]"; # '4 4.84 5.76 6.76 7.84 9'
|
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
for (@$gen) {
|
681
|
|
|
|
|
|
|
last if $_ > some_condition;
|
682
|
|
|
|
|
|
|
# the iteration of this loop is lazy, so when exited
|
683
|
|
|
|
|
|
|
# with `last`, no extra values are generated
|
684
|
|
|
|
|
|
|
...
|
685
|
|
|
|
|
|
|
}
|
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
=back
|
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
=head3 generators in loops
|
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
=over 4
|
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
evaluation in each of these looping examples remains lazy. using C< last > to
|
694
|
|
|
|
|
|
|
escape from the loop early will result in some values never being generated.
|
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
... for @$gen;
|
697
|
|
|
|
|
|
|
for my $x (@$gen) {...}
|
698
|
|
|
|
|
|
|
... while <$gen>;
|
699
|
|
|
|
|
|
|
while (my ($next) = $gen->()) {...}
|
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
there are also looping methods, which take a subroutine. calling C< last > from
|
702
|
|
|
|
|
|
|
the subroutine works the same as in the examples above.
|
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
$gen->do(sub {...}); or ->each
|
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
For {$gen} sub {
|
707
|
|
|
|
|
|
|
... # indirect object syntax
|
708
|
|
|
|
|
|
|
};
|
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
there is also a user space subroutine named C< &last > that is installed into
|
711
|
|
|
|
|
|
|
the calling namespace during the execution of the loop. calling it without
|
712
|
|
|
|
|
|
|
arguments has the same function as the builtin C< last >. calling it with an
|
713
|
|
|
|
|
|
|
argument will still end the looping construct, but will also cause the loop to
|
714
|
|
|
|
|
|
|
return the argument. the C< done ... > exception also works the same way as
|
715
|
|
|
|
|
|
|
C< &last(...) >
|
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
my $first = $gen->do(sub {&last($_) if /something/});
|
718
|
|
|
|
|
|
|
# same as: $gen->first(qr/something/);
|
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
you can use generators as file handle iterators:
|
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
local $_;
|
723
|
|
|
|
|
|
|
while (<$gen>) { # calls $gen->next internally
|
724
|
|
|
|
|
|
|
# do something with $_
|
725
|
|
|
|
|
|
|
}
|
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
=back
|
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=head3 generators as objects
|
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
all generators have the following methods by default
|
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
=over 4
|
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
=item * B:
|
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
$gen->next # iterates over generator ~~ $gen->get($gen->index++)
|
738
|
|
|
|
|
|
|
$gen->() # same. iterators return () when past the end
|
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
$gen->more # test if $gen->index not past end
|
741
|
|
|
|
|
|
|
$gen->reset # reset iterator to start
|
742
|
|
|
|
|
|
|
$gen->reset(4) # $gen->next returns $$gen[4]
|
743
|
|
|
|
|
|
|
$gen->index # fetches the current position
|
744
|
|
|
|
|
|
|
$gen->index = 4 # same as $gen->reset(4)
|
745
|
|
|
|
|
|
|
$gen->nxt # next until defined
|
746
|
|
|
|
|
|
|
$gen->iterator # returns the $gen->next coderef iterator
|
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
=item * B:
|
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
$gen->get(index) # returns $$gen[index]
|
751
|
|
|
|
|
|
|
$gen->(index) # same
|
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
$gen->slice(4 .. 12) # returns @$gen[4 .. 12]
|
754
|
|
|
|
|
|
|
$gen->(4 .. 12) # same
|
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
$gen->size # returns 'scalar @$gen'
|
757
|
|
|
|
|
|
|
$gen->all # same as list context '@$gen' but faster
|
758
|
|
|
|
|
|
|
$gen->list # same as $gen->all
|
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
=item * B:
|
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
$gen->join(' ') # join ' ', $gen->all
|
763
|
|
|
|
|
|
|
$gen->str # join $", $gen->all (recursive with nested generators)
|
764
|
|
|
|
|
|
|
$gen->str(10) # limits generators to 10 elements
|
765
|
|
|
|
|
|
|
$gen->perl # serializes the generator in array syntax (recursive)
|
766
|
|
|
|
|
|
|
$gen->perl(9) # limits generators to 9 elements
|
767
|
|
|
|
|
|
|
$gen->perl(9, '...') # prints ... at the end of each truncated generator
|
768
|
|
|
|
|
|
|
$gen->print(...); # print $gen->str(...)
|
769
|
|
|
|
|
|
|
$gen->say(...); # print $gen->str(...), $/
|
770
|
|
|
|
|
|
|
$gen->say(*FH, ...) # print FH $gen->str(...), $/
|
771
|
|
|
|
|
|
|
$gen->dump(...) # print $gen->perl(...), $/
|
772
|
|
|
|
|
|
|
$gen->debug # carps debugging information
|
773
|
|
|
|
|
|
|
$gen->watch(...) # prints ..., value, $/ each time a value is requested
|
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
=item * B:
|
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
$gen->do(sub {...}) # for (@$gen) {...} # but faster
|
778
|
|
|
|
|
|
|
$gen->each(sub{...}) # same
|
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
=item * B:
|
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
$gen->head # $gen->get(0)
|
783
|
|
|
|
|
|
|
$gen->tail # $gen->slice(<1..>) # lazy slices
|
784
|
|
|
|
|
|
|
$gen->drop(2) # $gen->slice(<2..>)
|
785
|
|
|
|
|
|
|
$gen->take(4) # $gen->slice(<0..3>)
|
786
|
|
|
|
|
|
|
$gen->x_xs # ($gen->head, $gen->tail)
|
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
=item * B:
|
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
$gen->range # range(0, $gen->size - 1)
|
791
|
|
|
|
|
|
|
$gen->keys # same as $gen->range, but a list in list context
|
792
|
|
|
|
|
|
|
$gen->values # same as $gen, but a list in list context
|
793
|
|
|
|
|
|
|
$gen->kv # zip($gen->range, $gen)
|
794
|
|
|
|
|
|
|
$gen->pairs # same as ->kv, but each pair is a tuple (array ref)
|
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
=item * B:
|
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
$gen->pick # return a random element from $gen
|
799
|
|
|
|
|
|
|
$gen->pick(n) # return n random elements from $gen
|
800
|
|
|
|
|
|
|
$gen->roll # same as pick
|
801
|
|
|
|
|
|
|
$gen->roll(n) # pick and replace
|
802
|
|
|
|
|
|
|
$gen->shuffle # a lazy shuffled generator
|
803
|
|
|
|
|
|
|
$gen->random # an infinite generator that returns random elements
|
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=item * B:
|
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
$gen->first(sub {$_ > 5}) # first {$_ > 5} $gen->all # but faster
|
808
|
|
|
|
|
|
|
$gen->first('>5') # same
|
809
|
|
|
|
|
|
|
$gen->last(...) # $gen->reverse->first(...)
|
810
|
|
|
|
|
|
|
$gen->first_idx(...) # same as first, but returns the index
|
811
|
|
|
|
|
|
|
$gen->last_idx(...)
|
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
=item * B:
|
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
$gen->sort # sort $gen->all
|
816
|
|
|
|
|
|
|
$gen->sort(sub {$a <=> $b}) # sort {$a <=> $b} $gen->all
|
817
|
|
|
|
|
|
|
$gen->sort('<=>') # same
|
818
|
|
|
|
|
|
|
$gen->sort('uc', 'cmp') # does: map {$$_[0]}
|
819
|
|
|
|
|
|
|
# sort {$$a[1] cmp $$b[1]}
|
820
|
|
|
|
|
|
|
# map {[$_ => uc]} $gen->all
|
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=item * B:
|
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
$gen->reduce(sub {$a + $b}) # reduce {$a + $b} $gen->all
|
825
|
|
|
|
|
|
|
$gen->reduce('+') # same
|
826
|
|
|
|
|
|
|
$gen->sum # $gen->reduce('+')
|
827
|
|
|
|
|
|
|
$gen->product # $gen->reduce('*')
|
828
|
|
|
|
|
|
|
$gen->scan('+') # [$$gen[0], sum(@$gen[0..1]), sum(@$gen[0..2]), ...]
|
829
|
|
|
|
|
|
|
$gen->min # min $gen->all
|
830
|
|
|
|
|
|
|
$gen->max # max $gen->all
|
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
=item * B:
|
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
$gen->cycle # infinite repetition of a generator
|
835
|
|
|
|
|
|
|
$gen->rotate(1) # [$gen[1], $gen[2] ... $gen[-1], $gen[0]]
|
836
|
|
|
|
|
|
|
$gen->rotate(-1) # [$gen[-1], $gen[0], $gen[1] ... $gen[-2]]
|
837
|
|
|
|
|
|
|
$gen->uniq # $gen->filter(do {my %seen; sub {not $seen{$_}++}})
|
838
|
|
|
|
|
|
|
$gen->deref # tuples($a, $b)->deref ~~ zip($a, $b)
|
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
=item * B:
|
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
$gen->zip($gen2, ...) # takes any number of generators or array refs
|
843
|
|
|
|
|
|
|
$gen->cross($gen2) # cross product
|
844
|
|
|
|
|
|
|
$gen->cross2d($gen2) # returns a 2D generator containing the same
|
845
|
|
|
|
|
|
|
# elements as the flat ->cross generator
|
846
|
|
|
|
|
|
|
$gen->tuples($gen2) # tuples($gen, $gen2)
|
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
the C< zip > and the C< cross > methods all use the comma operator (C< ',' >)
|
849
|
|
|
|
|
|
|
by default to join their arguments. if the first argument to any of these
|
850
|
|
|
|
|
|
|
methods is code or a code like string, that will be used to join the arguments.
|
851
|
|
|
|
|
|
|
more detail in the overloaded operators section below
|
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
$gen->zip(',' => $gen2) # same as $gen->zip($gen2)
|
854
|
|
|
|
|
|
|
$gen->zip('.' => $gen2) # $gen[0].$gen2[0], $gen[1].$gen2[1], ...
|
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
=item * B:
|
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
$gen->type # returns the package name of the generator
|
859
|
|
|
|
|
|
|
$gen->is_mutable # can the generator change size?
|
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
=item * B:
|
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
$gen->apply # causes a mutable generator to determine its true size
|
864
|
|
|
|
|
|
|
$gen->clone # copy a generator, resets the index
|
865
|
|
|
|
|
|
|
$gen->copy # copy a generator, preserves the index
|
866
|
|
|
|
|
|
|
$gen->purge # purge any caches in the source chain
|
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
=item * B:
|
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
$gen->leaves # returns a coderef iterator that will perform a depth first
|
871
|
|
|
|
|
|
|
# traversal of the edge nodes in a tree of nested generators.
|
872
|
|
|
|
|
|
|
# a full run of the iterator will ->reset all of the internal
|
873
|
|
|
|
|
|
|
# generators
|
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=item * B:
|
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
$gen->while(...) # While {...} $gen
|
878
|
|
|
|
|
|
|
$gen->take_while(...) # same
|
879
|
|
|
|
|
|
|
$gen->drop_while(...) # $gen->drop( $gen->first_idx(sub {...}) )
|
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
$gen->span # collects $gen->next calls until one
|
882
|
|
|
|
|
|
|
# returns undef, then returns the collection.
|
883
|
|
|
|
|
|
|
# ->span starts from and moves the ->index
|
884
|
|
|
|
|
|
|
$gen->span(sub{...}) # span with an argument splits the list when the code
|
885
|
|
|
|
|
|
|
# returns false, it is equivalent to but more efficient
|
886
|
|
|
|
|
|
|
# than ($gen->take_while(...), $gen->drop_while(...))
|
887
|
|
|
|
|
|
|
$gen->break(...) # $gen->span(sub {not ...})
|
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
=item * B:
|
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
the methods duplicate and extend the tied functionality and are necessary when
|
892
|
|
|
|
|
|
|
working with indices outside of perl's array limit C< (0 .. 2**31 - 1) > or when
|
893
|
|
|
|
|
|
|
fetching a list return value (perl clamps the return to a scalar with the array
|
894
|
|
|
|
|
|
|
syntax). in all cases, they are also faster than the tied interface.
|
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
=item * B:
|
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
most of the functions in this package are also methods of generators, including
|
899
|
|
|
|
|
|
|
by, every, mapn, gen, map (alias of gen), filter, grep (alias of filter), test,
|
900
|
|
|
|
|
|
|
cache, flip, reverse (alias of flip), expand, collect, overlay, mutable, while,
|
901
|
|
|
|
|
|
|
until, recursive, rec (alias of recursive).
|
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
my $gen = (range 0, 1_000_000)->gen(sub{$_**2})->filter(sub{$_ % 2});
|
904
|
|
|
|
|
|
|
#same as: filter {$_ % 2} gen {$_**2} 0, 1_000_000;
|
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
=item * B:
|
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
when a method takes a code ref, that code ref can be specified as a string
|
909
|
|
|
|
|
|
|
containing an operator and an optional curried argument (on either side)
|
910
|
|
|
|
|
|
|
|
911
|
|
|
|
|
|
|
my $gen = <0 .. 1_000_000>->map('**2')->grep('%2'); # same as above
|
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
you can prefix C< ! > or C< not > to negate the operator:
|
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
my $even = <1..>->grep('!%2'); # sub {not $_ % 2}
|
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
you can even use a typeglob to specify an operator when the method expects a
|
918
|
|
|
|
|
|
|
binary subroutine:
|
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
say <1 .. 10>->reduce(*+); # 55 # and saves a character over '+'
|
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
or a regex ref:
|
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
<1..30>->grep(qr/3/)->say; # 3 13 23 30
|
925
|
|
|
|
|
|
|
|
926
|
|
|
|
|
|
|
you can flip the arguments to a binary operator by prefixing it with C< R > or
|
927
|
|
|
|
|
|
|
by applying the C< ~ > operator to it:
|
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
say ->reduce('R.'); # 'dcba' # lowercase r works too
|
930
|
|
|
|
|
|
|
say ->reduce(~'.'); # 'dcba'
|
931
|
|
|
|
|
|
|
say ->reduce(~*.); # 'dcba'
|
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
=item * B:
|
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
the methods that do not have a useful return value, such as C<< ->say >>,
|
936
|
|
|
|
|
|
|
return the same generator they were called with. this lets you easily insert
|
937
|
|
|
|
|
|
|
these methods at any point in a method chain for debugging.
|
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
=back
|
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
=head3 predicates
|
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
=over 4
|
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
several predicates are available to use with the filtering methods:
|
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
<1..>->grep('even' )->say(5); # 2 4 6 8 10
|
948
|
|
|
|
|
|
|
<1..>->grep('odd' )->say(5); # 1 3 5 7 9
|
949
|
|
|
|
|
|
|
<1..>->grep('prime')->say(5); # 2 3 5 7 11
|
950
|
|
|
|
|
|
|
<1.. if prime>->say(5); # 2 3 5 7 11
|
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
others are: defined, true, false
|
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
=back
|
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
=head3 lazy slices
|
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
=over 4
|
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
if you call the C< slice > method with a C< range > or other numeric generator
|
961
|
|
|
|
|
|
|
as its argument, the method will return a generator that will perform the slice
|
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
my $gen = gen {$_ ** 2};
|
964
|
|
|
|
|
|
|
my $slice = $gen->slice(range 100 => 1000); # nothing calculated
|
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
say "@$slice[5 .. 10]"; # 6 values calculated
|
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
or using the glob syntax:
|
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
my $slice = $gen->slice(<100 .. 1000>);
|
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
infinite slices are fine:
|
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
my $tail = $gen->slice(<1..>);
|
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
lazy slices also work with the dwim code-deref syntax:
|
977
|
|
|
|
|
|
|
|
978
|
|
|
|
|
|
|
my $tail = $gen->(<1..>);
|
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
stacked continuous lazy slices collapse into a single composite slice for
|
981
|
|
|
|
|
|
|
efficiency
|
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
my $slice = $gen->(<1..>)->(<1..>)->(<1..>);
|
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
$slice == $gen->(<3..>);
|
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
if you choose not to import the C< glob > function, you can still write ranges
|
988
|
|
|
|
|
|
|
succinctly as strings, when used as arguments to slice:
|
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
my $tail = $gen->('1..');
|
991
|
|
|
|
|
|
|
my $tail = $gen->slice('1..');
|
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
=back
|
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
=head3 dwim code dereference
|
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
=over 4
|
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
when dereferenced as code, a generator decides what do do based on the
|
1000
|
|
|
|
|
|
|
arguments it is passed.
|
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
$gen->() ~~ $gen->next
|
1003
|
|
|
|
|
|
|
$gen->(1) ~~ $gen->get(1) or $$gen[1]
|
1004
|
|
|
|
|
|
|
$gen->(1, 2, ...) ~~ $gen->slice(1, 2, ...) or @$gen[1, 2, ...]
|
1005
|
|
|
|
|
|
|
$gen->(<1..>) ~~ $gen->slice(<1..>) or $gen->tail
|
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
if passed a code ref or regex ref, C<< ->map >> will be called with the argument,
|
1008
|
|
|
|
|
|
|
if passed a reference to a code ref or regex ref, C<< ->grep >> will be called.
|
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
my $pow2 = <0..>->(sub {$_**2}); # calls ->map(sub{...})
|
1011
|
|
|
|
|
|
|
my $uc = $gen->(\qr/[A-Z]/); # calls ->grep(qr/.../)
|
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
you can lexically enable code coercion from strings (experimental):
|
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
local $List::Gen::DWIM_CODE_STRINGS = 1;
|
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
my $gen = <0 .. 1_000_000>->('**2')(\'%2');
|
1018
|
|
|
|
|
|
|
^map ^grep
|
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
due to some scoping issues, if you want to install this dwim coderef into
|
1021
|
|
|
|
|
|
|
a subroutine, the reliable way is to call the C<< ->code >> method:
|
1022
|
|
|
|
|
|
|
|
1023
|
|
|
|
|
|
|
*fib = <0, 1, *+*...>->code; # rather than *fib = \&{<0, 1, *+*...>}
|
1024
|
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
|
=back
|
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
=head3 overloaded operators
|
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
=over 4
|
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
to make the usage of generators a bit more syntactic the following operators
|
1032
|
|
|
|
|
|
|
are overridden:
|
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
$gen1 x $gen2 ~~ $gen1->cross($gen2)
|
1035
|
|
|
|
|
|
|
$gen1 x'.'x $gen2 ~~ $gen1->cross('.', $gen2)
|
1036
|
|
|
|
|
|
|
or $gen1->cross(sub {$_[0].$_[1]}, $gen2)
|
1037
|
|
|
|
|
|
|
$gen1 x sub{$_[0].$_[1]} x $gen2 # same as above
|
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
$gen1 + $gen2 ~~ sequence $gen1, $gen2
|
1040
|
|
|
|
|
|
|
$g1 + $g2 + $g3 ~~ sequence $g1, $g2, $g3 # or more
|
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
$gen1 | $gen2 ~~ $gen1->zip($gen2)
|
1043
|
|
|
|
|
|
|
$gen1 |'+'| $gen2 ~~ $gen1->zip('+', $gen2)
|
1044
|
|
|
|
|
|
|
or $gen1->zip(sub {$_[0] + $_[1]}, $gen2)
|
1045
|
|
|
|
|
|
|
$gen1 |sub{$_[0]+$_[1]}| $gen2 # same as above
|
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
$x | $y | $z ~~ $x->zip($y, $z)
|
1048
|
|
|
|
|
|
|
$w | $x | $y | $z ~~ $w->zip($x, $y, $z) # or more
|
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
if the first argument to a C<< ->zip >> or C<< ->cross >> method is not an
|
1051
|
|
|
|
|
|
|
array or generator, it is assumed to be a subroutine and the corresponding
|
1052
|
|
|
|
|
|
|
C<< ->(zip|cross)with >> method is called:
|
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
$gen1->zipwith('+', $gen2) ~~ $gen1->zip('+', $gen2);
|
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
B:
|
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
not quite as elegant as perl6's hyper operators, but the same idea. these are
|
1059
|
|
|
|
|
|
|
similar to C< zipwith > but with more control over the length of the returned
|
1060
|
|
|
|
|
|
|
generator. all of perl's non-mutating binary operators are available to use as
|
1061
|
|
|
|
|
|
|
strings, or you can use a subroutine.
|
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
$gen1 <<'.'>> $gen2 # longest list
|
1064
|
|
|
|
|
|
|
$gen1 >>'+'<< $gen2 # equal length lists or error
|
1065
|
|
|
|
|
|
|
$gen1 >>'-'>> $gen2 # length of $gen2
|
1066
|
|
|
|
|
|
|
$gen1 <<'=='<< $gen2 # length of $gen1
|
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
$gen1 <> $gen2
|
1069
|
|
|
|
|
|
|
$gen1 <<\&some_sub>> $gen2
|
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
my $x = <1..> <<'.'>> 'x';
|
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
$x->say(5); # '1x 2x 3x 4x 5x'
|
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
in the last example, a bare string is the final element, and precedence rules
|
1076
|
|
|
|
|
|
|
keep everything working. however, if you want to use a non generator as the
|
1077
|
|
|
|
|
|
|
first element, a few parens are needed to force the evaluation properly:
|
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
my $y = 'y' <<('.'>> <1..>);
|
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
$y->say(5); # 'y1 y2 y3 y4 y5'
|
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
otherwise C<<< 'y' << '.' >>> will run first without overloading, which will be
|
1084
|
|
|
|
|
|
|
an error. since that is a bit awkward, where you can specify an operator string,
|
1085
|
|
|
|
|
|
|
you can prefix C< R > or C< r > to indicate that the arguments to the operator
|
1086
|
|
|
|
|
|
|
should be reversed.
|
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
my $y = <1..> <<'R.'>> 'y';
|
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
$y->say(5); # 'y1 y2 y3 y4 y5'
|
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
just like in perl6, hyper operators are recursively defined for multi
|
1093
|
|
|
|
|
|
|
dimensional generators.
|
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
say +(list(<1..>, <2..>, <3..>) >>'*'>> -1)->perl(4, '...')
|
1096
|
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
|
# [[-1, -2, -3, -4, ...], [-2, -3, -4, -5, ...], [-3, -4, -5, -6, ...]]
|
1098
|
|
|
|
|
|
|
|
1099
|
|
|
|
|
|
|
hyper operators currently do not work with mutable generators. this will be
|
1100
|
|
|
|
|
|
|
addressed in a future update.
|
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
you can also specify the operator in a hyper-operator as a typeglob:
|
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
my $xs = <1..> >>*.>> 'x'; # *. is equivalent to '.'
|
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
$xs->say(5); # 1x 2x 3x 4x 5x
|
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
my $negs = <0..> >>*-; # same as: <0..> >>'-'
|
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
$negs->say(5); # 0 -1 -2 -3 -4
|
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
hyper also works as a method:
|
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
<1..>->hyper('<<.>>', 'x')->say(5); # '1x 2x 3x 4x 5x'
|
1115
|
|
|
|
|
|
|
# defaults to '<<...>>'
|
1116
|
|
|
|
|
|
|
<1..>->hyper('.', 'x')->say(5); # '1x 2x 3x 4x 5x'
|
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
hyper negation can be done directly with the prefix minus operator:
|
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
-$gen ~~ $gen >>'-' ~~ $gen->hyper('-')
|
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
=back
|
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
=head3 mutable generators
|
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
=over 4
|
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
mutable generators (those returned from mutable, filter, While, Until, and
|
1129
|
|
|
|
|
|
|
iterate_multi) are generators with variable length. in addition to all normal
|
1130
|
|
|
|
|
|
|
methods, mutable generators have the following methods:
|
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
$gen->when_done(sub {...}) # schedule a method to be called when the
|
1133
|
|
|
|
|
|
|
# generator is exhausted
|
1134
|
|
|
|
|
|
|
# when_done can be called multiple times to
|
1135
|
|
|
|
|
|
|
# schedule multiple end actions
|
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
$gen->apply; # causes the generator to evaluate all of its elements in
|
1138
|
|
|
|
|
|
|
# order to find out its true size. it is a bad idea to call
|
1139
|
|
|
|
|
|
|
# ->apply on an infinite generator
|
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
due to the way perl processes list operations, when perl sees an expression
|
1142
|
|
|
|
|
|
|
like:
|
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
print "@$gen\n"; # or
|
1145
|
|
|
|
|
|
|
print join ' ' => @$gen;
|
1146
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
it calls the internal C< FETCHSIZE > method only once, before it starts getting
|
1148
|
|
|
|
|
|
|
elements from the array. this is fine for immutable generators. however, since
|
1149
|
|
|
|
|
|
|
mutable generators do not know their true size, perl will think the array is
|
1150
|
|
|
|
|
|
|
bigger than it really is, and will most likely run off the end of the list,
|
1151
|
|
|
|
|
|
|
returning many undefined elements, or throwing an exception.
|
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
the solution to this is to call C<< $gen->apply >> first, or to use the
|
1154
|
|
|
|
|
|
|
C<< $gen->all >> method with mutable generators instead of C< @$gen >, since
|
1155
|
|
|
|
|
|
|
the C<< ->all >> method understands how to deal with arrays that can change size
|
1156
|
|
|
|
|
|
|
while being read.
|
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
perl's C< for/foreach > loop is a bit smarter, so just like immutable
|
1159
|
|
|
|
|
|
|
generators, the mutable ones can be dereferenced as the loop argument with no
|
1160
|
|
|
|
|
|
|
problem:
|
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
... foreach @$mutable_generator; # works fine
|
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
=back
|
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
=head3 stream generators
|
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
=over 4
|
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
the generators C, C, and C (all of its flavors) have
|
1171
|
|
|
|
|
|
|
internal caches that allow random access within the generator. some algorithms
|
1172
|
|
|
|
|
|
|
only need monotonically increasing access to the generator (all access via
|
1173
|
|
|
|
|
|
|
repeated calls to C<< $gen->next >> for example), and the cache could become a
|
1174
|
|
|
|
|
|
|
performance/memory problem.
|
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
the C< *_stream > family of generators do not maintain an internal cache, and
|
1177
|
|
|
|
|
|
|
are subsequently unable to fulfill requests for indicies lower than or equal to
|
1178
|
|
|
|
|
|
|
the last accessed index. they will however be faster and use less memory than
|
1179
|
|
|
|
|
|
|
their non-stream counterparts when monotonically increasing access is all that
|
1180
|
|
|
|
|
|
|
an algorithm needs.
|
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
stream generators can be thought of as traditional subroutine iterators that
|
1183
|
|
|
|
|
|
|
also have generator methods. it is up to you to ensure that all operations and
|
1184
|
|
|
|
|
|
|
methods follow the monotonically increasing index rule. you can determine the
|
1185
|
|
|
|
|
|
|
current position of the stream iterator with the C<< $gen->index >> method.
|
1186
|
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
|
my $nums = iterate_stream{2*$_}->from(1);
|
1188
|
|
|
|
|
|
|
|
1189
|
|
|
|
|
|
|
say $nums->(); # 1
|
1190
|
|
|
|
|
|
|
say $nums->(); # 2
|
1191
|
|
|
|
|
|
|
say $nums->(); # 4
|
1192
|
|
|
|
|
|
|
say $nums->index; # 3
|
1193
|
|
|
|
|
|
|
say $nums->drop( $nums->index )->str(5); # '8 16 32 64 128'
|
1194
|
|
|
|
|
|
|
say $nums->index; # 8
|
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
the C<< $gen->drop( $gen->index )->method >> pattern can be shortened to
|
1197
|
|
|
|
|
|
|
C<< $gen->idx->method >>
|
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
say $nums->idx->str(5); # '256 512 1024 2048 4096'
|
1200
|
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
the C<< $gen->index >> method of stream generators is read only. calling
|
1202
|
|
|
|
|
|
|
C<< $gen->reset >> on a stream generator will throw an error.
|
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
stream generators are experimental and may change in future versions.
|
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
=back
|
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
=head3 threads
|
1209
|
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
|
=over 4
|
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
generators have the following multithreaded methods:
|
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
$gen->threads_blocksize(3) # sets size to divide work into
|
1215
|
|
|
|
|
|
|
$gen->threads_cached; # implements a threads::shared cache
|
1216
|
|
|
|
|
|
|
$gen->threads_cached(10) # as normal, then calls threads_start with arg
|
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
$gen->threads_start; # creates 4 worker threads
|
1219
|
|
|
|
|
|
|
$gen->threads_start(2); # or however many you want
|
1220
|
|
|
|
|
|
|
# if you don't call it, threads_slice will
|
1221
|
|
|
|
|
|
|
|
1222
|
|
|
|
|
|
|
my @list = $gen->threads_slice(0 .. 1000); # sends work to the threads
|
1223
|
|
|
|
|
|
|
my @list = $gen->threads_all;
|
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
$gen->threads_stop; # or let the generator fall out of scope
|
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
all threads are local to a particular generator, they are not shared.
|
1228
|
|
|
|
|
|
|
if the passed in generator was cached (at the top level) that cache is shared
|
1229
|
|
|
|
|
|
|
and used automatically. this includes most generators with implicit caches.
|
1230
|
|
|
|
|
|
|
threads_slice and threads_all can be called without starting the threads
|
1231
|
|
|
|
|
|
|
explicitly. in that case, they will start with default values.
|
1232
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
the threaded methods only work in perl versions 5.10.1 to 5.12.x, patches to
|
1234
|
|
|
|
|
|
|
support other versions are welcome.
|
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
=back
|
1237
|
|
|
|
|
|
|
|
1238
|
|
|
|
|
|
|
=cut
|
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
{package
|
1241
|
|
|
|
|
|
|
List::Gen::Base;
|
1242
|
|
|
|
|
|
|
for my $sub (qw(TIEARRAY FETCH STORE STORESIZE CLEAR PUSH
|
1243
|
|
|
|
|
|
|
POP SHIFT UNSHIFT SPLICE UNTIE EXTEND)) {
|
1244
|
10
|
|
|
10
|
|
94
|
no strict 'refs';
|
|
10
|
|
|
|
|
35
|
|
|
10
|
|
|
|
|
2063
|
|
1245
|
0
|
|
|
0
|
|
0
|
*$sub = sub {Carp::confess "$sub(".(join ', ' => @_).") not supported"}
|
1246
|
|
|
|
|
|
|
}
|
1247
|
134
|
|
|
134
|
|
219
|
sub DESTROY {}
|
1248
|
130
|
|
|
130
|
|
560
|
sub source {}
|
1249
|
|
|
|
|
|
|
sub FETCHSIZE {
|
1250
|
7
|
|
|
7
|
|
10
|
my $self = shift;
|
1251
|
7
|
|
|
|
|
15
|
my $install = (ref $self).'::FETCHSIZE';
|
1252
|
7
|
|
|
|
|
14
|
my $fsize = $self->can('fsize');
|
1253
|
|
|
|
|
|
|
my $fetchsize = sub {
|
1254
|
7
|
|
|
7
|
|
11
|
my $size = $fsize->();
|
1255
|
7
|
50
|
|
|
|
16
|
$size > 2**31-1
|
1256
|
|
|
|
|
|
|
? 2**31-1
|
1257
|
|
|
|
|
|
|
: $size
|
1258
|
7
|
|
|
|
|
24
|
};
|
1259
|
10
|
|
|
10
|
|
64
|
no strict 'refs';
|
|
10
|
|
|
|
|
35
|
|
|
10
|
|
|
|
|
3843
|
|
1260
|
7
|
|
|
|
|
11
|
my $size = $fetchsize->();
|
1261
|
14
|
|
|
14
|
|
36
|
*$install = $self->mutable
|
1262
|
|
|
|
|
|
|
? $fetchsize
|
1263
|
7
|
50
|
|
|
|
40
|
: sub {$size};
|
1264
|
7
|
|
|
|
|
44
|
$size
|
1265
|
|
|
|
|
|
|
}
|
1266
|
|
|
|
|
|
|
sub mutable {
|
1267
|
128
|
|
|
128
|
|
239
|
my @src = shift;
|
1268
|
128
|
|
|
|
|
147
|
my %seen;
|
1269
|
128
|
|
|
|
|
342
|
while (my $src = shift @src) {
|
1270
|
172
|
50
|
|
|
|
603
|
next if $seen{$src}++;
|
1271
|
172
|
50
|
|
|
|
1373
|
return 1 if $src->isa('List::Gen::Mutable');
|
1272
|
172
|
100
|
|
|
|
660
|
if (my $source = $src->source) {
|
1273
|
42
|
100
|
|
|
|
189
|
push @src, ref $source eq 'ARRAY' ? @$source : $source
|
1274
|
|
|
|
|
|
|
}
|
1275
|
|
|
|
|
|
|
}
|
1276
|
|
|
|
|
|
|
''
|
1277
|
128
|
|
|
|
|
599
|
}
|
1278
|
|
|
|
|
|
|
sub sources {
|
1279
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
1280
|
0
|
0
|
|
|
|
0
|
my $src = $self->source or return;
|
1281
|
0
|
0
|
|
|
|
0
|
if (ref $src eq 'ARRAY')
|
|
0
|
|
|
|
|
0
|
|
1282
|
0
|
|
|
|
|
0
|
{@$src, map $_->sources, @$src}
|
1283
|
|
|
|
|
|
|
else {$src, $src->sources}
|
1284
|
|
|
|
|
|
|
}
|
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
sub tail_size {
|
1287
|
0
|
|
|
0
|
|
0
|
$_[1] = List::Gen::TailSize->new($_[0]->can('fsize'))
|
1288
|
|
|
|
|
|
|
}
|
1289
|
|
|
|
|
|
|
{package
|
1290
|
|
|
|
|
|
|
List::Gen::TailSize;
|
1291
|
0
|
|
|
0
|
|
0
|
sub new {bless [pop]}
|
1292
|
0
|
|
|
0
|
|
0
|
use overload fallback => 1, '0+' => sub {&{$_[0][0]}}
|
|
0
|
|
|
|
|
0
|
|
1293
|
10
|
|
|
10
|
|
59
|
}
|
|
10
|
|
|
|
|
19
|
|
|
10
|
|
|
|
|
188
|
|
1294
|
|
|
|
|
|
|
|
1295
|
|
|
|
|
|
|
sub closures {
|
1296
|
176
|
50
|
33
|
|
|
1518
|
map {
|
|
|
|
33
|
|
|
|
|
1297
|
88
|
|
|
88
|
|
137
|
Scalar::Util::reftype($_[0]) eq 'HASH' && $_[0]{$_}
|
1298
|
|
|
|
|
|
|
or $_[0]->can($_)
|
1299
|
|
|
|
|
|
|
or Carp::confess("no $_ on $_[0]")
|
1300
|
|
|
|
|
|
|
} qw (FETCH fsize)
|
1301
|
|
|
|
|
|
|
}
|
1302
|
|
|
|
|
|
|
}
|
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
my $op2cv = do {
|
1305
|
|
|
|
|
|
|
my %unary_only = map {$_ => 1} qw (! \ ~);
|
1306
|
|
|
|
|
|
|
my %unary_ok = map {$_ => 1} qw (+ - not);
|
1307
|
|
|
|
|
|
|
sub {
|
1308
|
|
|
|
|
|
|
my $op = shift;
|
1309
|
|
|
|
|
|
|
my $src = $unary_only{$op} ? "sub {\@_ ? $op \$_[0] : $op \$_}"
|
1310
|
|
|
|
|
|
|
: 'sub ($$) {'.
|
1311
|
|
|
|
|
|
|
($unary_ok{$op} ? "
|
1312
|
|
|
|
|
|
|
if (\@_ == 0) {return ($op \$_)}
|
1313
|
|
|
|
|
|
|
if (\@_ == 1) {return ($op \$_[0])}
|
1314
|
|
|
|
|
|
|
" : "
|
1315
|
|
|
|
|
|
|
if (\@_ == 0) {return (\$a $op \$b)}
|
1316
|
|
|
|
|
|
|
if (\@_ == 1) {Carp::croak(q(too few arguments for '$op'))}
|
1317
|
|
|
|
|
|
|
") ."
|
1318
|
|
|
|
|
|
|
if (\@_ == 2) {return (\$_[0] $op \$_[1])}
|
1319
|
|
|
|
|
|
|
reduce {\$a $op \$b} \@_
|
1320
|
|
|
|
|
|
|
}";
|
1321
|
|
|
|
|
|
|
eval $src or die "$@\n$src"
|
1322
|
|
|
|
|
|
|
}
|
1323
|
|
|
|
|
|
|
};
|
1324
|
|
|
|
|
|
|
my %ops = map {$_ => $_->$op2cv} qw (
|
1325
|
|
|
|
|
|
|
+ - / * ** x % . & | ^ < > << >> <=> cmp lt gt eq ne le ge == != <= >=
|
1326
|
|
|
|
|
|
|
and or xor && || =~ !~
|
1327
|
|
|
|
|
|
|
! \ ~
|
1328
|
|
|
|
|
|
|
);
|
1329
|
|
|
|
|
|
|
my $ops = join '|' =>
|
1330
|
|
|
|
|
|
|
map {('\b' x /^\w/).(quotemeta).('\b' x /\w$/)}
|
1331
|
|
|
|
|
|
|
sort {length $b <=> length $a}
|
1332
|
|
|
|
|
|
|
grep {$_ ne '\\'}
|
1333
|
|
|
|
|
|
|
keys %ops, ',';
|
1334
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
$ops{','} = my $comma = sub ($$) {$_[0], $_[1]};
|
1336
|
|
|
|
|
|
|
$ops{'R,'} =
|
1337
|
|
|
|
|
|
|
$ops{'r,'} = my $rcomma = sub ($$) {$_[1], $_[0]};
|
1338
|
|
|
|
|
|
|
$ops{even} = sub ($) { not + (@_ ? $_[0] : $_) % 2};
|
1339
|
|
|
|
|
|
|
$ops{odd} = sub ($) { (@_ ? $_[0] : $_) % 2};
|
1340
|
|
|
|
|
|
|
$ops{defined} = sub ($) {defined (@_ ? $_[0] : $_)};
|
1341
|
|
|
|
|
|
|
$ops{true} = sub ($) {not not @_ ? $_[0] : $_};
|
1342
|
|
|
|
|
|
|
$ops{false} = sub ($) { not @_ ? $_[0] : $_};
|
1343
|
|
|
|
|
|
|
$ops{reverse} = sub ($) {scalar reverse (@_ ? $_[0] : $_)};
|
1344
|
|
|
|
|
|
|
$ops{say} = sub ($) {print @_ ? @_ : $_, $/; @_ ? @_[0..$#_] : $_};
|
1345
|
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
|
$sv2cv = sub {
|
1347
|
|
|
|
|
|
|
defined $_[0] or croak 'an undefined value can not be coerced into code';
|
1348
|
|
|
|
|
|
|
local $_ = $_[0];
|
1349
|
|
|
|
|
|
|
return $_ if ref and reftype($_) eq 'CODE';
|
1350
|
|
|
|
|
|
|
$_[0] = ($ops{$_} or do {
|
1351
|
|
|
|
|
|
|
$ops{$_} = do {
|
1352
|
|
|
|
|
|
|
if (ref eq ref qr//) {
|
1353
|
|
|
|
|
|
|
my $re = $_;
|
1354
|
|
|
|
|
|
|
sub {/$re/}
|
1355
|
|
|
|
|
|
|
}
|
1356
|
|
|
|
|
|
|
elsif (ref \$_ eq 'GLOB') {
|
1357
|
|
|
|
|
|
|
my $op = B::svref_2object(\$_)->NAME;
|
1358
|
|
|
|
|
|
|
$ops{$op} or $op->$sv2cv
|
1359
|
|
|
|
|
|
|
}
|
1360
|
|
|
|
|
|
|
elsif (ref and overload::Method($_, '&{}')) {
|
1361
|
|
|
|
|
|
|
\&{$_}
|
1362
|
|
|
|
|
|
|
}
|
1363
|
|
|
|
|
|
|
elsif ($ops{~$_}
|
1364
|
|
|
|
|
|
|
or /^[Rr]\s*($ops)\s*$/
|
1365
|
|
|
|
|
|
|
or ~$_ =~ /^\*main::($ops)$/
|
1366
|
|
|
|
|
|
|
) {
|
1367
|
|
|
|
|
|
|
my $op = $ops{$1 ? $1 : ~$_};
|
1368
|
|
|
|
|
|
|
sub ($$) {$op->(reverse @_)}
|
1369
|
|
|
|
|
|
|
}
|
1370
|
|
|
|
|
|
|
elsif (/[\$\@]\s*_\b/) {
|
1371
|
|
|
|
|
|
|
'$_/@_'->$eval("sub (\$) {$_}")
|
1372
|
|
|
|
|
|
|
}
|
1373
|
|
|
|
|
|
|
elsif (/\$a(?:\b|$)/ and /\$b(?:\b|$)/) {
|
1374
|
|
|
|
|
|
|
# $a $b:
|
1375
|
|
|
|
|
|
|
s{\$a(?:\b(?!\s*[\[\}])|$)} '$_[0]'gx;
|
1376
|
|
|
|
|
|
|
s{\$b(?:\b(?!\s*[\[\}])|$)} '$_[1]'gx;
|
1377
|
|
|
|
|
|
|
# $a[1] $b[1]:
|
1378
|
|
|
|
|
|
|
s{(?
|
1379
|
|
|
|
|
|
|
s{(?
|
1380
|
|
|
|
|
|
|
# $$a[1] $$b[1]:
|
1381
|
|
|
|
|
|
|
s{\$a(?:\b|$)} '${\$_[0]}'gx;
|
1382
|
|
|
|
|
|
|
s{\$b(?:\b|$)} '${\$_[1]}'gx;
|
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
'$a $b'->$eval('sub ($$) '."{$_}")
|
1385
|
|
|
|
|
|
|
}
|
1386
|
|
|
|
|
|
|
elsif (not m[/.+/]
|
1387
|
|
|
|
|
|
|
and /^ \s* ( ! | not\b | ) \s*
|
1388
|
|
|
|
|
|
|
(?: (.+?) \s* ($ops) | ($ops) \s* (.+?) )
|
1389
|
|
|
|
|
|
|
\s* $/x
|
1390
|
|
|
|
|
|
|
) {
|
1391
|
|
|
|
|
|
|
my $arg = $2 ? $2 : $5;
|
1392
|
|
|
|
|
|
|
my $op = $ops{$2 ? $3 : $4};
|
1393
|
|
|
|
|
|
|
if ($1) {
|
1394
|
|
|
|
|
|
|
my $normal = $op;
|
1395
|
|
|
|
|
|
|
$op = sub {not &$normal}
|
1396
|
|
|
|
|
|
|
}
|
1397
|
|
|
|
|
|
|
$arg = 'curry'->$eval($arg) unless looks_like_number $arg;
|
1398
|
|
|
|
|
|
|
$2 ? sub ($) {$op->($arg, @_ ? $_[0] : $_)}
|
1399
|
|
|
|
|
|
|
: sub ($) {$op->(@_ ? $_[0] : $_, $arg)}
|
1400
|
|
|
|
|
|
|
}
|
1401
|
|
|
|
|
|
|
elsif (/^[a-zA-Z_][\w\s]*$/) {
|
1402
|
|
|
|
|
|
|
'bareword'->$eval("sub (\$) {$_(\$_)}")
|
1403
|
|
|
|
|
|
|
}
|
1404
|
|
|
|
|
|
|
elsif (/^ \s*(?:not|!|)\s* (?: ( [sy] | tr ) | m | (?=\s*\/) ) \s*
|
1405
|
|
|
|
|
|
|
( [^\w\s] | (?<= \s )\w ) .* (?: \2 | [\}\)\]] )
|
1406
|
|
|
|
|
|
|
[a-z]* \s* $/x
|
1407
|
|
|
|
|
|
|
) {
|
1408
|
|
|
|
|
|
|
$_ = '(my $x = $_) =~ '.$_.'; $x' if $1;
|
1409
|
|
|
|
|
|
|
'regex'->$eval("sub (\$) {$_}")
|
1410
|
|
|
|
|
|
|
}
|
1411
|
|
|
|
|
|
|
}
|
1412
|
|
|
|
|
|
|
} or Carp::croak "error, no dwim code type found for: '$_[0]'")
|
1413
|
|
|
|
|
|
|
};
|
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
{package
|
1416
|
|
|
|
|
|
|
List::Gen::Hyper;
|
1417
|
0
|
|
|
|
|
0
|
use overload fallback => 1,
|
1418
|
0
|
|
|
0
|
|
0
|
'&{}' => sub {\&{$_[0]->self}},
|
1419
|
20
|
|
|
|
|
45
|
map {
|
1420
|
10
|
|
|
|
|
82
|
my $op = $_;
|
1421
|
|
|
|
|
|
|
$op => sub {
|
1422
|
5
|
|
|
5
|
|
10
|
my ($x, $y, $flip) = @_;
|
1423
|
5
|
50
|
|
|
|
20
|
hyper ($flip ? ($y, $op, @$x) : (@$x, $op, $y))
|
1424
|
|
|
|
|
|
|
}
|
1425
|
10
|
|
|
10
|
|
31897
|
} qw (<< >>);
|
|
10
|
|
|
|
|
100
|
|
|
20
|
|
|
|
|
151
|
|
1426
|
0
|
|
|
0
|
|
0
|
sub DESTROY {}
|
1427
|
|
|
|
|
|
|
sub AUTOLOAD {
|
1428
|
0
|
|
|
0
|
|
0
|
my ($method) = our $AUTOLOAD =~ /([^:']+)$/;
|
1429
|
0
|
0
|
|
|
|
0
|
my ($op, $gen) = @{$_[0]}[List::Gen::isagen($_[0][0]) ? (2,0) : (0,2)];
|
|
0
|
|
|
|
|
0
|
|
1430
|
0
|
|
|
|
|
0
|
$gen->hyper($op)->$method(@_[1..$#_])
|
1431
|
|
|
|
|
|
|
}
|
1432
|
|
|
|
|
|
|
my %cache;
|
1433
|
|
|
|
|
|
|
sub hyper {
|
1434
|
5
|
|
|
5
|
|
12
|
my ($left, $lh, $code, $rh, $right) = @_;
|
1435
|
5
|
50
|
|
|
|
22
|
$code->$sv2cv unless ref $code eq 'CODE';
|
1436
|
5
|
|
|
|
|
14
|
for ($left, $right) {
|
1437
|
10
|
100
|
|
|
|
17
|
next if &List::Gen::isagen($_);
|
1438
|
5
|
|
|
|
|
8
|
my $src = $_;
|
1439
|
5
|
100
|
|
|
|
13
|
if (ref $src eq 'ARRAY') {
|
1440
|
1
|
|
|
|
|
4
|
$_ = &List::Gen::makegen($src);
|
1441
|
|
|
|
|
|
|
} else {
|
1442
|
4
|
|
|
40
|
|
16
|
$_ = &List::Gen::gen(sub {$src}, 1);
|
|
40
|
|
|
|
|
80
|
|
1443
|
|
|
|
|
|
|
}
|
1444
|
|
|
|
|
|
|
}
|
1445
|
5
|
50
|
33
|
|
|
19
|
if ($left->is_mutable or $right->is_mutable) {
|
1446
|
0
|
|
|
|
|
0
|
Carp::croak('hyper operators not yet supported with mutable generators')
|
1447
|
|
|
|
|
|
|
} else {
|
1448
|
5
|
|
|
|
|
19
|
my ($lsize, $rsize) = map tied(@$_)->fsize => $left, $right;
|
1449
|
|
|
|
|
|
|
my $size =
|
1450
|
|
|
|
|
|
|
($lh eq '<<' and $rh eq '>>') ? List::Util::max($lsize, $rsize)
|
1451
|
|
|
|
|
|
|
: $lh eq '<<' ? $rsize
|
1452
|
|
|
|
|
|
|
: $rh eq '>>' ? $lsize
|
1453
|
5
|
50
|
66
|
|
|
40
|
: do {
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1454
|
0
|
0
|
|
|
|
0
|
Carp::croak("unequal size lists passed to non-dwimmy hyper")
|
1455
|
|
|
|
|
|
|
if $lsize != $rsize;
|
1456
|
0
|
|
|
|
|
0
|
$lsize
|
1457
|
|
|
|
|
|
|
};
|
1458
|
5
|
50
|
66
|
|
|
36
|
for my $src (($lh eq '<<' and $lsize < $size) ? $left : (),
|
|
|
50
|
33
|
|
|
|
|
1459
|
|
|
|
|
|
|
($rh eq '>>' and $rsize < $size) ? $right : ()) {
|
1460
|
5
|
|
|
|
|
22
|
my $fetch = tied(@$src)->can('FETCH');
|
1461
|
5
|
|
|
|
|
11
|
my $src_size = tied(@$src)->fsize;
|
1462
|
5
|
|
|
50
|
|
26
|
$src = &List::Gen::gen(sub {$fetch->(undef, $_ % $src_size)}, $size)
|
|
50
|
|
|
|
|
82
|
|
1463
|
|
|
|
|
|
|
}
|
1464
|
5
|
|
|
|
|
445
|
my ($lfetch, $rfetch) = map tied(@$_)->can('FETCH') => $left, $right;
|
1465
|
|
|
|
|
|
|
$code == $comma
|
1466
|
|
|
|
|
|
|
? &List::Gen::gen(sub {
|
1467
|
0
|
0
|
|
0
|
|
0
|
my $got = $_ % 2 ? $rfetch->(undef, int($_/2))
|
1468
|
|
|
|
|
|
|
: $lfetch->(undef, int($_/2));
|
1469
|
0
|
0
|
|
|
|
0
|
if (ref $got) {
|
1470
|
0
|
0
|
0
|
|
|
0
|
if (ref $got eq 'ARRAY' or List::Gen::isagen($got)) {
|
1471
|
0
|
|
|
|
|
0
|
Carp::croak("hyper comma not yet supported with multi-dimentional generators");
|
1472
|
|
|
|
|
|
|
#my $other = ($_ % 2 ? $lfetch : $rfetch)->(undef, int($_/2));
|
1473
|
|
|
|
|
|
|
#my ($l, $r) = $_ % 2 ? ($other, $got) : ($got, $other);
|
1474
|
|
|
|
|
|
|
#return $cache{join $; => $l, $lh, $code, $rh, $r}
|
1475
|
|
|
|
|
|
|
# ||= hyper($l, $lh, $code, $rh, $r);
|
1476
|
|
|
|
|
|
|
}
|
1477
|
|
|
|
|
|
|
}
|
1478
|
|
|
|
|
|
|
$got
|
1479
|
0
|
|
|
|
|
0
|
}, $size * 2)
|
1480
|
|
|
|
|
|
|
: &List::Gen::gen(sub {
|
1481
|
50
|
|
|
50
|
|
80
|
my $l = $lfetch->(undef, $_);
|
1482
|
50
|
|
|
|
|
79
|
my $r = $rfetch->(undef, $_);
|
1483
|
50
|
|
|
|
|
134
|
for (grep ref, $l, $r) {
|
1484
|
0
|
0
|
0
|
|
|
0
|
if (ref $_ eq 'ARRAY' or &List::Gen::isagen($_)) {
|
1485
|
0
|
|
0
|
|
|
0
|
return $cache{join $; => $l, $lh, $code, $rh, $r}
|
1486
|
|
|
|
|
|
|
||= hyper($l, $lh, $code, $rh, $r)
|
1487
|
|
|
|
|
|
|
}
|
1488
|
|
|
|
|
|
|
}
|
1489
|
50
|
|
|
|
|
203
|
$code->($l, $r)
|
1490
|
5
|
50
|
|
|
|
37
|
}, $size)
|
1491
|
|
|
|
|
|
|
}
|
1492
|
|
|
|
|
|
|
}
|
1493
|
|
|
|
|
|
|
}
|
1494
|
|
|
|
|
|
|
{
|
1495
|
|
|
|
|
|
|
my $build; BEGIN {$build = sub {
|
1496
|
20
|
|
|
|
|
42
|
my $method = shift;
|
1497
|
|
|
|
|
|
|
sub {
|
1498
|
8
|
|
|
8
|
|
18
|
my ($self, $ys, $flip) = @_;
|
1499
|
8
|
|
|
|
|
22
|
my ($code, $xs) = @$self{qw(code xs)};
|
1500
|
8
|
|
|
|
|
22
|
$code->$sv2cv;
|
1501
|
8
|
50
|
|
|
|
18
|
($xs, $ys) = ($ys, $xs) if $flip;
|
1502
|
8
|
|
|
|
|
19
|
for ($xs, $ys) {
|
1503
|
16
|
50
|
|
|
|
30
|
next if isagen(my $x = $_);
|
1504
|
0
|
0
|
0
|
|
|
0
|
$_ = ref && reftype($_) eq 'ARRAY'
|
|
|
0
|
|
|
|
|
|
1505
|
|
|
|
|
|
|
? &makegen($_)
|
1506
|
|
|
|
|
|
|
: $method eq 'zip'
|
1507
|
|
|
|
|
|
|
? &repeat($x)
|
1508
|
|
|
|
|
|
|
: &list($x)
|
1509
|
|
|
|
|
|
|
}
|
1510
|
8
|
|
|
|
|
31
|
$xs->$method($code, $ys)
|
1511
|
|
|
|
|
|
|
}
|
1512
|
10
|
|
|
10
|
|
15656
|
}}
|
|
20
|
|
|
|
|
185
|
|
1513
|
|
|
|
|
|
|
package
|
1514
|
|
|
|
|
|
|
List::Gen::xWith;
|
1515
|
|
|
|
|
|
|
my $end = qr/([^:]+)$/;
|
1516
|
|
|
|
|
|
|
sub AUTOLOAD {
|
1517
|
0
|
|
|
0
|
|
0
|
my ($self) = $_[0];
|
1518
|
0
|
|
|
|
|
0
|
my ($xWith) = map lc, ref($self) =~ $end;
|
1519
|
0
|
|
|
|
|
0
|
my ($method) = our $AUTOLOAD =~ $end;
|
1520
|
0
|
|
|
|
|
0
|
my ($xs, $ys) = @$self{qw(xs ys)};
|
1521
|
0
|
0
|
|
|
|
0
|
unless ($ys->$isagen) {
|
1522
|
0
|
|
|
|
|
0
|
my $y = $ys;
|
1523
|
0
|
0
|
|
|
|
0
|
$ys = $xWith eq 'zip' ? &List::Gen::repeat($y)
|
1524
|
|
|
|
|
|
|
: &List::Gen::list($y)
|
1525
|
|
|
|
|
|
|
}
|
1526
|
0
|
0
|
|
|
|
0
|
($xs, $ys) = ($ys, $xs) if $$self{flip};
|
1527
|
|
|
|
|
|
|
|
1528
|
0
|
|
|
|
|
0
|
$_[0] = $xs->$xWith($ys);
|
1529
|
|
|
|
|
|
|
|
1530
|
0
|
0
|
|
|
|
0
|
goto &{$_[0]->can($method)
|
|
0
|
|
|
|
|
0
|
|
1531
|
|
|
|
|
|
|
or Carp::croak "no method '$method' on $_[0]"}
|
1532
|
|
|
|
|
|
|
}
|
1533
|
0
|
|
|
0
|
|
0
|
sub DESTROY {}
|
1534
|
|
|
|
|
|
|
package
|
1535
|
|
|
|
|
|
|
List::Gen::xWith::Cross;
|
1536
|
|
|
|
|
|
|
our @ISA = 'List::Gen::xWith';
|
1537
|
10
|
|
|
10
|
|
69
|
use overload fallback => 1, 'x' => $build->('cross');
|
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
38
|
|
1538
|
|
|
|
|
|
|
package
|
1539
|
|
|
|
|
|
|
List::Gen::xWith::Zip;
|
1540
|
|
|
|
|
|
|
our @ISA = 'List::Gen::xWith';
|
1541
|
10
|
|
|
10
|
|
1194
|
use overload fallback => 1, '|' => $build->('zip');
|
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
38
|
|
1542
|
|
|
|
|
|
|
}
|
1543
|
|
|
|
|
|
|
{package
|
1544
|
|
|
|
|
|
|
List::Gen::erator;
|
1545
|
|
|
|
|
|
|
List::Gen::DEBUG or $Carp::Internal{ (__PACKAGE__) }++;
|
1546
|
2
|
|
|
2
|
|
18
|
use overload fallback => 1,
|
1547
|
|
|
|
|
|
|
'&{}' => sub {$_[0]->_overloader},
|
1548
|
0
|
|
|
0
|
|
0
|
'<>' => sub {$_[0]->_overloader; $_[0]->next},
|
|
0
|
|
|
|
|
0
|
|
1549
|
20
|
|
|
|
|
185
|
'cross: zip:<|>'->${\sub {map {
|
1550
|
10
|
|
|
|
|
47
|
my ($method, $op) = /(.+):<(.)>/;
|
1551
|
20
|
|
|
|
|
68
|
my $package = 'List::Gen::xWith::'.ucfirst $method;
|
1552
|
20
|
|
|
|
|
41
|
my $method_with = $method.'with';
|
1553
|
|
|
|
|
|
|
$op => sub {
|
1554
|
11
|
|
|
11
|
|
28
|
my ($xs, $ys, $flip) = @_;
|
1555
|
11
|
|
|
|
|
16
|
my $ys_save = $ys;
|
1556
|
11
|
50
|
|
|
|
34
|
if (ref \$ys eq 'GLOB') {
|
1557
|
0
|
|
|
|
|
0
|
$ys = B::svref_2object(\$ys)->NAME
|
1558
|
|
|
|
|
|
|
}
|
1559
|
11
|
100
|
|
|
|
38
|
$ys = $ops{$ys} if $ops{$ys};
|
1560
|
11
|
100
|
100
|
|
|
54
|
if (not ref $ys or ref $ys eq 'CODE') {
|
1561
|
8
|
|
|
|
|
75
|
return bless {
|
1562
|
|
|
|
|
|
|
flip => $flip,
|
1563
|
|
|
|
|
|
|
code => $ys,
|
1564
|
|
|
|
|
|
|
ys => $ys_save,
|
1565
|
|
|
|
|
|
|
xs => $xs,
|
1566
|
|
|
|
|
|
|
} => $package
|
1567
|
|
|
|
|
|
|
}
|
1568
|
3
|
50
|
|
|
|
11
|
if (ref $ys eq $package) {
|
1569
|
0
|
|
|
|
|
0
|
(my $code, $ys) = @$ys{qw(code xs)};
|
1570
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
1571
|
0
|
0
|
|
|
|
0
|
($xs, $ys) = ($ys, $xs) if $flip;
|
1572
|
0
|
0
|
|
|
|
0
|
return $code == $comma
|
1573
|
|
|
|
|
|
|
? $xs->$method($ys)
|
1574
|
|
|
|
|
|
|
: $xs->$method_with($code, $ys)
|
1575
|
|
|
|
|
|
|
}
|
1576
|
|
|
|
|
|
|
|
1577
|
3
|
100
|
|
|
|
11
|
if (ref $ys eq 'ARRAY') {
|
1578
|
1
|
|
|
|
|
4
|
$ys = &List::Gen::makegen($ys)
|
1579
|
|
|
|
|
|
|
}
|
1580
|
|
|
|
|
|
|
|
1581
|
3
|
|
|
|
|
13
|
for ([xs => $xs], [ys => $ys]) {
|
1582
|
6
|
|
|
|
|
10
|
my ($n, $s) = @$_;
|
1583
|
6
|
50
|
|
|
|
22
|
if ($s->type =~ /List::Gen::(Zip)/) {
|
1584
|
0
|
|
|
|
|
0
|
my $type = lc $1;
|
1585
|
0
|
0
|
|
|
|
0
|
if ($type eq $method) {
|
1586
|
0
|
|
|
|
|
0
|
my $src = tied(@$s)->source;
|
1587
|
0
|
0
|
|
|
|
0
|
my $other = $n eq 'xs' ? $ys : $xs;
|
1588
|
0
|
|
|
|
|
0
|
my @other = $other->type =~ /List::Gen::$type/i
|
1589
|
0
|
0
|
|
|
|
0
|
? @{tied(@$other)->source}
|
1590
|
|
|
|
|
|
|
: tied @$other;
|
1591
|
0
|
0
|
|
|
|
0
|
return List::Gen::tiegen(
|
1592
|
|
|
|
|
|
|
ucfirst $type =>
|
1593
|
|
|
|
|
|
|
$n eq 'ys' ? (@other, @$src)
|
1594
|
|
|
|
|
|
|
: (@$src, @other)
|
1595
|
|
|
|
|
|
|
)
|
1596
|
|
|
|
|
|
|
}
|
1597
|
|
|
|
|
|
|
}
|
1598
|
|
|
|
|
|
|
}
|
1599
|
3
|
50
|
|
|
|
14
|
($xs, $ys) = ($ys, $xs) if $flip;
|
1600
|
3
|
|
|
|
|
19
|
$xs->$method($ys)
|
1601
|
|
|
|
|
|
|
}
|
1602
|
10
|
|
|
|
|
130
|
} split /\s+/, shift}},
|
|
20
|
|
|
|
|
213
|
|
1603
|
|
|
|
|
|
|
'+' => sub {
|
1604
|
0
|
|
|
0
|
|
0
|
my ($x, $y, $flip) = @_;
|
1605
|
0
|
0
|
|
|
|
0
|
($x, $y) = ($y, $x) if $flip;
|
1606
|
0
|
|
|
|
|
0
|
List::Gen::sequence($x, $y);
|
1607
|
|
|
|
|
|
|
},
|
1608
|
30
|
|
|
|
|
88
|
(map {
|
1609
|
|
|
|
|
|
|
(my $op = $_) =~ s/neg/-/;
|
1610
|
0
|
|
|
0
|
|
0
|
$_ => sub {$_[0]->hyper($op)}
|
1611
|
30
|
|
|
|
|
183
|
} qw (neg ! ~)),
|
1612
|
10
|
|
|
|
|
78
|
do {
|
1613
|
120
|
|
|
|
|
315
|
my %unary = map {
|
1614
|
10
|
|
|
|
|
1070
|
(my $op = $_) =~ s/^u//i;
|
1615
|
120
|
|
50
|
|
|
12550
|
$_ => (eval (m/(..)(.)/?"sub {$1\$_[0]$2}":"sub {$op \$_[0]}") or die $@)
|
1616
|
|
|
|
|
|
|
} qw (! ~ \ @{} ${} %{} &{} *{} U- U+ u- u+);
|
1617
|
20
|
|
|
|
|
30
|
map {
|
1618
|
10
|
|
|
|
|
46
|
my $op = $_;
|
1619
|
|
|
|
|
|
|
$op => sub {
|
1620
|
5
|
|
|
5
|
|
14
|
my ($x, $y, $flip) = @_;
|
1621
|
5
|
50
|
|
|
|
15
|
if (my $code = $unary{$y}) {
|
1622
|
0
|
|
|
|
|
0
|
return $x->hyper($code);
|
1623
|
|
|
|
|
|
|
}
|
1624
|
5
|
50
|
|
|
|
14
|
($x, $y) = ($y, $x) if $flip;
|
1625
|
5
|
|
|
|
|
66
|
bless [$x, $op, $y] => 'List::Gen::Hyper';
|
1626
|
|
|
|
|
|
|
}
|
1627
|
20
|
|
|
|
|
140
|
} qw (<< >>)
|
1628
|
10
|
|
|
10
|
|
11806
|
};
|
|
10
|
|
|
|
|
22
|
|
1629
|
|
|
|
|
|
|
|
1630
|
|
|
|
|
|
|
#END {defined &$_ and print "$_\n"
|
1631
|
|
|
|
|
|
|
# for sort {lc $a cmp lc $b} keys %List::Gen::erator::}
|
1632
|
|
|
|
|
|
|
my $l2g = \&List::Gen::list;
|
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
sub new {
|
1635
|
129
|
50
|
|
129
|
|
248
|
goto &_new if $STRICT;
|
1636
|
129
|
|
|
|
|
855
|
bless $_[1] => 'List::Gen::era::tor'}
|
1637
|
|
|
|
|
|
|
{package
|
1638
|
|
|
|
|
|
|
List::Gen::era::tor;
|
1639
|
|
|
|
|
|
|
our @ISA = 'List::Gen::erator';
|
1640
|
|
|
|
|
|
|
my $force = sub {List::Gen::erator->_new($_[0])};
|
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
tie my @by, 'List::Gen::By', 2, [1..10];
|
1643
|
|
|
|
|
|
|
my $by = List::Gen::erator->_new(\@by);
|
1644
|
10
|
|
|
10
|
|
3826
|
no strict 'refs';
|
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
19495
|
|
1645
|
|
|
|
|
|
|
for my $proxy (grep /[a-z]/, keys %{ref($by).'::'}) {
|
1646
|
0
|
|
|
0
|
|
0
|
*$proxy = $proxy eq 'index'
|
1647
|
|
|
|
|
|
|
? sub :lvalue {&$force->index}
|
1648
|
42
|
|
|
42
|
|
50
|
: sub {goto & {&$force->can($proxy)}}
|
|
42
|
|
|
|
|
73
|
|
1649
|
|
|
|
|
|
|
}
|
1650
|
0
|
|
|
0
|
|
0
|
sub DESTROY {}
|
1651
|
|
|
|
|
|
|
}
|
1652
|
|
|
|
|
|
|
{
|
1653
|
|
|
|
|
|
|
my %code_ok = map {ref, 1} sub {}, qr {};
|
1654
|
|
|
|
|
|
|
my $croak_msg = 'not supported in dwim generator code dereference';
|
1655
|
|
|
|
|
|
|
sub _new {
|
1656
|
|
|
|
|
|
|
package List::Gen;
|
1657
|
52
|
|
|
52
|
|
100
|
my ($class, $gen) = @_;
|
1658
|
52
|
|
|
|
|
80
|
my $src = tied @$gen;
|
1659
|
52
|
|
|
|
|
188
|
weaken $gen;
|
1660
|
52
|
|
|
|
|
412
|
my ($fetch, $fsize) = $src->closures;
|
1661
|
52
|
|
50
|
52
|
|
733
|
my $index = ($src->can('index') or sub {0})->();
|
|
52
|
|
|
|
|
106
|
|
1662
|
52
|
|
|
|
|
174
|
my $size = $fsize->();
|
1663
|
52
|
|
|
|
|
231
|
my $mutable = $src->mutable;
|
1664
|
52
|
100
|
|
|
|
133
|
if($mutable) {
|
1665
|
2
|
|
|
|
|
6
|
$src->tail_size($size)
|
1666
|
|
|
|
|
|
|
}
|
1667
|
52
|
|
|
|
|
84
|
my $dwim_code_strings = $DWIM_CODE_STRINGS;
|
1668
|
|
|
|
|
|
|
my $overload = sub {
|
1669
|
36
|
50
|
|
36
|
|
96
|
if (@_ == 0) {
|
|
|
50
|
|
|
|
|
|
1670
|
0
|
0
|
|
|
|
0
|
ref $index
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
? $$index < $size ? $fetch->(undef, $$index ) : ()
|
1672
|
|
|
|
|
|
|
: $index < $size ? $fetch->(undef, $index++) : ()
|
1673
|
|
|
|
|
|
|
}
|
1674
|
0
|
|
|
|
|
0
|
elsif (@_ == 1) {
|
1675
|
36
|
50
|
|
|
|
63
|
if (looks_like_number($_[0])) {$fetch->(undef, $_[0])}
|
|
36
|
0
|
|
|
|
79
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1676
|
0
|
|
|
|
|
0
|
elsif (ref $_[0]) {
|
1677
|
0
|
0
|
0
|
|
|
0
|
if (isagen($_[0])) {slice($gen, $_[0])}
|
|
0
|
0
|
0
|
|
|
0
|
|
|
|
0
|
0
|
|
|
|
|
1678
|
0
|
|
|
|
|
0
|
elsif ($code_ok{ref $_[0]}) {
|
1679
|
0
|
|
|
|
|
0
|
$gen->map($_[0])
|
1680
|
|
|
|
|
|
|
}
|
1681
|
|
|
|
|
|
|
elsif (ref $_[0] eq 'REF' && $code_ok{ref ${$_[0]}}
|
1682
|
|
|
|
|
|
|
or $dwim_code_strings && ref $_[0] eq 'SCALAR'
|
1683
|
0
|
|
|
|
|
0
|
) {
|
1684
|
0
|
|
|
|
|
0
|
$gen->grep(${$_[0]})
|
|
0
|
|
|
|
|
0
|
|
1685
|
|
|
|
|
|
|
}
|
1686
|
|
|
|
|
|
|
else {croak "reference '$_[0]' $croak_msg"}
|
1687
|
|
|
|
|
|
|
}
|
1688
|
|
|
|
|
|
|
elsif (canglob($_[0])) {slice($gen, $_[0])}
|
1689
|
0
|
|
|
|
|
0
|
elsif ($dwim_code_strings) { $gen->map ($_[0])}
|
|
0
|
|
|
|
|
0
|
|
1690
|
|
|
|
|
|
|
else {croak "value '$_[0]' $croak_msg"}
|
1691
|
|
|
|
|
|
|
}
|
1692
|
0
|
|
|
|
|
0
|
else {unshift @_, $gen; goto &{$gen->can('slice')}}
|
|
0
|
|
|
|
|
0
|
|
1693
|
52
|
|
|
|
|
285
|
};
|
1694
|
|
|
|
|
|
|
curse {
|
1695
|
|
|
|
|
|
|
-bless => $gen,
|
1696
|
|
|
|
|
|
|
_overloader => sub {
|
1697
|
2
|
50
|
|
2
|
|
4
|
eval qq {
|
|
1
|
|
|
1
|
|
11
|
|
|
1
|
|
|
1
|
|
3
|
|
|
1
|
|
|
|
|
12
|
|
|
17
|
|
|
|
|
142
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
8
|
|
|
17
|
|
|
|
|
171
|
|
1698
|
2
|
|
|
|
|
325
|
package @{[ref $_[0]]};
|
1699
|
|
|
|
|
|
|
use overload fallback => 1, '&{}' => sub {\$overload},
|
1700
|
|
|
|
|
|
|
'<>' => \\&next;
|
1701
|
|
|
|
|
|
|
local *DESTROY;
|
1702
|
|
|
|
|
|
|
bless []; 1
|
1703
|
|
|
|
|
|
|
} or croak "overloading failed: $@";
|
1704
|
2
|
|
|
|
|
6
|
$overload
|
1705
|
|
|
|
|
|
|
},
|
1706
|
3
|
|
|
3
|
|
4
|
size => $fsize,
|
1707
|
|
|
|
|
|
|
get => $fetch,
|
1708
|
|
|
|
|
|
|
slice => sub {shift;
|
1709
|
3
|
0
|
0
|
|
|
10
|
@_ == 1 and (isagen($_[0]) or canglob($_[0]))
|
|
|
|
33
|
|
|
|
|
1710
|
|
|
|
|
|
|
and return slice($gen, $_[0]);
|
1711
|
3
|
50
|
|
|
|
5
|
if ($mutable) {
|
1712
|
0
|
|
|
|
|
0
|
my @ret;
|
1713
|
0
|
|
|
|
|
0
|
for my $i (@_) {
|
1714
|
0
|
0
|
|
|
|
0
|
$i < $size or next;
|
1715
|
0
|
|
|
|
|
0
|
my @x = \($fetch->(undef, $i));
|
1716
|
0
|
0
|
|
|
|
0
|
$i < $size or next;
|
1717
|
0
|
|
|
|
|
0
|
push @ret, @x;
|
1718
|
|
|
|
|
|
|
}
|
1719
|
0
|
0
|
|
|
|
0
|
wantarray ? map $$_ => @ret
|
1720
|
|
|
|
|
|
|
: $l2g->(map $$_ => @ret)
|
1721
|
|
|
|
|
|
|
}
|
1722
|
|
|
|
|
|
|
else {
|
1723
|
3
|
50
|
|
|
|
10
|
wantarray ? map $fetch->(undef, $_) => @_
|
1724
|
|
|
|
|
|
|
: $l2g->(map $fetch->(undef, $_) => @_)
|
1725
|
|
|
|
|
|
|
}
|
1726
|
|
|
|
|
|
|
},
|
1727
|
0
|
|
|
0
|
|
0
|
index => ref $index ? sub {$$index} : sub :lvalue {$index},
|
|
0
|
|
|
|
|
0
|
|
1728
|
0
|
|
|
0
|
|
0
|
more => ref $index ? sub {$$index < $size} : sub {$index < $size},
|
|
0
|
|
|
|
|
0
|
|
1729
|
0
|
0
|
|
0
|
|
0
|
next => ref $index
|
1730
|
|
|
|
|
|
|
? sub {$$index < $size ? $fetch->(undef, $$index ) : ()}
|
1731
|
0
|
0
|
|
0
|
|
0
|
: sub { $index < $size ? $fetch->(undef, $index++) : ()},
|
1732
|
52
|
50
|
|
|
|
1106
|
} => $class
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1733
|
|
|
|
|
|
|
}
|
1734
|
|
|
|
|
|
|
}
|
1735
|
|
|
|
|
|
|
sub reset {
|
1736
|
0
|
0
|
|
0
|
|
0
|
tied(@{$_[0]})->can('index')
|
|
0
|
|
|
|
|
0
|
|
1737
|
|
|
|
|
|
|
and Carp::croak "can not call ->reset on stream generator";
|
1738
|
|
|
|
|
|
|
|
1739
|
0
|
|
0
|
|
|
0
|
$_[0]->index = $_[1] || 0; $_[0]
|
|
0
|
|
|
|
|
0
|
|
1740
|
|
|
|
|
|
|
}
|
1741
|
|
|
|
|
|
|
|
1742
|
|
|
|
|
|
|
sub all {
|
1743
|
20
|
|
|
20
|
|
25
|
my $gen = shift;
|
1744
|
20
|
|
|
|
|
34
|
my $src = tied @$gen;
|
1745
|
20
|
|
|
|
|
47
|
my $size = $src->fsize;
|
1746
|
20
|
|
|
|
|
117
|
my $mutable = $src->mutable;
|
1747
|
|
|
|
|
|
|
|
1748
|
20
|
0
|
33
|
|
|
93
|
$mutable or $size < 2**31
|
|
|
50
|
|
|
|
|
|
1749
|
|
|
|
|
|
|
or Carp::confess "can't call ->all on ",
|
1750
|
|
|
|
|
|
|
$size < 9**9**9
|
1751
|
|
|
|
|
|
|
? 'generator larger than 2**31, use iteration instead'
|
1752
|
|
|
|
|
|
|
: 'infinite generator';
|
1753
|
|
|
|
|
|
|
|
1754
|
20
|
50
|
|
|
|
353
|
if (my $cap = $src->can('capture')) {
|
|
|
50
|
|
|
|
|
|
1755
|
0
|
|
|
|
|
0
|
@{ $cap->() }
|
|
0
|
|
|
|
|
0
|
|
1756
|
|
|
|
|
|
|
}
|
1757
|
|
|
|
|
|
|
elsif (my $range = $src->can('range')) {
|
1758
|
0
|
|
|
|
|
0
|
my ($low, $step, $size) = $range->();
|
1759
|
0
|
|
|
|
|
0
|
map $low + $step * $_ => 0 .. $size - 1
|
1760
|
|
|
|
|
|
|
}
|
1761
|
|
|
|
|
|
|
else {
|
1762
|
20
|
|
|
|
|
48
|
my $fetch = $src->can('FETCH');
|
1763
|
20
|
50
|
|
|
|
40
|
if ($mutable) {
|
1764
|
0
|
|
|
|
|
0
|
my ($i, @ret) = 0;
|
1765
|
0
|
|
|
|
|
0
|
$src->tail_size($size);
|
1766
|
0
|
|
|
|
|
0
|
while ($i < $size) {
|
1767
|
0
|
|
|
|
|
0
|
my @got = \($fetch->(undef, $i));
|
1768
|
0
|
0
|
|
|
|
0
|
last unless $i++ < $size;
|
1769
|
0
|
|
|
|
|
0
|
push @ret, @got
|
1770
|
|
|
|
|
|
|
}
|
1771
|
0
|
|
|
|
|
0
|
map $$_ => @ret
|
1772
|
|
|
|
|
|
|
}
|
1773
|
|
|
|
|
|
|
else {
|
1774
|
20
|
|
|
|
|
73
|
map $fetch->(undef, $_) => 0 .. $size - 1
|
1775
|
|
|
|
|
|
|
}
|
1776
|
|
|
|
|
|
|
}
|
1777
|
|
|
|
|
|
|
}
|
1778
|
10
|
|
|
10
|
|
6582
|
BEGIN {*list = *all}
|
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
{my $inf;
|
1781
|
|
|
|
|
|
|
sub hyper {
|
1782
|
0
|
0
|
|
0
|
|
0
|
if (@_ == 2) {
|
1783
|
0
|
|
0
|
|
|
0
|
$inf ||= &List::Gen::range(0, 9**9**9);
|
1784
|
0
|
|
|
|
|
0
|
my $code = $_[1];
|
1785
|
0
|
0
|
0
|
|
|
0
|
unless ((ref($code)||'') eq 'CODE') {
|
1786
|
0
|
0
|
|
|
|
0
|
if (ref \$code eq 'GLOB') {
|
1787
|
0
|
|
|
|
|
0
|
($code) = $code =~ /([^:]+)$/
|
1788
|
|
|
|
|
|
|
} else {
|
1789
|
0
|
|
|
|
|
0
|
$code =~ s/^\s*(?:<<|>>)\s*(.+?)\s*$/$1/
|
1790
|
|
|
|
|
|
|
}
|
1791
|
0
|
0
|
|
|
|
0
|
$code =~ /[~!-\\]/ or Carp::croak 'arg 1 to ->hyper(str) must match /(<<|>>)?[~!-\]/';
|
1792
|
0
|
|
|
|
|
0
|
$code = 'hyper'->$eval("sub {$code \$_[0]}")
|
1793
|
|
|
|
|
|
|
}
|
1794
|
0
|
|
|
|
|
0
|
return $_[0]->hyper('>>', $code, '>>', $inf)
|
1795
|
|
|
|
|
|
|
}
|
1796
|
0
|
0
|
|
|
|
0
|
if (@_ == 3) {
|
1797
|
0
|
0
|
0
|
|
|
0
|
if (ref \$_[1] eq 'GLOB' or $_[1] =~ /^(?:<|>>?|>=|<=|[^<>]+)$/) {
|
1798
|
0
|
|
|
|
|
0
|
return List::Gen::Hyper::hyper (
|
1799
|
|
|
|
|
|
|
$_[0], '<<', $_[1], '>>', $_[2]
|
1800
|
|
|
|
|
|
|
)
|
1801
|
|
|
|
|
|
|
}
|
1802
|
0
|
0
|
|
|
|
0
|
if ($_[1] =~ /^\s*(<|>>?)?\s*(\S+?)\s*(<|>>?)?\s*$/) {
|
1803
|
|
|
|
|
|
|
|
1804
|
0
|
0
|
|
|
|
0
|
return List::Gen::Hyper::hyper (
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1805
|
|
|
|
|
|
|
$_[0],
|
1806
|
|
|
|
|
|
|
$1 ? (length $1 == 1 ? $1.$1 : $1) : '<<',
|
1807
|
|
|
|
|
|
|
$2,
|
1808
|
|
|
|
|
|
|
$3 ? (length $3 == 1 ? $3.$3 : $3) : '>>',
|
1809
|
|
|
|
|
|
|
$_[2]
|
1810
|
|
|
|
|
|
|
)
|
1811
|
|
|
|
|
|
|
}
|
1812
|
0
|
|
|
|
|
0
|
Carp::croak "arg 1 to ->hyper(str, val) must match (<<|>>)op(<<|>>)";
|
1813
|
|
|
|
|
|
|
}
|
1814
|
0
|
0
|
|
|
|
0
|
goto &List::Gen::Hyper::hyper if @_ == 5;
|
1815
|
0
|
|
|
|
|
0
|
Carp::croak q{takes 1 `->hyper('-')` or 2 `->hyper('<<+>>', 1)` }.
|
1816
|
|
|
|
|
|
|
q{or 4 `->hyper(qw(<< + >>), 1)` args, not }.$#_
|
1817
|
|
|
|
|
|
|
}}
|
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
for my $proxy (qw(apply purge rewind)) {
|
1820
|
10
|
|
|
10
|
|
250
|
no strict 'refs';
|
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
5166
|
|
1821
|
|
|
|
|
|
|
*$proxy = sub {
|
1822
|
0
|
|
|
0
|
|
0
|
my @src;
|
1823
|
0
|
|
|
|
|
0
|
my @todo = tied @{$_[0]};
|
|
0
|
|
|
|
|
0
|
|
1824
|
0
|
|
|
|
|
0
|
while (my $next = shift @todo) {
|
1825
|
0
|
|
|
|
|
0
|
unshift @src, $next;
|
1826
|
0
|
0
|
|
|
|
0
|
next if ref($next) =~ /^List::Gen::While/;
|
1827
|
0
|
0
|
|
|
|
0
|
if (my $source = $next->source) {
|
1828
|
0
|
0
|
|
|
|
0
|
unshift @todo, ref $source eq 'ARRAY'
|
1829
|
|
|
|
|
|
|
? @$source
|
1830
|
|
|
|
|
|
|
: $source
|
1831
|
|
|
|
|
|
|
}
|
1832
|
|
|
|
|
|
|
}
|
1833
|
0
|
|
0
|
|
|
0
|
($_->can($proxy) or next)->($_) for @src;
|
1834
|
0
|
|
|
|
|
0
|
$_[0]
|
1835
|
|
|
|
|
|
|
}
|
1836
|
|
|
|
|
|
|
}
|
1837
|
|
|
|
|
|
|
|
1838
|
0
|
|
|
0
|
|
0
|
sub is_inf {$_[0]->size >= 9**9**9}
|
1839
|
0
|
|
|
0
|
|
0
|
sub x_xs {$_[0]->head, $_[0]->tail}
|
1840
|
0
|
|
|
0
|
|
0
|
sub idx {$_[0]->drop( $_[0]->index + 0 )}
|
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
sub tee {
|
1843
|
0
|
|
|
0
|
|
0
|
my @ret;
|
1844
|
0
|
|
|
|
|
0
|
for (shift) {
|
1845
|
0
|
|
|
|
|
0
|
for my $code (@_)
|
|
0
|
|
|
|
|
0
|
|
1846
|
|
|
|
|
|
|
{push @ret, $code->()}}
|
1847
|
|
|
|
|
|
|
wantarray
|
1848
|
|
|
|
|
|
|
? @ret
|
1849
|
0
|
0
|
|
|
|
0
|
: @ret > 1
|
|
|
0
|
|
|
|
|
|
1850
|
|
|
|
|
|
|
? &List::Gen::makegen(\@ret)
|
1851
|
|
|
|
|
|
|
: pop @ret
|
1852
|
|
|
|
|
|
|
}
|
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
BEGIN {
|
1855
|
10
|
|
|
10
|
|
35
|
*from_index = *idx;
|
1856
|
0
|
|
|
0
|
|
0
|
*s = *self = *scalar = sub {$_[0]}
|
1857
|
10
|
|
|
|
|
5773
|
}
|
1858
|
|
|
|
|
|
|
|
1859
|
6
|
|
|
6
|
|
8
|
sub type {(my $t = ref tied @{$_[0]}) =~ s/::_\d+$//; $t}
|
|
6
|
|
|
|
|
37
|
|
|
6
|
|
|
|
|
26
|
|
1860
|
|
|
|
|
|
|
|
1861
|
0
|
|
|
0
|
|
0
|
sub elems {$_[0]->size}
|
1862
|
0
|
|
|
0
|
|
0
|
sub end {$_[0]->apply->size - 1}
|
1863
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
{package
|
1865
|
|
|
|
|
|
|
List::Gen::DwimCode;
|
1866
|
|
|
|
|
|
|
my %save;
|
1867
|
|
|
|
|
|
|
sub new {
|
1868
|
0
|
|
|
0
|
|
0
|
my ($class, $gen) = @_;
|
1869
|
0
|
|
|
|
|
0
|
my $code = \&$gen;
|
1870
|
0
|
|
|
|
|
0
|
bless $code => $class;
|
1871
|
0
|
|
|
|
|
0
|
$save{$code} = $gen;
|
1872
|
0
|
|
|
|
|
0
|
$code
|
1873
|
|
|
|
|
|
|
}
|
1874
|
|
|
|
|
|
|
sub DESTROY {
|
1875
|
0
|
|
|
0
|
|
0
|
delete $save{$_[0]}
|
1876
|
|
|
|
|
|
|
}
|
1877
|
|
|
|
|
|
|
}
|
1878
|
0
|
|
|
0
|
|
0
|
sub code {List::Gen::DwimCode->new($_[0])}
|
1879
|
|
|
|
|
|
|
|
1880
|
|
|
|
|
|
|
sub size_from {
|
1881
|
0
|
|
|
0
|
|
0
|
List::Gen::tiegen(Size_From => map tied @$_ => @_)
|
1882
|
|
|
|
|
|
|
}
|
1883
|
|
|
|
|
|
|
List::Gen::generator Size_From => sub {
|
1884
|
0
|
|
|
0
|
|
0
|
my ($class, $self, $from) = @_;
|
1885
|
0
|
|
|
0
|
|
0
|
List::Gen::curse {
|
1886
|
|
|
|
|
|
|
fsize => $from->can('fsize'),
|
1887
|
|
|
|
|
|
|
FETCH => $self->can('FETCH'),
|
1888
|
|
|
|
|
|
|
source => sub {[$self, $from]},
|
1889
|
0
|
0
|
|
0
|
|
0
|
$from->mutable ? (mutable => sub {1}) : ()
|
|
0
|
|
|
|
|
0
|
|
1890
|
|
|
|
|
|
|
} => $class
|
1891
|
|
|
|
|
|
|
};
|
1892
|
|
|
|
|
|
|
|
1893
|
0
|
|
|
0
|
|
0
|
sub defined {$_[0]->grep('defined')}
|
1894
|
|
|
|
|
|
|
|
1895
|
0
|
|
|
0
|
|
0
|
sub iterator {$_[0]->index; $_[0]->can('next')}
|
|
0
|
|
|
|
|
0
|
|
1896
|
10
|
|
|
10
|
|
622
|
BEGIN {*iter = *iterator}
|
1897
|
|
|
|
|
|
|
|
1898
|
0
|
|
|
0
|
|
0
|
sub range {&List::Gen::range(0, $_[0]->size - 1)}
|
1899
|
10
|
|
|
10
|
|
100
|
{no warnings 'once';
|
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
4509
|
|
1900
|
0
|
0
|
|
0
|
|
0
|
*keys = sub {wantarray ? $_[0]->range->all : $_[0]->range};
|
1901
|
0
|
0
|
|
0
|
|
0
|
*values = sub {wantarray ? $_[0]->all : $_[0]};
|
1902
|
|
|
|
|
|
|
}
|
1903
|
0
|
|
|
0
|
|
0
|
sub kv {&List::Gen::zip($_[0]->range, $_[0])}
|
1904
|
0
|
|
|
0
|
|
0
|
sub tuples {&List::Gen::tuples}
|
1905
|
0
|
|
|
0
|
|
0
|
sub pairs {$_[0]->range->tuples($_[0])}
|
1906
|
|
|
|
|
|
|
|
1907
|
|
|
|
|
|
|
sub sort {
|
1908
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
1909
|
0
|
0
|
|
|
|
0
|
@_ == 2 and return $self->wrapsort(@_);
|
1910
|
|
|
|
|
|
|
@_ == 0
|
1911
|
|
|
|
|
|
|
? wantarray ? sort $self->all
|
1912
|
|
|
|
|
|
|
: $l2g->(sort $self->all)
|
1913
|
0
|
0
|
|
|
|
0
|
: do {
|
|
|
0
|
|
|
|
|
|
1914
|
0
|
|
|
|
|
0
|
my $code = pop;
|
1915
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
1916
|
0
|
|
|
|
|
0
|
my ($ca, $cb) = $code->$cv_ab_ref;
|
1917
|
0
|
|
|
|
|
0
|
local (*$ca, *$cb) = (*a, *b);
|
1918
|
0
|
0
|
|
|
|
0
|
wantarray ? sort $code $self->all
|
1919
|
|
|
|
|
|
|
: $l2g->(sort $code $self->all)
|
1920
|
|
|
|
|
|
|
}
|
1921
|
|
|
|
|
|
|
}
|
1922
|
|
|
|
|
|
|
{package
|
1923
|
|
|
|
|
|
|
List::Gen::Wrap;
|
1924
|
10
|
|
|
10
|
|
60
|
use overload fallback => 1, '""' => sub {$_[0][1]};
|
|
10
|
|
|
0
|
|
16
|
|
|
10
|
|
|
|
|
137
|
|
|
0
|
|
|
|
|
0
|
|
1925
|
|
|
|
|
|
|
}
|
1926
|
|
|
|
|
|
|
sub wrap {
|
1927
|
0
|
|
|
0
|
|
0
|
my ($gen, $code) = splice @_;
|
1928
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
1929
|
0
|
|
|
|
|
0
|
$l2g->(map {bless [$_ => &$code] => 'List::Gen::Wrap'} $gen->all)
|
|
0
|
|
|
|
|
0
|
|
1930
|
|
|
|
|
|
|
}
|
1931
|
|
|
|
|
|
|
sub unwrap {
|
1932
|
0
|
0
|
|
0
|
|
0
|
wantarray ? map $$_[0], $_[0]->all
|
1933
|
|
|
|
|
|
|
: $l2g->(map $$_[0], $_[0]->all)
|
1934
|
|
|
|
|
|
|
}
|
1935
|
|
|
|
|
|
|
sub wrapsort {
|
1936
|
0
|
|
|
0
|
|
0
|
my ($gen, $code, @by) = @_;
|
1937
|
0
|
|
|
|
|
0
|
$gen->wrap($code)->sort(@by)->unwrap
|
1938
|
|
|
|
|
|
|
}
|
1939
|
10
|
|
|
10
|
|
6352
|
BEGIN {*wsort = *wrapsort}
|
1940
|
|
|
|
|
|
|
|
1941
|
|
|
|
|
|
|
sub perl {
|
1942
|
0
|
|
|
0
|
|
0
|
my $src = shift;
|
1943
|
0
|
0
|
|
|
|
0
|
'[' .(join ', ' => map {
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1944
|
0
|
0
|
0
|
|
|
0
|
ref $_
|
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1945
|
|
|
|
|
|
|
? &List::Gen::isagen($_)
|
1946
|
|
|
|
|
|
|
? $_->perl(@_)
|
1947
|
|
|
|
|
|
|
: ref eq 'ARRAY'
|
1948
|
|
|
|
|
|
|
? &List::Gen::makegen($_)->perl(@_)
|
1949
|
|
|
|
|
|
|
: "'$_'"
|
1950
|
|
|
|
|
|
|
: /^-?\d+(?:\.\d+)?$/
|
1951
|
|
|
|
|
|
|
? $_
|
1952
|
|
|
|
|
|
|
: "'$_'"
|
1953
|
|
|
|
|
|
|
} (@_ and $_[0] < 9**9**9)
|
1954
|
|
|
|
|
|
|
? $src->size <= $_[0]
|
1955
|
|
|
|
|
|
|
? $src->all
|
1956
|
|
|
|
|
|
|
: $src->slice(0 .. $_[0] - 1)
|
1957
|
|
|
|
|
|
|
: $src->all
|
1958
|
|
|
|
|
|
|
).((@_ == 2 and $_[0] < $src->size) ? ", $_[1]" : ''). ']'
|
1959
|
|
|
|
|
|
|
}
|
1960
|
|
|
|
|
|
|
sub str {
|
1961
|
23
|
|
|
23
|
|
37
|
my $src = shift;
|
1962
|
23
|
50
|
|
|
|
99
|
join defined $" ? $" : '' => $src->flat(@_)
|
1963
|
|
|
|
|
|
|
}
|
1964
|
10
|
|
|
10
|
|
60
|
{no warnings 'once';
|
|
10
|
|
|
|
|
16
|
|
|
10
|
|
|
|
|
28556
|
|
1965
|
|
|
|
|
|
|
*join = sub {
|
1966
|
0
|
0
|
|
0
|
|
0
|
join @_ > 1 ? $_[1] : '',
|
|
|
0
|
|
|
|
|
|
1967
|
|
|
|
|
|
|
@_ > 2 ? $_[0]->take($_[2])->all : $_[0]->all,
|
1968
|
|
|
|
|
|
|
@_[3 .. $#_]
|
1969
|
|
|
|
|
|
|
}}
|
1970
|
|
|
|
|
|
|
sub flat {
|
1971
|
23
|
|
|
23
|
|
33
|
my $src = shift;
|
1972
|
204
|
0
|
|
|
|
521
|
map {
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1973
|
23
|
50
|
66
|
|
|
123
|
ref $_
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1974
|
|
|
|
|
|
|
? &List::Gen::isagen($_)
|
1975
|
|
|
|
|
|
|
? $_->flat(@_)
|
1976
|
|
|
|
|
|
|
: ref eq 'ARRAY'
|
1977
|
|
|
|
|
|
|
? &List::Gen::makegen($_)->flat(@_)
|
1978
|
|
|
|
|
|
|
: $_
|
1979
|
|
|
|
|
|
|
: $_
|
1980
|
|
|
|
|
|
|
} (@_ and $_[0] < 9**9**9)
|
1981
|
|
|
|
|
|
|
? $src->size <= $_[0]
|
1982
|
|
|
|
|
|
|
? $src->all
|
1983
|
|
|
|
|
|
|
: ($src->slice(0 .. $_[0] - 1), @_ == 2 ? $_[1] : ())
|
1984
|
|
|
|
|
|
|
: $src->all
|
1985
|
|
|
|
|
|
|
}
|
1986
|
|
|
|
|
|
|
sub say {
|
1987
|
0
|
|
|
0
|
|
0
|
local $\ = "\n";
|
1988
|
0
|
|
|
|
|
0
|
&print
|
1989
|
|
|
|
|
|
|
}
|
1990
|
|
|
|
|
|
|
|
1991
|
|
|
|
|
|
|
sub print {
|
1992
|
0
|
|
|
0
|
|
0
|
my $src = shift;
|
1993
|
0
|
0
|
0
|
|
|
0
|
if (@_ and Scalar::Util::openhandle($_[0])) {
|
|
0
|
|
|
|
|
0
|
|
1994
|
0
|
|
|
|
|
0
|
my $fh = shift;
|
1995
|
0
|
|
|
|
|
0
|
print $fh $src->str(@_)
|
1996
|
|
|
|
|
|
|
}
|
1997
|
|
|
|
|
|
|
else {print $src->str(@_)}
|
1998
|
0
|
|
|
|
|
0
|
$src
|
1999
|
|
|
|
|
|
|
}
|
2000
|
|
|
|
|
|
|
sub dump {
|
2001
|
0
|
|
|
0
|
|
0
|
local *flat = *perl;
|
2002
|
0
|
|
|
|
|
0
|
&say
|
2003
|
|
|
|
|
|
|
}
|
2004
|
|
|
|
|
|
|
{my $bool = sub {$_[0] ? 'yes' : 'no'};
|
2005
|
|
|
|
|
|
|
sub debug {
|
2006
|
0
|
|
|
0
|
|
0
|
my ($gen, $num) = (@_, 10);
|
2007
|
0
|
0
|
|
|
|
0
|
my ($max) = map {$_ >= 9**9**9 ? 'inf' : $_} $gen->size - 1;
|
|
0
|
|
|
|
|
0
|
|
2008
|
0
|
|
|
|
|
0
|
my $stream = tied(@$gen)->can('index');
|
2009
|
0
|
0
|
|
|
|
0
|
my $perl = !$num ? ''
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2010
|
|
|
|
|
|
|
: ($stream ? 'from '.$gen->index.': ' : '')
|
2011
|
|
|
|
|
|
|
. ($stream ? $gen->idx : $gen)->perl($num, '...');
|
2012
|
|
|
|
|
|
|
|
2013
|
0
|
0
|
|
|
|
0
|
Carp::carp join '' => map {
|
2014
|
0
|
|
|
|
|
0
|
sprintf "%-8s %s\n", "$$_[0]:",
|
2015
|
|
|
|
|
|
|
$#$_ > 0 ? join ', ' => @$_[1 .. $#$_] : 'none'
|
2016
|
|
|
|
|
|
|
} [debug => $gen],
|
2017
|
|
|
|
|
|
|
[type => $gen->type],
|
2018
|
0
|
0
|
|
|
|
0
|
[source => map {ref =~ /(.+)::/} tied(@$gen)->sources],
|
2019
|
|
|
|
|
|
|
[mutable => $bool->($gen->is_mutable)],
|
2020
|
|
|
|
|
|
|
[stream => $bool->($stream)],
|
2021
|
|
|
|
|
|
|
[range => "[0 .. $max]"],
|
2022
|
|
|
|
|
|
|
[index => $gen->index],
|
2023
|
|
|
|
|
|
|
$perl ? [perl => $perl] :();
|
2024
|
0
|
|
|
|
|
0
|
$gen
|
2025
|
|
|
|
|
|
|
}}
|
2026
|
|
|
|
|
|
|
|
2027
|
|
|
|
|
|
|
sub watch {
|
2028
|
0
|
|
|
0
|
|
0
|
my ($gen, $fh) = shift;
|
2029
|
0
|
|
0
|
|
|
0
|
my $msg = join ' ', grep {
|
2030
|
0
|
|
|
|
|
0
|
not (Scalar::Util::openhandle $_ and $fh = $_)
|
2031
|
|
|
|
|
|
|
} @_;
|
2032
|
0
|
0
|
|
|
|
0
|
$msg .= ': ' if $msg =~ /^\w+$/;
|
2033
|
|
|
|
|
|
|
&List::Gen::gen(sub {
|
2034
|
0
|
0
|
|
0
|
|
0
|
defined $\ or local $\ = $/;
|
2035
|
0
|
0
|
|
|
|
0
|
$fh ? print $fh $msg, $_
|
2036
|
|
|
|
|
|
|
: print $msg, $_;
|
2037
|
0
|
|
|
|
|
0
|
$_
|
2038
|
0
|
|
|
|
|
0
|
}, $gen)
|
2039
|
|
|
|
|
|
|
}
|
2040
|
|
|
|
|
|
|
|
2041
|
|
|
|
|
|
|
sub pick {
|
2042
|
0
|
|
|
0
|
|
0
|
my ($self, $n) = (@_, 1);
|
2043
|
0
|
0
|
0
|
|
|
0
|
if ($n == 1 and not $self->is_mutable) {
|
2044
|
0
|
|
|
|
|
0
|
my $size = $self->size;
|
2045
|
0
|
0
|
|
|
|
0
|
$self->get(int rand ($size >= 9**9**9 ? $MAX_IDX : $size))
|
2046
|
|
|
|
|
|
|
} else {
|
2047
|
0
|
|
|
|
|
0
|
my $pick = $self->shuffle->take($n);
|
2048
|
0
|
0
|
|
|
|
0
|
wantarray ? $pick->all : $pick
|
2049
|
|
|
|
|
|
|
}
|
2050
|
|
|
|
|
|
|
}
|
2051
|
|
|
|
|
|
|
my $wantgen = sub {wantarray ? @_ : &List::Gen::makegen(\@_)};
|
2052
|
|
|
|
|
|
|
sub roll {
|
2053
|
0
|
|
|
0
|
|
0
|
my ($self, $n) = (@_, 1);
|
2054
|
0
|
0
|
|
|
|
0
|
$n > 1 ? $wantgen->(map $self->pick, 1 .. $n) : $self->pick
|
2055
|
|
|
|
|
|
|
}
|
2056
|
|
|
|
|
|
|
|
2057
|
|
|
|
|
|
|
sub random {
|
2058
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
2059
|
0
|
|
|
|
|
0
|
my $size = $self->size;
|
2060
|
0
|
|
|
|
|
0
|
my $fetch = tied(@$self)->can('FETCH');
|
2061
|
0
|
|
|
|
|
0
|
my %map;
|
2062
|
0
|
0
|
|
|
|
0
|
$self->tail_size($size) if $self->is_mutable;
|
2063
|
0
|
0
|
|
|
|
0
|
&List::Gen::gen(sub {{
|
2064
|
0
|
|
|
0
|
|
0
|
return $fetch->(undef, $map{$_}) if exists $map{$_};
|
2065
|
0
|
0
|
|
|
|
0
|
my $i = int rand ($size >= 9**9**9 ? $MAX_IDX : $size);
|
2066
|
0
|
|
|
|
|
0
|
my $x = $fetch->(undef, $i);
|
2067
|
0
|
0
|
|
|
|
0
|
redo unless $i < $size;
|
2068
|
0
|
|
|
|
|
0
|
$map{$_} = $i;
|
2069
|
0
|
|
|
|
|
0
|
$x
|
2070
|
|
|
|
|
|
|
}})
|
2071
|
0
|
|
|
|
|
0
|
}
|
2072
|
|
|
|
|
|
|
sub shuffle {
|
2073
|
0
|
|
|
0
|
|
0
|
my $src = shift;
|
2074
|
0
|
|
|
|
|
0
|
my $size = $src->size;
|
2075
|
0
|
|
|
|
|
0
|
my $fetch = tied(@$src)->can('FETCH');
|
2076
|
0
|
|
|
|
|
0
|
my (%seen, %map);
|
2077
|
0
|
0
|
|
|
|
0
|
$src->tail_size($size) if $src->is_mutable;
|
2078
|
|
|
|
|
|
|
&List::Gen::gen(sub {
|
2079
|
0
|
0
|
|
0
|
|
0
|
return $fetch->(undef, $map{$_}) if exists $map{$_};
|
2080
|
0
|
|
|
|
|
0
|
while (keys %seen < $size) {
|
2081
|
0
|
0
|
|
|
|
0
|
my $i = int rand ($size >= 9**9**9 ? $MAX_IDX : $size);
|
2082
|
0
|
|
|
|
|
0
|
my $start = $i;
|
2083
|
0
|
|
0
|
|
|
0
|
$i++ while $i < $size-1 and $seen{$i};
|
2084
|
0
|
0
|
|
|
|
0
|
$i = $start if $seen{$i};
|
2085
|
0
|
|
0
|
|
|
0
|
$i-- while $i > 0 and $seen{$i};
|
2086
|
0
|
0
|
|
|
|
0
|
$seen{$i}++ or return $fetch->(undef, $map{$_} = $i)
|
2087
|
|
|
|
|
|
|
}
|
2088
|
0
|
|
|
|
|
0
|
})->size_from($src)
|
2089
|
|
|
|
|
|
|
}
|
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
sub uniq {
|
2092
|
0
|
|
|
0
|
|
0
|
my %seen;
|
2093
|
0
|
|
|
0
|
|
0
|
&List::Gen::filter(sub {not $seen{$_}++}, $_[0])
|
|
0
|
|
|
|
|
0
|
|
2094
|
|
|
|
|
|
|
}
|
2095
|
|
|
|
|
|
|
|
2096
|
|
|
|
|
|
|
our $first_idx;
|
2097
|
|
|
|
|
|
|
sub first {
|
2098
|
0
|
0
|
|
0
|
|
0
|
return $_[0]->get(0) if @_ == 1;
|
2099
|
0
|
|
|
|
|
0
|
my ($self, $code) = @_;
|
2100
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2101
|
0
|
|
|
|
|
0
|
my $fetch = tied(@$self)->can('FETCH');
|
2102
|
0
|
|
|
|
|
0
|
my $i = 0;
|
2103
|
0
|
|
|
|
|
0
|
local @_;
|
2104
|
0
|
|
|
|
|
0
|
local *_ = \undef;
|
2105
|
0
|
|
|
|
|
0
|
my $size = $self->size;
|
2106
|
0
|
0
|
|
|
|
0
|
if ($self->is_mutable) {
|
2107
|
0
|
|
|
|
|
0
|
$self->tail_size($size);
|
2108
|
0
|
|
|
|
|
0
|
while ($i < $size) {
|
2109
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, $i);
|
2110
|
0
|
0
|
|
|
|
0
|
return if $i >= $size;
|
2111
|
0
|
0
|
|
|
|
0
|
return $first_idx ? $i : $_ if &$code;
|
|
|
0
|
|
|
|
|
|
2112
|
0
|
|
|
|
|
0
|
$i++;
|
2113
|
|
|
|
|
|
|
}
|
2114
|
|
|
|
|
|
|
} else {
|
2115
|
0
|
|
|
|
|
0
|
while ($i < $size) {
|
2116
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, $i);
|
2117
|
0
|
0
|
|
|
|
0
|
return $first_idx ? $i : $_ if &$code;
|
|
|
0
|
|
|
|
|
|
2118
|
0
|
|
|
|
|
0
|
$i++;
|
2119
|
|
|
|
|
|
|
}
|
2120
|
|
|
|
|
|
|
}
|
2121
|
|
|
|
|
|
|
return
|
2122
|
0
|
|
|
|
|
0
|
}
|
2123
|
|
|
|
|
|
|
sub last {
|
2124
|
0
|
0
|
|
0
|
|
0
|
@_ == 1 ? $_[0]->get( $_[0]->apply->size-1 )
|
2125
|
|
|
|
|
|
|
: $_[0]->reverse->first($_[1])
|
2126
|
|
|
|
|
|
|
}
|
2127
|
|
|
|
|
|
|
|
2128
|
|
|
|
|
|
|
sub first_idx {
|
2129
|
0
|
|
|
0
|
|
0
|
local $first_idx = 1;
|
2130
|
0
|
|
|
|
|
0
|
&first
|
2131
|
|
|
|
|
|
|
}
|
2132
|
|
|
|
|
|
|
sub last_idx {
|
2133
|
0
|
|
|
0
|
|
0
|
local $first_idx = 1;
|
2134
|
0
|
|
|
|
|
0
|
&last
|
2135
|
|
|
|
|
|
|
}
|
2136
|
|
|
|
|
|
|
BEGIN {
|
2137
|
10
|
|
|
10
|
|
36
|
*firstidx = *first_idx;
|
2138
|
10
|
|
|
|
|
47036
|
*lastidx = *last_idx;
|
2139
|
|
|
|
|
|
|
}
|
2140
|
|
|
|
|
|
|
|
2141
|
|
|
|
|
|
|
sub deref {
|
2142
|
0
|
|
|
0
|
|
0
|
List::Gen::tiegen(Deref => @_)
|
2143
|
|
|
|
|
|
|
}
|
2144
|
|
|
|
|
|
|
List::Gen::generator Deref => sub {
|
2145
|
0
|
|
|
0
|
|
0
|
my ($class, $gen, $mod) = @_;
|
2146
|
0
|
|
|
|
|
0
|
my ($src, $pos) = (tied @$gen, -1);
|
2147
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = $src->closures;
|
2148
|
0
|
|
|
|
|
0
|
my ($ref, $i);
|
2149
|
0
|
|
0
|
|
|
0
|
$mod ||= @{$ref = $fetch->(undef, $pos = 0)};
|
|
0
|
|
|
|
|
0
|
|
2150
|
0
|
|
|
|
|
0
|
my $size = $fsize->();
|
2151
|
|
|
|
|
|
|
List::Gen::curse {
|
2152
|
|
|
|
|
|
|
FETCH => sub {
|
2153
|
0
|
|
|
0
|
|
0
|
$i = int ($_[1] / $mod);
|
2154
|
0
|
0
|
|
|
|
0
|
$ref = $fetch->(undef, $pos = $i) if $i != $pos;
|
2155
|
0
|
|
|
|
|
0
|
$$ref[ $_[1] % $mod ]
|
2156
|
|
|
|
|
|
|
},
|
2157
|
0
|
|
|
|
|
0
|
fsize => $src->mutable ? do {
|
2158
|
0
|
|
|
|
|
0
|
$src->tail_size($size);
|
2159
|
0
|
|
|
0
|
|
0
|
sub {$size * $mod}
|
2160
|
0
|
|
|
|
|
0
|
}
|
2161
|
0
|
|
|
0
|
|
0
|
: do {$size *= $mod; sub {$size}},
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2162
|
|
|
|
|
|
|
source => sub {$src},
|
2163
|
0
|
0
|
|
|
|
0
|
} => $class
|
2164
|
|
|
|
|
|
|
};
|
2165
|
|
|
|
|
|
|
|
2166
|
|
|
|
|
|
|
sub drop_while {
|
2167
|
0
|
|
|
0
|
|
0
|
my ($gen, $code) = @_;
|
2168
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2169
|
0
|
|
|
0
|
|
0
|
$gen->drop_until(sub {not &$code})
|
2170
|
|
|
|
|
|
|
|
2171
|
0
|
|
|
|
|
0
|
}
|
2172
|
|
|
|
|
|
|
sub drop_until {
|
2173
|
0
|
|
|
0
|
|
0
|
my ($gen, $code) = @_;
|
2174
|
0
|
|
|
|
|
0
|
my $n = $gen->first_idx($code);
|
2175
|
0
|
0
|
|
|
|
0
|
defined $n ? $gen->drop($n) : List::Gen::empty()
|
2176
|
|
|
|
|
|
|
}
|
2177
|
|
|
|
|
|
|
|
2178
|
|
|
|
|
|
|
sub cross2d {
|
2179
|
0
|
0
|
|
0
|
|
0
|
if ($_[1]->$is_array_or_gen) {
|
2180
|
0
|
|
|
|
|
0
|
$_[0]->crosswith2d($comma, @_[1..$#_])
|
2181
|
|
|
|
|
|
|
} else {
|
2182
|
0
|
|
|
|
|
0
|
goto &crosswith2d
|
2183
|
|
|
|
|
|
|
}
|
2184
|
|
|
|
|
|
|
}
|
2185
|
|
|
|
|
|
|
sub crosswith2d {
|
2186
|
0
|
|
|
0
|
|
0
|
my ($xs, $code, $ys) = splice @_, 0, 3;
|
2187
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2188
|
0
|
0
|
|
|
|
0
|
if (grep {$_->is_mutable} $xs, $ys) {
|
|
0
|
|
|
|
|
0
|
|
2189
|
0
|
|
|
|
|
0
|
Carp::croak "mutable generators not yet supported"
|
2190
|
|
|
|
|
|
|
}
|
2191
|
|
|
|
|
|
|
&List::Gen::iterate(sub {
|
2192
|
0
|
|
|
0
|
|
0
|
my $x = $xs->get($_);
|
2193
|
0
|
|
|
|
|
0
|
&List::Gen::gen(sub {$code->($x, $_)}, $ys)
|
|
0
|
|
|
|
|
0
|
|
2194
|
0
|
|
|
|
|
0
|
}, $xs->size);
|
2195
|
|
|
|
|
|
|
}
|
2196
|
|
|
|
|
|
|
|
2197
|
|
|
|
|
|
|
sub cross {
|
2198
|
5
|
100
|
|
5
|
|
11
|
if ($_[1]->$is_array_or_gen) {
|
2199
|
1
|
|
|
|
|
12
|
$_[0]->crosswith($comma, @_[1..$#_])
|
2200
|
|
|
|
|
|
|
} else {
|
2201
|
4
|
|
|
|
|
13
|
goto &crosswith
|
2202
|
|
|
|
|
|
|
}
|
2203
|
|
|
|
|
|
|
}
|
2204
|
|
|
|
|
|
|
sub crosswith {
|
2205
|
5
|
|
|
5
|
|
11
|
my ($xs, $code, $ys) = splice @_, 0, 3;
|
2206
|
5
|
|
|
|
|
13
|
$code->$sv2cv;
|
2207
|
5
|
50
|
|
|
|
14
|
if (@_) {
|
2208
|
0
|
|
|
|
|
0
|
$xs = $xs->crosswith($code, $_) for $ys, @_;
|
2209
|
0
|
|
|
|
|
0
|
return $xs
|
2210
|
|
|
|
|
|
|
}
|
2211
|
5
|
|
|
|
|
6
|
my $mutable;
|
2212
|
|
|
|
|
|
|
List::Gen::mapn {
|
2213
|
10
|
|
|
10
|
|
23
|
$_[1] = $_->size;
|
2214
|
10
|
50
|
|
|
|
50
|
if ($_->is_mutable) {
|
2215
|
0
|
|
|
|
|
0
|
$mutable = $_[2] = 1;
|
2216
|
0
|
|
|
|
|
0
|
$_->tail_size($_[1])
|
2217
|
|
|
|
|
|
|
}
|
2218
|
5
|
|
|
|
|
31
|
} 3 => $xs => my ($xsize, $xs_mutable),
|
2219
|
|
|
|
|
|
|
$ys => my ($ysize, $ys_mutable);
|
2220
|
|
|
|
|
|
|
|
2221
|
5
|
50
|
33
|
|
|
30
|
if ($ysize >= 9**9**9 and not $ys_mutable) {
|
2222
|
|
|
|
|
|
|
return &List::Gen::gen(sub {
|
2223
|
0
|
|
|
0
|
|
0
|
$code->($xs->get(0), $ys->get($_))
|
2224
|
|
|
|
|
|
|
})
|
2225
|
0
|
|
|
|
|
0
|
}
|
2226
|
5
|
50
|
33
|
|
|
14
|
if ($xsize >= 9**9**9 and not $xs_mutable) {
|
2227
|
|
|
|
|
|
|
return &List::Gen::gen(sub {
|
2228
|
0
|
|
|
0
|
|
0
|
$code->($xs->get(int($_ / $ysize)), $ys->get($_ % $ysize))
|
2229
|
|
|
|
|
|
|
})
|
2230
|
0
|
|
|
|
|
0
|
}
|
2231
|
5
|
|
|
|
|
6
|
my ($xi, $yi, $gen);
|
2232
|
5
|
100
|
|
|
|
14
|
if ($code == $comma) {
|
2233
|
1
|
|
|
|
|
3
|
my $i;
|
2234
|
|
|
|
|
|
|
my $got;
|
2235
|
|
|
|
|
|
|
$gen = &List::Gen::gen(
|
2236
|
|
|
|
|
|
|
$mutable
|
2237
|
|
|
|
|
|
|
? do {
|
2238
|
|
|
|
|
|
|
my $set_size = sub {
|
2239
|
0
|
|
|
0
|
|
0
|
$gen->set_size($xs->size * $ys->size * 2)
|
2240
|
0
|
|
|
|
|
0
|
};
|
2241
|
0
|
0
|
|
|
|
0
|
$xs->when_done($set_size) if $xs_mutable;
|
2242
|
0
|
0
|
|
|
|
0
|
$ys->when_done($set_size) if $ys_mutable;
|
2243
|
|
|
|
|
|
|
sub {
|
2244
|
0
|
0
|
0
|
0
|
|
0
|
if ($got and int($_ / 2) == $i) {
|
2245
|
0
|
|
|
|
|
0
|
return $$got[$_ % 2]
|
2246
|
|
|
|
|
|
|
}
|
2247
|
0
|
|
|
|
|
0
|
$i = int ($_ / 2);
|
2248
|
0
|
|
|
|
|
0
|
$xi = int ($i / $ysize);
|
2249
|
0
|
|
|
|
|
0
|
$yi = $i - $xi * $ysize;
|
2250
|
0
|
|
|
|
|
0
|
$got = sub {\@_}->($xs->get($xi), $ys->get($yi));
|
|
0
|
|
|
|
|
0
|
|
2251
|
0
|
|
|
|
|
0
|
$$got[$_ % 2]
|
2252
|
|
|
|
|
|
|
}
|
2253
|
0
|
|
|
|
|
0
|
}
|
2254
|
|
|
|
|
|
|
: sub {
|
2255
|
18
|
|
|
18
|
|
44
|
$i = int ($_ / 2);
|
2256
|
18
|
|
|
|
|
19
|
$xi = int ($i / $ysize);
|
2257
|
18
|
100
|
|
|
|
47
|
$_ % 2 ? $ys->get($i - $xi * $ysize)
|
2258
|
|
|
|
|
|
|
: $xs->get($xi)
|
2259
|
|
|
|
|
|
|
},
|
2260
|
1
|
50
|
|
|
|
11
|
$xsize * $ysize * 2
|
2261
|
|
|
|
|
|
|
)
|
2262
|
|
|
|
|
|
|
} else {
|
2263
|
|
|
|
|
|
|
$gen = &List::Gen::gen(
|
2264
|
|
|
|
|
|
|
$mutable
|
2265
|
|
|
|
|
|
|
? do {
|
2266
|
|
|
|
|
|
|
my $set_size = sub {
|
2267
|
0
|
|
|
0
|
|
0
|
$gen->set_size($xs->size * $ys->size)
|
2268
|
0
|
|
|
|
|
0
|
};
|
2269
|
0
|
0
|
|
|
|
0
|
$xs->when_done($set_size) if $xs_mutable;
|
2270
|
0
|
0
|
|
|
|
0
|
$ys->when_done($set_size) if $ys_mutable;
|
2271
|
|
|
|
|
|
|
sub {
|
2272
|
0
|
|
|
0
|
|
0
|
$xi = int ($_ / $ysize);
|
2273
|
0
|
|
|
|
|
0
|
$yi = $_ - $xi * $ysize;
|
2274
|
0
|
|
|
|
|
0
|
$code->($xs->get($xi), $ys->get($yi))
|
2275
|
|
|
|
|
|
|
}
|
2276
|
0
|
|
|
|
|
0
|
}
|
2277
|
|
|
|
|
|
|
: sub {
|
2278
|
21
|
|
|
21
|
|
30
|
$xi = int ($_ / $ysize);
|
2279
|
21
|
|
|
|
|
24
|
$yi = $_ - $xi * $ysize;
|
2280
|
21
|
|
|
|
|
42
|
$code->($xs->get($xi), $ys->get($yi))
|
2281
|
|
|
|
|
|
|
},
|
2282
|
4
|
50
|
|
|
|
26
|
$xsize * $ysize
|
2283
|
|
|
|
|
|
|
)
|
2284
|
|
|
|
|
|
|
}
|
2285
|
5
|
50
|
|
|
|
24
|
$gen = &List::Gen::mutable($gen) if $mutable;
|
2286
|
5
|
|
|
|
|
36
|
$gen
|
2287
|
|
|
|
|
|
|
}
|
2288
|
|
|
|
|
|
|
|
2289
|
|
|
|
|
|
|
sub cycle {
|
2290
|
0
|
|
|
0
|
|
0
|
my $src = shift;
|
2291
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = tied(@$src)->closures;
|
2292
|
0
|
|
|
|
|
0
|
my $size = $fsize->();
|
2293
|
|
|
|
|
|
|
$src->is_mutable
|
2294
|
|
|
|
|
|
|
? do {
|
2295
|
0
|
|
|
|
|
0
|
$src->tail_size($size);
|
2296
|
|
|
|
|
|
|
&List::Gen::gen(sub {
|
2297
|
0
|
0
|
|
0
|
|
0
|
my $ret = \$fetch->(undef, $size >= 9**9**9 ? $_ : $_ % $size);
|
2298
|
0
|
0
|
|
|
|
0
|
$_ < $size ? $$ret : $fetch->(undef, $_ % $size)
|
2299
|
|
|
|
|
|
|
})
|
2300
|
0
|
|
|
|
|
0
|
}
|
2301
|
0
|
0
|
|
|
|
0
|
: do {
|
2302
|
0
|
|
|
0
|
|
0
|
$size >= 9**9**9
|
2303
|
|
|
|
|
|
|
? $src
|
2304
|
|
|
|
|
|
|
: &List::Gen::gen(sub {$fetch->(undef, $_ % $size)})
|
2305
|
0
|
0
|
|
|
|
0
|
}
|
2306
|
|
|
|
|
|
|
}
|
2307
|
|
|
|
|
|
|
|
2308
|
|
|
|
|
|
|
sub reduce {
|
2309
|
7
|
|
|
7
|
|
10
|
my ($self, $code) = @_;
|
2310
|
7
|
|
|
|
|
17
|
$code->$sv2cv;
|
2311
|
7
|
50
|
|
|
|
21
|
return $self if $code == $comma;
|
2312
|
7
|
50
|
|
|
|
17
|
return $self->flip if $code == $rcomma;
|
2313
|
|
|
|
|
|
|
|
2314
|
7
|
|
|
|
|
17
|
my ($ca, $cb) = $code->$cv_ab_ref;
|
2315
|
7
|
|
|
|
|
26
|
local (*a, *b) = local (*$ca, *$cb);
|
2316
|
|
|
|
|
|
|
|
2317
|
7
|
|
|
|
|
56
|
my $fetch = tied(@$self)->can('FETCH');
|
2318
|
7
|
50
|
|
|
|
44
|
$a = $fetch->(undef, 0) if @$self;
|
2319
|
7
|
50
|
|
|
|
16
|
return unless @$self;
|
2320
|
|
|
|
|
|
|
|
2321
|
7
|
|
|
|
|
15
|
my $args = $code->$cv_wants_2_args;
|
2322
|
7
|
50
|
|
|
|
19
|
if ($self->is_mutable) {
|
2323
|
0
|
|
|
|
|
0
|
my $i;
|
2324
|
0
|
|
|
|
|
0
|
my $size = $self->size;
|
2325
|
0
|
|
|
|
|
0
|
$self->tail_size($size);
|
2326
|
0
|
|
|
|
|
0
|
while (++$i < $size) {
|
2327
|
0
|
|
|
|
|
0
|
$b = $fetch->(undef, $i);
|
2328
|
0
|
0
|
|
|
|
0
|
last if $i >= $size;
|
2329
|
0
|
0
|
|
|
|
0
|
$a = $code->($args ? ($a, $b) : ())
|
2330
|
|
|
|
|
|
|
}
|
2331
|
|
|
|
|
|
|
} else {
|
2332
|
7
|
50
|
|
|
|
21
|
$self->size < 9**9**9 or Carp::croak "can not reduce infinite generator";
|
2333
|
7
|
|
|
|
|
436
|
for (1 .. $#$self) {
|
2334
|
45
|
|
|
|
|
74
|
$b = $fetch->(undef, $_);
|
2335
|
45
|
50
|
|
|
|
529
|
$a = $code->($args ? ($a, $b) : ())
|
2336
|
|
|
|
|
|
|
}
|
2337
|
|
|
|
|
|
|
}
|
2338
|
7
|
|
|
|
|
52
|
$a
|
2339
|
|
|
|
|
|
|
}
|
2340
|
0
|
0
|
|
0
|
|
0
|
sub sum {$_[0]->reduce(sub {$a + $b}) or 0}
|
|
0
|
|
|
0
|
|
0
|
|
2341
|
0
|
0
|
|
0
|
|
0
|
sub product {$_[0]->reduce(sub {$a * $b}) or 0}
|
|
0
|
|
|
0
|
|
0
|
|
2342
|
0
|
0
|
|
0
|
|
0
|
sub min {$_[0]->reduce(sub {$a > $b ? $b : $a})}
|
|
0
|
|
|
0
|
|
0
|
|
2343
|
0
|
0
|
|
0
|
|
0
|
sub max {$_[0]->reduce(sub {$a > $b ? $a : $b})}
|
|
0
|
|
|
0
|
|
0
|
|
2344
|
|
|
|
|
|
|
|
2345
|
|
|
|
|
|
|
sub rotate {
|
2346
|
0
|
|
|
0
|
|
0
|
my ($self, $n) = (@_, 1);
|
2347
|
0
|
0
|
|
|
|
0
|
$self->apply if $self->is_mutable;
|
2348
|
0
|
|
|
|
|
0
|
my $size = $self->size;
|
2349
|
0
|
0
|
|
|
|
0
|
if ($n < 0) {
|
2350
|
0
|
|
|
|
|
0
|
$n = $size - (abs($n) % $size);
|
2351
|
|
|
|
|
|
|
}
|
2352
|
0
|
0
|
|
|
|
0
|
return $self->drop($n) if $size >= 9**9**9;
|
2353
|
0
|
0
|
|
|
|
0
|
if ($n >= $size) {
|
2354
|
0
|
|
|
|
|
0
|
$n %= $size
|
2355
|
|
|
|
|
|
|
}
|
2356
|
0
|
|
|
|
|
0
|
List::Gen::tiegen( Rotate => tied @$self, $n )
|
2357
|
|
|
|
|
|
|
}
|
2358
|
|
|
|
|
|
|
|
2359
|
|
|
|
|
|
|
List::Gen::generator Rotate => sub {
|
2360
|
0
|
|
|
0
|
|
0
|
my ($class, $src, $n) = @_;
|
2361
|
0
|
|
|
|
|
0
|
my $size = $src->fsize;
|
2362
|
0
|
|
|
|
|
0
|
while ($src->can('rotate')) {
|
2363
|
0
|
|
|
|
|
0
|
$n += $src->rotate;
|
2364
|
0
|
|
|
|
|
0
|
$src = $src->source;
|
2365
|
|
|
|
|
|
|
}
|
2366
|
0
|
|
|
|
|
0
|
my $fetch = $src->can('FETCH');
|
2367
|
0
|
|
|
0
|
|
0
|
&List::Gen::curse({
|
2368
|
|
|
|
|
|
|
FETCH => sub {$fetch->(undef, ($_[1] + $n) % $size)},
|
2369
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
2370
|
0
|
|
|
0
|
|
0
|
source => sub {$src},
|
2371
|
0
|
|
|
0
|
|
0
|
rotate => sub {$n},
|
2372
|
0
|
|
|
|
|
0
|
} => $class)
|
2373
|
0
|
|
|
0
|
|
0
|
}, mutable => sub {0};
|
2374
|
|
|
|
|
|
|
|
2375
|
|
|
|
|
|
|
sub nxt {
|
2376
|
0
|
|
|
0
|
|
0
|
my ($self, $n) = @_;
|
2377
|
0
|
|
|
|
|
0
|
my @ret;
|
2378
|
0
|
|
|
|
|
0
|
while ($self->more) {
|
2379
|
0
|
0
|
|
|
|
0
|
my @x = $self->next or next;
|
2380
|
0
|
0
|
|
|
|
0
|
if ($n) {
|
2381
|
0
|
|
|
|
|
0
|
push @ret, @x;
|
2382
|
0
|
0
|
|
|
|
0
|
next if @ret < $n;
|
2383
|
|
|
|
|
|
|
last
|
2384
|
0
|
|
|
|
|
0
|
}
|
2385
|
0
|
0
|
|
|
|
0
|
return wantarray ? @x : pop @x
|
2386
|
|
|
|
|
|
|
}
|
2387
|
0
|
0
|
|
|
|
0
|
wantarray ? @ret : &List::Gen::makegen(\@ret)
|
2388
|
|
|
|
|
|
|
}
|
2389
|
|
|
|
|
|
|
|
2390
|
|
|
|
|
|
|
sub span {
|
2391
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
2392
|
0
|
0
|
|
|
|
0
|
if (@_) {
|
2393
|
0
|
|
|
|
|
0
|
my $code = shift;
|
2394
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2395
|
0
|
|
|
|
|
0
|
my $size = $self->size;
|
2396
|
0
|
0
|
|
|
|
0
|
$self->tail_size($size) if $self->is_mutable;
|
2397
|
0
|
|
|
|
|
0
|
my $done;
|
2398
|
0
|
|
|
|
|
0
|
my $take = $self->take_while($code);
|
2399
|
0
|
|
|
0
|
|
0
|
$take->when_done(sub {$done = $take->size});
|
|
0
|
|
|
|
|
0
|
|
2400
|
|
|
|
|
|
|
my $drop = &List::Gen::gen(sub {
|
2401
|
0
|
0
|
|
0
|
|
0
|
$take->apply unless defined $done;
|
2402
|
0
|
|
|
|
|
0
|
my $i = $_ + $done;
|
2403
|
0
|
0
|
|
|
|
0
|
List::Gen::done() if $i >= $size;
|
2404
|
0
|
|
|
|
|
0
|
my $x = $self->get($_ + $done);
|
2405
|
0
|
0
|
|
|
|
0
|
List::Gen::done() if $i >= $size;
|
2406
|
0
|
0
|
|
|
|
0
|
List::Gen::done($x) if $i == $size - 1;
|
2407
|
0
|
|
|
|
|
0
|
$x
|
2408
|
0
|
|
|
|
|
0
|
})->mutable;
|
2409
|
0
|
|
|
|
|
0
|
$take, $drop
|
2410
|
|
|
|
|
|
|
}
|
2411
|
|
|
|
|
|
|
else {
|
2412
|
0
|
|
|
|
|
0
|
my (@i, @ret);
|
2413
|
0
|
|
|
|
|
0
|
while ($self->more) {
|
2414
|
0
|
0
|
|
|
|
0
|
@ret ? last : next unless @i = $self->next;
|
|
|
0
|
|
|
|
|
|
2415
|
0
|
|
|
|
|
0
|
push @ret, @i;
|
2416
|
|
|
|
|
|
|
}
|
2417
|
0
|
0
|
|
|
|
0
|
wantarray ? @ret : \@ret
|
2418
|
|
|
|
|
|
|
}
|
2419
|
|
|
|
|
|
|
}
|
2420
|
|
|
|
|
|
|
sub break {
|
2421
|
0
|
|
|
0
|
|
0
|
my ($self, $code) = @_;
|
2422
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2423
|
0
|
|
|
0
|
|
0
|
$self->span(sub {not &$code})
|
2424
|
0
|
|
|
|
|
0
|
}
|
2425
|
|
|
|
|
|
|
|
2426
|
|
|
|
|
|
|
sub zip {
|
2427
|
6
|
100
|
|
6
|
|
23
|
if ($_[1]->$is_array_or_gen) {
|
2428
|
2
|
|
|
|
|
10
|
goto &List::Gen::zipgen
|
2429
|
|
|
|
|
|
|
}
|
2430
|
4
|
|
|
|
|
14
|
goto &zipwith
|
2431
|
|
|
|
|
|
|
}
|
2432
|
|
|
|
|
|
|
sub zipwith {
|
2433
|
4
|
|
|
4
|
|
12
|
my ($self, $code) = splice @_, 0, 2;
|
2434
|
4
|
|
|
|
|
8
|
$code->$sv2cv;
|
2435
|
4
|
|
|
|
|
13
|
&List::Gen::zipwith($code, $self, @_);
|
2436
|
|
|
|
|
|
|
}
|
2437
|
|
|
|
|
|
|
|
2438
|
|
|
|
|
|
|
sub zipwithab {
|
2439
|
0
|
|
|
0
|
|
0
|
my ($xs, $code, $ys) = @_;
|
2440
|
0
|
0
|
|
|
|
0
|
if ($code =~ /(?=.* \$a \b) (?=.* \$b \b)/sx) {
|
2441
|
0
|
|
|
|
|
0
|
$code = 'zipwithab'->$eval("sub {$code}");
|
2442
|
|
|
|
|
|
|
}
|
2443
|
0
|
0
|
|
|
|
0
|
ref $code eq 'CODE' or Carp::croak "not \$a / \$b code: $code";
|
2444
|
0
|
|
|
|
|
0
|
&List::Gen::zipwithab($code, $xs, $ys)
|
2445
|
|
|
|
|
|
|
}
|
2446
|
10
|
|
|
10
|
|
3060
|
BEGIN {*zipab = *zipwithab}
|
2447
|
|
|
|
|
|
|
|
2448
|
|
|
|
|
|
|
sub mapn {
|
2449
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
2450
|
0
|
0
|
|
|
|
0
|
my ($n, $code) = $_[0] =~ /^\d+$/ ? @_ : @_[1, 0];
|
2451
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2452
|
|
|
|
|
|
|
$self->by($n)->map(sub {
|
2453
|
0
|
|
|
0
|
|
0
|
local *_ = $_;
|
2454
|
0
|
|
|
|
|
0
|
local *_ = \$_[0];
|
2455
|
0
|
|
|
|
|
0
|
&$code
|
2456
|
|
|
|
|
|
|
})
|
2457
|
0
|
|
|
|
|
0
|
}
|
2458
|
|
|
|
|
|
|
|
2459
|
|
|
|
|
|
|
*clone = \&List::Gen::clone;
|
2460
|
|
|
|
|
|
|
sub copy {
|
2461
|
0
|
|
|
0
|
|
0
|
my $src = shift;
|
2462
|
0
|
|
|
|
|
0
|
my $new = clone($src);
|
2463
|
0
|
|
|
|
|
0
|
$new->index = $src->index;
|
2464
|
0
|
|
|
|
|
0
|
$new
|
2465
|
|
|
|
|
|
|
}
|
2466
|
|
|
|
|
|
|
{
|
2467
|
10
|
|
|
10
|
|
209
|
no warnings 'once';
|
|
10
|
|
|
|
|
25
|
|
|
10
|
|
|
|
|
876
|
|
2468
|
|
|
|
|
|
|
*For = *each = *do = sub {
|
2469
|
10
|
|
|
10
|
|
74
|
use warnings;
|
|
10
|
|
|
|
|
29
|
|
|
10
|
|
|
|
|
1340
|
|
2470
|
0
|
0
|
|
0
|
|
0
|
@_ == 2 or Carp::croak 'call as $gen->do/each(CODE or STRING)';
|
2471
|
0
|
|
|
|
|
0
|
my ($gen, $code) = @_;
|
2472
|
0
|
|
|
|
|
0
|
my $src = tied @$gen;
|
2473
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = $src->closures;
|
2474
|
0
|
|
|
|
|
0
|
my $i = 0;
|
2475
|
|
|
|
|
|
|
|
2476
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2477
|
0
|
|
|
|
|
0
|
my $last = $code->$cv_local('last');
|
2478
|
10
|
|
|
10
|
|
57
|
no warnings 'redefine';
|
|
10
|
|
|
|
|
22
|
|
|
10
|
|
|
|
|
771
|
|
2479
|
0
|
|
|
0
|
|
0
|
local *$last = sub {die bless [@_] => 'List::Gen::Last'};
|
|
0
|
|
|
|
|
0
|
|
2480
|
10
|
|
|
10
|
|
63
|
use warnings;
|
|
10
|
|
|
|
|
18
|
|
|
10
|
|
|
|
|
7187
|
|
2481
|
|
|
|
|
|
|
|
2482
|
0
|
|
|
|
|
0
|
my $warn = $SIG{__WARN__};
|
2483
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub {
|
2484
|
0
|
0
|
|
0
|
|
0
|
return if $_[0] =~ /^Exiting subroutine via last/i;
|
2485
|
0
|
0
|
|
|
|
0
|
$warn ? &$warn : print STDERR @_
|
2486
|
0
|
|
|
|
|
0
|
};
|
2487
|
0
|
|
|
|
|
0
|
local ($@, @_);
|
2488
|
0
|
|
|
|
|
0
|
local *_ = \0;
|
2489
|
0
|
|
|
|
|
0
|
eval {
|
2490
|
0
|
|
|
|
|
0
|
my $size = $fsize->();
|
2491
|
0
|
0
|
|
|
|
0
|
if ($src->mutable) {
|
2492
|
0
|
|
|
|
|
0
|
$src->tail_size($size);
|
2493
|
0
|
|
|
|
|
0
|
while ($i < $size) {
|
2494
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, $i);
|
2495
|
0
|
0
|
|
|
|
0
|
last unless $i++ < $size;
|
2496
|
0
|
|
|
|
|
0
|
&$code
|
2497
|
|
|
|
|
|
|
}
|
2498
|
|
|
|
|
|
|
} else {
|
2499
|
0
|
|
|
|
|
0
|
while ($i < $size) {
|
2500
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, $i++);
|
2501
|
0
|
|
|
|
|
0
|
&$code
|
2502
|
|
|
|
|
|
|
}
|
2503
|
|
|
|
|
|
|
}
|
2504
|
0
|
|
|
|
|
0
|
1} or ref $@
|
2505
|
|
|
|
|
|
|
? ref($@) =~ /^List::Gen::(Last|Done)$/
|
2506
|
0
|
0
|
|
|
|
0
|
? return wantarray ? @{$@} : pop @{$@}
|
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2507
|
|
|
|
|
|
|
: die $@
|
2508
|
|
|
|
|
|
|
: Carp::croak $@;
|
2509
|
|
|
|
|
|
|
return
|
2510
|
0
|
|
|
|
|
0
|
}
|
2511
|
|
|
|
|
|
|
}
|
2512
|
|
|
|
|
|
|
|
2513
|
0
|
|
|
0
|
|
0
|
sub head {tied(@{$_[0]})->FETCH(0)}
|
|
0
|
|
|
|
|
0
|
|
2514
|
|
|
|
|
|
|
{
|
2515
|
|
|
|
|
|
|
my ($slice, $range) = \(&List::Gen::slice, &List::Gen::range);
|
2516
|
0
|
|
0
|
0
|
|
0
|
{my $span; sub tail {$_[0]->$slice($span ||= $range->( 1 => 9**9**9 ))}}
|
2517
|
0
|
|
0
|
0
|
|
0
|
{my %span; sub drop {$_[0]->$slice($span{$_[1]} ||= $range->($_[1] => 9**9**9 ))}}
|
2518
|
9
|
|
66
|
9
|
|
374
|
{my %span; sub take {$_[0]->$slice($span{$_[1]} ||= $range->( 0 => $_[1] - 1))}}
|
2519
|
|
|
|
|
|
|
}
|
2520
|
10
|
|
|
10
|
|
66
|
{no strict 'refs';
|
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
3859
|
|
2521
|
|
|
|
|
|
|
for my $sub (qw(
|
2522
|
|
|
|
|
|
|
gen test cache expand contract collect flip While Until recursive
|
2523
|
|
|
|
|
|
|
mutable by every filter filter_stream scan scan_stream
|
2524
|
|
|
|
|
|
|
iterate iterate_multi iterate_stream iterate_multi_stream
|
2525
|
|
|
|
|
|
|
gather gather_multi gather_stream gather_multi_stream
|
2526
|
|
|
|
|
|
|
)) {
|
2527
|
|
|
|
|
|
|
my $code = \&{"List::Gen::$sub"};
|
2528
|
|
|
|
|
|
|
if ((prototype $code or '') =~ /^&/) {
|
2529
|
|
|
|
|
|
|
*$sub = sub {
|
2530
|
7
|
|
|
7
|
|
14
|
push @_, shift;
|
2531
|
7
|
|
|
|
|
18
|
$sv2cv->(my $sub = shift);
|
2532
|
7
|
|
|
|
|
15
|
unshift @_, $sub;
|
2533
|
7
|
|
|
|
|
80
|
goto &$code;
|
2534
|
|
|
|
|
|
|
}
|
2535
|
|
|
|
|
|
|
} else {
|
2536
|
0
|
|
|
0
|
|
0
|
*$sub = sub {push @_, shift; goto &$code}
|
|
0
|
|
|
|
|
0
|
|
2537
|
|
|
|
|
|
|
}
|
2538
|
|
|
|
|
|
|
if ($sub =~ /_/) {
|
2539
|
|
|
|
|
|
|
(my $joined = $sub) =~ s/_//g;
|
2540
|
|
|
|
|
|
|
(my $short = $sub) =~ s/_([a-z])[a-z]+/\U$1/g;
|
2541
|
|
|
|
|
|
|
*$short = *$joined = *$sub;
|
2542
|
|
|
|
|
|
|
}
|
2543
|
|
|
|
|
|
|
}
|
2544
|
10
|
|
|
10
|
|
73
|
{no warnings 'once';
|
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
104151
|
|
2545
|
|
|
|
|
|
|
*map = *gen;
|
2546
|
|
|
|
|
|
|
*grep = *filter;
|
2547
|
|
|
|
|
|
|
*x = *X = *cross;
|
2548
|
|
|
|
|
|
|
*z = *Z = *zip;
|
2549
|
|
|
|
|
|
|
*while = *take_while = *While;
|
2550
|
|
|
|
|
|
|
*until = *take_until = *Until;
|
2551
|
|
|
|
|
|
|
*rec = *with_self = *withself = *recursive;
|
2552
|
|
|
|
|
|
|
*cached = *memoized = *memoize = *cache;
|
2553
|
|
|
|
|
|
|
*filterS = *grepS = *grep_stream = *filter_stream;
|
2554
|
|
|
|
|
|
|
}
|
2555
|
|
|
|
|
|
|
for my $internal (qw(set_size when_done clear_done is_mutable set from
|
2556
|
|
|
|
|
|
|
PUSH POP SHIFT UNSHIFT SPLICE tail_size load)) {
|
2557
|
|
|
|
|
|
|
my $method = $internal eq 'is_mutable' ? 'mutable' : $internal;
|
2558
|
|
|
|
|
|
|
my $search = $internal =~ /^(?:set_size|when_done|clear_done)$/;
|
2559
|
|
|
|
|
|
|
*{lc $internal} = sub {
|
2560
|
45
|
|
|
45
|
|
58
|
my $gen = shift;
|
2561
|
45
|
|
|
|
|
624
|
my $self = tied @$gen;
|
2562
|
45
|
50
|
33
|
|
|
418
|
if (my $code = $self->can($method) || $search && do {
|
2563
|
|
|
|
|
|
|
my @src = $self->sources;
|
2564
|
|
|
|
|
|
|
while (@src) {
|
2565
|
|
|
|
|
|
|
last if $src[0]->can($method);
|
2566
|
|
|
|
|
|
|
shift @src;
|
2567
|
|
|
|
|
|
|
}
|
2568
|
|
|
|
|
|
|
@src ? ($self = $src[0])->can($method) : ()
|
2569
|
0
|
|
|
|
|
0
|
}) {
|
2570
|
45
|
|
|
|
|
85
|
unshift @_, $self;
|
2571
|
45
|
50
|
|
|
|
138
|
if ($internal =~ /^(PUSH|UNSHIFT|from|load)$/) {
|
|
45
|
|
|
|
|
78
|
|
2572
|
0
|
|
|
|
|
0
|
&$code;
|
2573
|
0
|
|
|
|
|
0
|
$gen
|
2574
|
|
|
|
|
|
|
} else {&$code}
|
2575
|
|
|
|
|
|
|
}
|
2576
|
|
|
|
|
|
|
else {Carp::croak "no method '$method' on '".ref($self)."'"}
|
2577
|
|
|
|
|
|
|
}
|
2578
|
|
|
|
|
|
|
}
|
2579
|
|
|
|
|
|
|
}
|
2580
|
0
|
|
|
0
|
|
0
|
sub reverse {goto &List::Gen::flip}
|
2581
|
0
|
|
|
0
|
|
0
|
sub overlay {goto &List::Gen::overlay}
|
2582
|
0
|
|
|
0
|
|
0
|
sub zipmax {goto &List::Gen::zipgenmax}
|
2583
|
|
|
|
|
|
|
sub zipwithmax {
|
2584
|
0
|
|
|
0
|
|
0
|
my $code = splice @_, 1, 1;
|
2585
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
2586
|
0
|
|
|
|
|
0
|
unshift @_, $code;
|
2587
|
0
|
|
|
|
|
0
|
goto &List::Gen::zipwithmax
|
2588
|
|
|
|
|
|
|
}
|
2589
|
|
|
|
|
|
|
|
2590
|
|
|
|
|
|
|
sub leaves {
|
2591
|
0
|
|
|
0
|
|
0
|
my @stack = @_;
|
2592
|
0
|
|
|
|
|
0
|
for (@stack) {
|
2593
|
0
|
0
|
0
|
|
|
0
|
$_->reset if ref and List::Gen::isagen($_)
|
2594
|
|
|
|
|
|
|
}
|
2595
|
|
|
|
|
|
|
sub {
|
2596
|
0
|
|
0
|
0
|
|
0
|
while (@stack and ref $stack[-1]
|
|
|
|
0
|
|
|
|
|
2597
|
|
|
|
|
|
|
and List::Gen::isagen($stack[-1])) {
|
2598
|
0
|
0
|
|
|
|
0
|
if (my @next = $stack[-1]->next) {
|
2599
|
0
|
|
|
|
|
0
|
for (@next) {
|
2600
|
0
|
0
|
0
|
|
|
0
|
$_->reset if ref and List::Gen::isagen($_)
|
2601
|
|
|
|
|
|
|
}
|
2602
|
0
|
|
|
|
|
0
|
push @stack, CORE::reverse @next;
|
2603
|
|
|
|
|
|
|
} else {
|
2604
|
0
|
|
|
|
|
0
|
(pop @stack)->reset;
|
2605
|
|
|
|
|
|
|
}
|
2606
|
|
|
|
|
|
|
}
|
2607
|
0
|
0
|
|
|
|
0
|
@stack ? pop @stack : ()
|
2608
|
|
|
|
|
|
|
}
|
2609
|
0
|
|
|
|
|
0
|
}
|
2610
|
|
|
|
|
|
|
{
|
2611
|
|
|
|
|
|
|
my %threaded;
|
2612
|
51
|
50
|
|
51
|
|
2493
|
sub DESTROY {$_[0]->threads_stop if delete $threaded{$_[0]}}
|
2613
|
|
|
|
|
|
|
|
2614
|
|
|
|
|
|
|
sub threads_start {
|
2615
|
0
|
0
|
|
0
|
|
0
|
$] < 5.013 or Carp::croak "threads not yet supported in perl 5.13+";
|
2616
|
0
|
|
|
|
|
0
|
$threaded{$_[0]} = 1;
|
2617
|
0
|
|
|
|
|
0
|
my $self = tied @{$_[0]};
|
|
0
|
|
|
|
|
0
|
|
2618
|
0
|
0
|
|
|
|
0
|
return if $$self{thread_queue};
|
2619
|
0
|
|
0
|
|
|
0
|
my $threads = $_[1] || 4;
|
2620
|
0
|
|
|
|
|
0
|
require threads;
|
2621
|
0
|
|
|
|
|
0
|
require Thread::Queue;
|
2622
|
0
|
|
|
|
|
0
|
$$self{$_} = Thread::Queue->new for qw(thread_queue thread_done);
|
2623
|
0
|
|
|
|
|
0
|
my $fetch = $self->can('FETCH');
|
2624
|
0
|
|
|
|
|
0
|
my $cached = $self->can('cached');
|
2625
|
0
|
0
|
0
|
|
|
0
|
if ($cached or $$self{thread_cached}) {
|
2626
|
0
|
0
|
|
|
|
0
|
if ($cached) {
|
2627
|
0
|
|
|
|
|
0
|
$cached = $cached->();
|
2628
|
0
|
0
|
|
|
|
0
|
unless (&threads::shared::is_shared($cached)) {
|
2629
|
0
|
|
|
|
|
0
|
my $type = Scalar::Util::reftype $cached;
|
2630
|
0
|
0
|
|
|
|
0
|
my @cache = $type eq 'HASH' ? %$cached : @$cached;
|
2631
|
0
|
|
|
|
|
0
|
&threads::shared::share($cached);
|
2632
|
0
|
0
|
|
|
|
0
|
($type eq 'HASH' ? %$cached : @$cached) = @cache;
|
2633
|
|
|
|
|
|
|
}
|
2634
|
|
|
|
|
|
|
} else {
|
2635
|
0
|
|
|
|
|
0
|
my $real_fetch = $fetch;
|
2636
|
0
|
|
|
|
|
0
|
my %cache;
|
2637
|
0
|
|
|
|
|
0
|
&threads::shared::share(\%cache);
|
2638
|
|
|
|
|
|
|
$fetch = sub {
|
2639
|
0
|
0
|
|
0
|
|
0
|
exists $cache{$_[1]}
|
2640
|
|
|
|
|
|
|
? $cache{$_[1]}
|
2641
|
|
|
|
|
|
|
:($cache{$_[1]} = $real_fetch->(undef, $_[1]))
|
2642
|
|
|
|
|
|
|
}
|
2643
|
0
|
|
|
|
|
0
|
}
|
2644
|
|
|
|
|
|
|
}
|
2645
|
0
|
|
|
|
|
0
|
@{$$self{thread_workers}} = map {
|
2646
|
0
|
|
|
|
|
0
|
threads->create(sub {
|
2647
|
0
|
|
|
0
|
|
0
|
while (my $job = $$self{thread_queue}->dequeue) {
|
2648
|
0
|
0
|
|
|
|
0
|
last if $job eq 'stop';
|
2649
|
0
|
|
|
|
|
0
|
$$self{thread_done}->enqueue(
|
2650
|
0
|
|
|
|
|
0
|
[$$job[0], sub {\@_}->(map $fetch->(undef, $_) => @{$$job[1]})]
|
|
0
|
|
|
|
|
0
|
|
2651
|
|
|
|
|
|
|
)
|
2652
|
|
|
|
|
|
|
}
|
2653
|
|
|
|
|
|
|
})
|
2654
|
0
|
|
|
|
|
0
|
} 1 .. $threads;
|
2655
|
0
|
|
|
|
|
0
|
$_[0];
|
2656
|
|
|
|
|
|
|
}
|
2657
|
|
|
|
|
|
|
sub threads_stop {
|
2658
|
0
|
|
|
0
|
|
0
|
my $self = tied @{$_[0]};
|
|
0
|
|
|
|
|
0
|
|
2659
|
0
|
0
|
|
|
|
0
|
if ($$self{thread_queue}) {
|
2660
|
0
|
|
|
|
|
0
|
$$self{thread_queue}->enqueue('stop') for @{$$self{thread_workers}};
|
|
0
|
|
|
|
|
0
|
|
2661
|
0
|
|
|
|
|
0
|
for (@{$$self{thread_workers}}) {
|
|
0
|
|
|
|
|
0
|
|
2662
|
0
|
|
|
|
|
0
|
$_->join;
|
2663
|
|
|
|
|
|
|
}
|
2664
|
0
|
|
|
|
|
0
|
delete $$self{"thread_$_"} for qw(queue done workers cache cached);
|
2665
|
|
|
|
|
|
|
}
|
2666
|
0
|
|
|
|
|
0
|
delete $threaded{$_[0]};
|
2667
|
0
|
|
|
|
|
0
|
$_[0]
|
2668
|
|
|
|
|
|
|
}
|
2669
|
|
|
|
|
|
|
}
|
2670
|
|
|
|
|
|
|
sub threads_slice {
|
2671
|
0
|
|
|
0
|
|
0
|
my $gen = shift;
|
2672
|
0
|
|
|
|
|
0
|
my $self = tied @$gen;
|
2673
|
0
|
0
|
|
|
|
0
|
$gen->threads_start unless $$self{thread_queue};
|
2674
|
0
|
|
|
|
|
0
|
my $threads = @{$$self{thread_workers}};
|
|
0
|
|
|
|
|
0
|
|
2675
|
0
|
|
0
|
|
|
0
|
my $step = $$self{thread_blocksize} || int(@_/$threads + 1);
|
2676
|
0
|
|
|
|
|
0
|
my $part = 0;
|
2677
|
|
|
|
|
|
|
List::Gen::mapn {
|
2678
|
0
|
|
|
0
|
|
0
|
$$self{thread_queue}->enqueue([$part++, \@_]);
|
2679
|
0
|
|
|
|
|
0
|
} $step => @_;
|
2680
|
0
|
|
|
|
|
0
|
my @result;
|
2681
|
0
|
|
|
|
|
0
|
for (1 .. $part) {
|
2682
|
0
|
|
|
|
|
0
|
my $got = $$self{thread_done}->dequeue;
|
2683
|
0
|
|
|
|
|
0
|
$result[$$got[0]] = $$got[1];
|
2684
|
|
|
|
|
|
|
}
|
2685
|
0
|
0
|
|
|
|
0
|
wantarray ? map @$_ => @result
|
2686
|
|
|
|
|
|
|
: $l2g->(map @$_ => @result)
|
2687
|
|
|
|
|
|
|
}
|
2688
|
|
|
|
|
|
|
sub threads_all {
|
2689
|
0
|
|
|
0
|
|
0
|
my $gen = shift;
|
2690
|
0
|
|
|
|
|
0
|
$gen->threads_slice(0 .. $gen->size - 1)
|
2691
|
|
|
|
|
|
|
}
|
2692
|
|
|
|
|
|
|
sub threads_cached {
|
2693
|
0
|
|
|
0
|
|
0
|
my $gen = shift;
|
2694
|
0
|
|
|
|
|
0
|
my $self = tied @$gen;
|
2695
|
0
|
0
|
|
|
|
0
|
Carp::carp "can not cache started threads" if $$self{thread_workers};
|
2696
|
0
|
|
|
|
|
0
|
$$self{thread_cached} = 1;
|
2697
|
0
|
0
|
|
|
|
0
|
$gen->threads_start(@_) if @_;
|
2698
|
0
|
|
|
|
|
0
|
$gen;
|
2699
|
|
|
|
|
|
|
}
|
2700
|
|
|
|
|
|
|
sub threads_blocksize {
|
2701
|
0
|
|
|
0
|
|
0
|
my $gen = shift;
|
2702
|
0
|
|
|
|
|
0
|
my $self = tied @$gen;
|
2703
|
0
|
|
|
|
|
0
|
my $size = int shift;
|
2704
|
0
|
0
|
|
|
|
0
|
Carp::croak "minimum block size is 1" if $size < 1;
|
2705
|
0
|
|
|
|
|
0
|
$$self{thread_blocksize} = $size;
|
2706
|
0
|
|
|
|
|
0
|
$gen;
|
2707
|
|
|
|
|
|
|
}
|
2708
|
|
|
|
|
|
|
}
|
2709
|
|
|
|
|
|
|
|
2710
|
|
|
|
|
|
|
sub isagen (;$) {
|
2711
|
117
|
100
|
66
|
117
|
0
|
1349
|
@_ ? (ref $_[0] and substr(ref $_[0], 0, 14) eq 'List::Gen::era' and $_[0])
|
|
|
|
33
|
|
|
|
|
2712
|
|
|
|
|
|
|
: (ref $_ and substr(ref $_, 0, 14) eq 'List::Gen::era' and $_)
|
2713
|
|
|
|
|
|
|
}
|
2714
|
|
|
|
|
|
|
sub tiegen {
|
2715
|
129
|
|
|
129
|
0
|
237
|
my @ret;
|
2716
|
129
|
|
|
|
|
177
|
my $class = shift;
|
2717
|
129
|
0
|
|
|
|
160
|
eval {tie @ret => 'List::Gen::'.$class, @_}
|
|
129
|
50
|
|
|
|
619
|
|
2718
|
|
|
|
|
|
|
or croak "error compiling $class, ",
|
2719
|
|
|
|
|
|
|
$@ =~ /^(.+) at .+?List-Gen.*$/s ? $1 : $@;
|
2720
|
|
|
|
|
|
|
|
2721
|
129
|
50
|
|
|
|
286
|
if (DEBUG) {
|
2722
|
0
|
|
|
|
|
0
|
my $src = tied @ret;
|
2723
|
0
|
|
|
|
|
0
|
(my $type = ref $src) =~ s/::_\d+$//;
|
2724
|
0
|
|
|
|
|
0
|
my @needs = do {
|
2725
|
0
|
|
|
|
|
0
|
my %exempt = (
|
2726
|
|
|
|
|
|
|
source => [qw(Range Capture Iterate Iterate_Multi Empty)],
|
2727
|
|
|
|
|
|
|
mutable => [qw(Gen Sequence Zip Flip Recursive Slice Mutable)],
|
2728
|
|
|
|
|
|
|
);
|
2729
|
0
|
|
|
|
|
0
|
$exempt{$_} = {map {;"List::Gen::$_" => 1} @{$exempt{$_}}} for keys %exempt;
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2730
|
0
|
0
|
0
|
0
|
|
0
|
grep {$$src{$_} ? 0 : B::svref_2object($src->can($_) or sub {})->STASH->NAME ne $type}
|
|
0
|
0
|
0
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2731
|
|
|
|
|
|
|
qw (FETCH fsize), ('source') x! $exempt{source}{$type},
|
2732
|
|
|
|
|
|
|
!$exempt{mutable}{$type} && $src->mutable ? qw(apply set_size _when_done tail_size) : ()
|
2733
|
|
|
|
|
|
|
};
|
2734
|
0
|
0
|
|
|
|
0
|
if (@needs) {
|
2735
|
0
|
|
|
|
|
0
|
$List::Gen::report{"$type needs @needs"}++;
|
2736
|
|
|
|
|
|
|
}
|
2737
|
|
|
|
|
|
|
}
|
2738
|
129
|
50
|
|
|
|
259
|
croak '$List::Gen::LIST is no longer supported' if $LIST;
|
2739
|
129
|
|
|
|
|
372
|
List::Gen::erator->new(\@ret)
|
2740
|
|
|
|
|
|
|
}
|
2741
|
10
|
50
|
|
10
|
|
82161
|
END {if (DEBUG) {warn "$_\n" for keys %List::Gen::report}}
|
|
0
|
|
|
|
|
0
|
|
2742
|
|
|
|
|
|
|
|
2743
|
|
|
|
|
|
|
sub done;
|
2744
|
|
|
|
|
|
|
sub done_if ($@);
|
2745
|
|
|
|
|
|
|
sub done_unless ($@);
|
2746
|
|
|
|
|
|
|
sub catch_done ();
|
2747
|
|
|
|
|
|
|
sub mutable;
|
2748
|
|
|
|
|
|
|
|
2749
|
|
|
|
|
|
|
sub clone {
|
2750
|
0
|
|
|
0
|
0
|
0
|
tiegen Clone => @_
|
2751
|
|
|
|
|
|
|
}
|
2752
|
|
|
|
|
|
|
generator Clone => sub {
|
2753
|
0
|
|
|
0
|
|
0
|
my $src = tied @{$_[1]};
|
|
0
|
|
|
|
|
0
|
|
2754
|
0
|
|
|
|
|
0
|
bless {%$src, self => [$_[1]]} => ref $src
|
2755
|
|
|
|
|
|
|
};
|
2756
|
|
|
|
|
|
|
|
2757
|
0
|
|
|
0
|
0
|
0
|
sub empty () {tiegen 'Empty'}
|
2758
|
|
|
|
|
|
|
generator Empty => sub {
|
2759
|
|
|
|
|
|
|
curse {
|
2760
|
0
|
|
|
0
|
|
0
|
FETCH => sub () { },
|
2761
|
|
|
|
|
|
|
fsize => sub () {0},
|
2762
|
|
|
|
|
|
|
} => shift
|
2763
|
0
|
|
|
0
|
|
0
|
};
|
2764
|
|
|
|
|
|
|
|
2765
|
|
|
|
|
|
|
|
2766
|
|
|
|
|
|
|
=head2 source generators
|
2767
|
|
|
|
|
|
|
|
2768
|
|
|
|
|
|
|
=over 4
|
2769
|
|
|
|
|
|
|
|
2770
|
|
|
|
|
|
|
=item range C< SIZE >
|
2771
|
|
|
|
|
|
|
|
2772
|
|
|
|
|
|
|
returns a generator from C< 0 > to C< SIZE - 1 >
|
2773
|
|
|
|
|
|
|
|
2774
|
|
|
|
|
|
|
my $range = range 10;
|
2775
|
|
|
|
|
|
|
|
2776
|
|
|
|
|
|
|
say $range->str; # 0 1 2 3 4 5 6 7 8 9
|
2777
|
|
|
|
|
|
|
say $range->size; # 10
|
2778
|
|
|
|
|
|
|
|
2779
|
|
|
|
|
|
|
=item range C< START STOP [STEP] >
|
2780
|
|
|
|
|
|
|
|
2781
|
|
|
|
|
|
|
returns a generator for values from C< START > to C< STOP > by C< STEP >,
|
2782
|
|
|
|
|
|
|
inclusive.
|
2783
|
|
|
|
|
|
|
|
2784
|
|
|
|
|
|
|
C< STEP > defaults to 1 but can be fractional and negative. depending on your
|
2785
|
|
|
|
|
|
|
choice of C< STEP >, the last value returned may not always be C< STOP >.
|
2786
|
|
|
|
|
|
|
|
2787
|
|
|
|
|
|
|
range(0, 3, 0.4) will return (0, 0.4, 0.8, 1.2, 1.6, 2, 2.4, 2.8)
|
2788
|
|
|
|
|
|
|
|
2789
|
|
|
|
|
|
|
print "$_ " for @{range 0, 1, 0.1};
|
2790
|
|
|
|
|
|
|
# 0 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1
|
2791
|
|
|
|
|
|
|
|
2792
|
|
|
|
|
|
|
print "$_ " for @{range 5, 0, -1};
|
2793
|
|
|
|
|
|
|
# 5 4 3 2 1 0
|
2794
|
|
|
|
|
|
|
|
2795
|
|
|
|
|
|
|
my $nums = range 0, 1_000_000, 2;
|
2796
|
|
|
|
|
|
|
print "@$nums[10, 100, 1000]";
|
2797
|
|
|
|
|
|
|
# gets the tenth, hundredth, and thousandth numbers in the range
|
2798
|
|
|
|
|
|
|
# without calculating any other values
|
2799
|
|
|
|
|
|
|
|
2800
|
|
|
|
|
|
|
C also accepts character strings instead of numbers. it will behave
|
2801
|
|
|
|
|
|
|
the same way as perl's internal C< .. > operator, except it will be lazy.
|
2802
|
|
|
|
|
|
|
|
2803
|
|
|
|
|
|
|
say range('a', 'z')->str; # 'a b c d e f g ... x y z'
|
2804
|
|
|
|
|
|
|
|
2805
|
|
|
|
|
|
|
range('a', 'zzz', 2)->say; # 'a c e g i k m ... zzu zzw zzy'
|
2806
|
|
|
|
|
|
|
|
2807
|
|
|
|
|
|
|
say ->str; # 'A B C D E ... ZX ZY ZZ'
|
2808
|
|
|
|
|
|
|
|
2809
|
|
|
|
|
|
|
<1..>->zip()->say(10); # '1 a 2 b 3 c 4 d 5 e'
|
2810
|
|
|
|
|
|
|
|
2811
|
|
|
|
|
|
|
to specify an infinite range, you can pass C< range > an infinite value
|
2812
|
|
|
|
|
|
|
(C< 9**9**9 > works well), or the glob C< ** >, or the string C< '*' >
|
2813
|
|
|
|
|
|
|
|
2814
|
|
|
|
|
|
|
range(1, 9**9**9) ~~ range(1, **) ~~ range(1, '*') ~~ <1..*> ~~ <1..>
|
2815
|
|
|
|
|
|
|
|
2816
|
|
|
|
|
|
|
ranges only store their endpoints, and ranges of all sizes take up the same
|
2817
|
|
|
|
|
|
|
amount of memory.
|
2818
|
|
|
|
|
|
|
|
2819
|
|
|
|
|
|
|
=cut
|
2820
|
|
|
|
|
|
|
|
2821
|
|
|
|
|
|
|
sub range ($;$$) {
|
2822
|
63
|
50
|
33
|
63
|
1
|
346
|
splice @_, 1, 1, 9**9**9
|
|
|
|
66
|
|
|
|
|
2823
|
|
|
|
|
|
|
if @_ > 1 and $_[1] eq '*'
|
2824
|
|
|
|
|
|
|
|| \$_[1] == \**;
|
2825
|
63
|
|
|
|
|
122
|
for (@_) {
|
2826
|
|
|
|
|
|
|
defined
|
2827
|
124
|
100
|
66
|
|
|
711
|
and /^[a-z]+$/i
|
|
|
|
100
|
|
|
|
|
2828
|
|
|
|
|
|
|
and not looks_like_number $_
|
2829
|
|
|
|
|
|
|
and goto &arange
|
2830
|
|
|
|
|
|
|
}
|
2831
|
57
|
100
|
|
|
|
231
|
tiegen Range => @_ == 1 ? (0, $_[0] - 1) : @_
|
2832
|
|
|
|
|
|
|
}
|
2833
|
|
|
|
|
|
|
generator Range => sub {
|
2834
|
57
|
|
|
57
|
|
131
|
my ($class, $low, $high, $step, $size) = (@_, 1);
|
2835
|
|
|
|
|
|
|
$size = $high < 9**9**9
|
2836
|
57
|
100
|
|
|
|
132
|
? do {
|
2837
|
31
|
50
|
|
|
|
77
|
$size = $step > 0 ? $high - $low : $low - $high;
|
2838
|
31
|
|
|
|
|
69
|
$size = 1 + $size / abs $step;
|
2839
|
31
|
50
|
|
|
|
62
|
$size > 0 ? int $size : 0
|
2840
|
|
|
|
|
|
|
} : $high;
|
2841
|
|
|
|
|
|
|
|
2842
|
57
|
50
|
|
|
|
223
|
$size = 0 unless $low < 9**9**9;
|
2843
|
|
|
|
|
|
|
curse {
|
2844
|
|
|
|
|
|
|
FETCH => sub {
|
2845
|
125
|
50
|
|
125
|
|
497
|
$_[1] < $size
|
2846
|
|
|
|
|
|
|
? $low + $step * $_[1]
|
2847
|
0
|
|
|
|
|
0
|
: croak "range index $_[1] out of bounds [0 .. @{[$size - 1]}]"
|
2848
|
|
|
|
|
|
|
},
|
2849
|
81
|
|
|
81
|
|
424
|
fsize => sub {$size},
|
2850
|
45
|
|
|
45
|
|
131
|
range => sub {$low, $step, $size},
|
2851
|
57
|
|
|
|
|
605
|
} => $class
|
2852
|
|
|
|
|
|
|
};
|
2853
|
|
|
|
|
|
|
|
2854
|
|
|
|
|
|
|
{my %map; @map{0..25} = 'a'..'z';
|
2855
|
|
|
|
|
|
|
my @cache = 'a'..'zz';
|
2856
|
|
|
|
|
|
|
sub num2alpha {
|
2857
|
24
|
50
|
|
24
|
0
|
40
|
my $num = @_ ? $_[0] : $_;
|
2858
|
24
|
50
|
|
|
|
44
|
return '-'.num2alpha(-$num) if $num < 0;
|
2859
|
24
|
50
|
|
|
|
96
|
return $cache[$num] if $num < 702;
|
2860
|
0
|
|
|
|
|
0
|
my @str;
|
2861
|
0
|
|
|
|
|
0
|
while ($num > -1) {
|
2862
|
0
|
|
|
|
|
0
|
unshift @str, $map{$num % 26};
|
2863
|
0
|
|
|
|
|
0
|
$num = int($num / 26) - 1;
|
2864
|
|
|
|
|
|
|
}
|
2865
|
0
|
|
|
|
|
0
|
join '' => @str
|
2866
|
|
|
|
|
|
|
}}
|
2867
|
|
|
|
|
|
|
|
2868
|
|
|
|
|
|
|
{my %map; @map{'a'..'z'} = 0..25;
|
2869
|
|
|
|
|
|
|
sub alpha2num {
|
2870
|
9
|
|
|
9
|
0
|
11
|
my $str = shift;
|
2871
|
9
|
50
|
|
|
|
15
|
return -alpha2num($1) if $str =~ /^-(.+)/;
|
2872
|
9
|
|
|
|
|
10
|
my ($num, $scale);
|
2873
|
9
|
|
|
|
|
27
|
for (split //, reverse $str) {
|
2874
|
9
|
|
|
|
|
28
|
$num += ($map{$_} + !!$scale) * 26**$scale++
|
2875
|
|
|
|
|
|
|
}
|
2876
|
|
|
|
|
|
|
$num
|
2877
|
9
|
|
|
|
|
24
|
}}
|
2878
|
|
|
|
|
|
|
|
2879
|
|
|
|
|
|
|
sub arange {
|
2880
|
6
|
50
|
|
6
|
0
|
21
|
my ($low, $high, $step) = (@_ == 1 ? 'a' : (), @_, 1);
|
2881
|
6
|
|
|
|
|
13
|
my $uc = $low =~ /^[A-Z]+$/;
|
2882
|
6
|
|
|
|
|
11
|
for ($low, $high) {
|
2883
|
12
|
100
|
66
|
|
|
54
|
$_ = alpha2num lc if /^[a-z]+$/i and not looks_like_number $_
|
2884
|
|
|
|
|
|
|
}
|
2885
|
6
|
50
|
|
|
|
17
|
if ($step =~ /^[a-z]+$/i) {
|
2886
|
0
|
|
|
|
|
0
|
$step = 1 + alpha2num lc $step;
|
2887
|
|
|
|
|
|
|
}
|
2888
|
6
|
50
|
|
0
|
|
22
|
&gen($uc ? sub {uc &num2alpha} : \&num2alpha, $low, $high, $step)
|
|
0
|
|
|
|
|
0
|
|
2889
|
|
|
|
|
|
|
}
|
2890
|
|
|
|
|
|
|
|
2891
|
|
|
|
|
|
|
|
2892
|
|
|
|
|
|
|
=item gen C< {CODE} GENERATOR >
|
2893
|
|
|
|
|
|
|
|
2894
|
|
|
|
|
|
|
=item gen C< {CODE} ARRAYREF >
|
2895
|
|
|
|
|
|
|
|
2896
|
|
|
|
|
|
|
=item gen C< {CODE} SIZE >
|
2897
|
|
|
|
|
|
|
|
2898
|
|
|
|
|
|
|
=item gen C< {CODE} [START STOP [STEP]] >
|
2899
|
|
|
|
|
|
|
|
2900
|
|
|
|
|
|
|
=item gen C< {CODE} GLOBSTRING >
|
2901
|
|
|
|
|
|
|
|
2902
|
|
|
|
|
|
|
C< gen > is the equivalent of C< map > for generators. it returns a generator
|
2903
|
|
|
|
|
|
|
that will apply the C< CODE > block to its source when accessed. C< gen > takes
|
2904
|
|
|
|
|
|
|
a generator, array ref, glob-string, or suitable arguments for C< range > as its
|
2905
|
|
|
|
|
|
|
source. with no arguments, C< gen > uses the range C< 0 .. infinity >.
|
2906
|
|
|
|
|
|
|
|
2907
|
|
|
|
|
|
|
my @result = map {slow($_)} @source; # slow() called @source times
|
2908
|
|
|
|
|
|
|
my $result = gen {slow($_)} \@source; # slow() not called
|
2909
|
|
|
|
|
|
|
|
2910
|
|
|
|
|
|
|
my ($x, $y) = @$result[4, 7]; # slow() called twice
|
2911
|
|
|
|
|
|
|
|
2912
|
|
|
|
|
|
|
my $lazy = gen {slow($_)} range 1, 1_000_000_000;
|
2913
|
|
|
|
|
|
|
same: gen {slow($_)} 1, 1_000_000_000;
|
2914
|
|
|
|
|
|
|
|
2915
|
|
|
|
|
|
|
print $$lazy[1_000_000]; # slow() only called once
|
2916
|
|
|
|
|
|
|
|
2917
|
|
|
|
|
|
|
C< gen {...} list LIST > is a replacement for C< [ map {...} LIST ] >.
|
2918
|
|
|
|
|
|
|
|
2919
|
|
|
|
|
|
|
C< gen > provides the functionality of the identical C<< ->gen(...) >> and
|
2920
|
|
|
|
|
|
|
C<< ->map(...) >> methods.
|
2921
|
|
|
|
|
|
|
|
2922
|
|
|
|
|
|
|
note that while effort has gone into making generators as fast as possible there
|
2923
|
|
|
|
|
|
|
is overhead involved with lazy generation. simply replacing all calls to
|
2924
|
|
|
|
|
|
|
C< map > with C< gen > will almost certainly slow down your code. use these
|
2925
|
|
|
|
|
|
|
functions in situations where the time / memory required to completely generate
|
2926
|
|
|
|
|
|
|
the list is unacceptable.
|
2927
|
|
|
|
|
|
|
|
2928
|
|
|
|
|
|
|
C< gen > and other similarly argumented functions in this package can also
|
2929
|
|
|
|
|
|
|
accept a string suitable for the C<< >> syntax:
|
2930
|
|
|
|
|
|
|
|
2931
|
|
|
|
|
|
|
my $square_of_nats = gen {$_**2} '1..';
|
2932
|
|
|
|
|
|
|
my $square_of_fibs = gen {$_**2} '0, 1, *+*'; # no need for '...' with '*'
|
2933
|
|
|
|
|
|
|
|
2934
|
|
|
|
|
|
|
which is the same as the following if C< glob > is imported:
|
2935
|
|
|
|
|
|
|
|
2936
|
|
|
|
|
|
|
my $square_of_nats = gen {$_**2} <1..>;
|
2937
|
|
|
|
|
|
|
my $square_of_fibs = gen {$_**2} <0, 1, *+* ...>; # still need dots here
|
2938
|
|
|
|
|
|
|
|
2939
|
|
|
|
|
|
|
=cut
|
2940
|
|
|
|
|
|
|
|
2941
|
|
|
|
|
|
|
sub gen (&;$$$) {
|
2942
|
37
|
|
|
37
|
1
|
1358
|
tiegen Gen => shift, tied @{&dwim}
|
|
37
|
|
|
|
|
65
|
|
2943
|
|
|
|
|
|
|
}
|
2944
|
|
|
|
|
|
|
|
2945
|
|
|
|
|
|
|
my $canglob = qr/\.{2,3}|,.*\*/;
|
2946
|
0
|
0
|
|
0
|
0
|
0
|
sub canglob (;$) {(@_ ? $_[0] : $_) =~ $canglob}
|
2947
|
|
|
|
|
|
|
|
2948
|
|
|
|
|
|
|
sub dwim {
|
2949
|
46
|
100
|
|
46
|
1
|
112
|
@_ or @_ = (0 => 9**9**9);
|
2950
|
|
|
|
|
|
|
$#_ and &range
|
2951
|
46
|
0
|
66
|
|
|
483
|
or ref $_[0] and do {
|
|
|
100
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
2952
|
10
|
50
|
|
|
|
27
|
$_[0] = ${$_[0]}->() if ref $_[0] eq 'List::Gen::Thunk';
|
|
0
|
|
|
|
|
0
|
|
2953
|
10
|
50
|
0
|
|
|
23
|
isagen $_[0]
|
2954
|
|
|
|
|
|
|
or ref $_[0] eq 'ARRAY' and &makegen
|
2955
|
|
|
|
|
|
|
}
|
2956
|
|
|
|
|
|
|
or $_[0] and $_[0] =~ $canglob
|
2957
|
|
|
|
|
|
|
and isagen &glob($_[0] =~ /\.{2,3}/ ? $_[0] : "$_[0]...")
|
2958
|
|
|
|
|
|
|
or looks_like_number $_[0]
|
2959
|
|
|
|
|
|
|
and range int $_[0]
|
2960
|
|
|
|
|
|
|
or croak "invalid argument for generator: '$_[0]'"
|
2961
|
|
|
|
|
|
|
}
|
2962
|
|
|
|
|
|
|
generator Gen => sub {
|
2963
|
36
|
|
|
36
|
|
75
|
my ($class, $code, $source) = @_;
|
2964
|
36
|
|
|
|
|
232
|
my ($fetch, $fsize) = $source->closures;
|
2965
|
|
|
|
|
|
|
curse {
|
2966
|
40
|
|
|
40
|
|
102
|
FETCH => do {
|
2967
|
36
|
50
|
|
|
|
447
|
if ($source->can('range')) {
|
|
|
0
|
|
|
|
|
|
2968
|
36
|
|
|
|
|
84
|
my ($low, $step, $size) = $source->range;
|
2969
|
|
|
|
|
|
|
sub {
|
2970
|
278
|
50
|
|
278
|
|
704
|
local *_ = $_[1] < $size
|
2971
|
|
|
|
|
|
|
? \($low + $step * $_[1])
|
2972
|
|
|
|
|
|
|
: &$fetch;
|
2973
|
278
|
|
|
|
|
502
|
$code->()
|
2974
|
|
|
|
|
|
|
}
|
2975
|
36
|
|
|
|
|
277
|
}
|
2976
|
|
|
|
|
|
|
elsif ($source->can('capture')) {
|
2977
|
0
|
|
|
|
|
0
|
my $cap = $source->capture;
|
2978
|
0
|
|
|
0
|
|
0
|
sub {local *_ = \$$cap[$_[1]]; $code->()}
|
|
0
|
|
|
|
|
0
|
|
2979
|
0
|
|
|
|
|
0
|
}
|
2980
|
|
|
|
|
|
|
else {
|
2981
|
0
|
|
|
0
|
|
0
|
sub {local *_ = \$fetch->(undef, $_[1]); $code->()}
|
|
0
|
|
|
|
|
0
|
|
2982
|
0
|
|
|
|
|
0
|
}
|
2983
|
|
|
|
|
|
|
},
|
2984
|
|
|
|
|
|
|
fsize => $fsize,
|
2985
|
|
|
|
|
|
|
source => sub {$source},
|
2986
|
36
|
|
|
|
|
54
|
} => $class
|
2987
|
|
|
|
|
|
|
};
|
2988
|
|
|
|
|
|
|
|
2989
|
|
|
|
|
|
|
|
2990
|
|
|
|
|
|
|
=item makegen C< ARRAY >
|
2991
|
|
|
|
|
|
|
|
2992
|
|
|
|
|
|
|
C< makegen > converts an array to a generator. this is normally not needed as
|
2993
|
|
|
|
|
|
|
most generator functions will call it automatically if passed an array reference
|
2994
|
|
|
|
|
|
|
|
2995
|
|
|
|
|
|
|
C< makegen > considers the length of C< ARRAY > to be immutable. changing the
|
2996
|
|
|
|
|
|
|
length of an array after passing it to C< makegen > (or to C< gen > and like
|
2997
|
|
|
|
|
|
|
argumented subroutines) will result in undefined behavior. this is done for
|
2998
|
|
|
|
|
|
|
performance reasons. if you need a length mutable array, use the C< array >
|
2999
|
|
|
|
|
|
|
function. changing the value of a cell in the array is fine, and will be
|
3000
|
|
|
|
|
|
|
picked up by a generator (of course if the generator uses a cache, the value
|
3001
|
|
|
|
|
|
|
won't change after being cached).
|
3002
|
|
|
|
|
|
|
|
3003
|
|
|
|
|
|
|
you can assign to the generator returned by C< makegen >, provided the
|
3004
|
|
|
|
|
|
|
assignment does not lengthen the array.
|
3005
|
|
|
|
|
|
|
|
3006
|
|
|
|
|
|
|
my $gen = makegen @array;
|
3007
|
|
|
|
|
|
|
|
3008
|
|
|
|
|
|
|
$$gen[3] = 'some value'; # now $array[3] is 'some value'
|
3009
|
|
|
|
|
|
|
|
3010
|
|
|
|
|
|
|
=cut
|
3011
|
|
|
|
|
|
|
|
3012
|
|
|
|
|
|
|
sub makegen (\@) {
|
3013
|
11
|
|
|
11
|
1
|
31
|
tiegen Capture => @_
|
3014
|
|
|
|
|
|
|
}
|
3015
|
|
|
|
|
|
|
generator Capture => sub {
|
3016
|
11
|
|
|
11
|
|
19
|
my ($class, $source) = @_;
|
3017
|
11
|
|
|
|
|
16
|
my $size = @$source;
|
3018
|
73
|
|
|
73
|
|
132
|
curse {
|
3019
|
|
|
|
|
|
|
FETCH => sub {$$source[ $_[1] ]},
|
3020
|
27
|
|
|
27
|
|
58
|
fsize => sub {$size},
|
3021
|
0
|
|
|
0
|
|
0
|
capture => sub {$source}
|
3022
|
11
|
|
|
|
|
117
|
} => $class
|
3023
|
|
|
|
|
|
|
},
|
3024
|
|
|
|
|
|
|
STORE => sub {
|
3025
|
0
|
0
|
|
0
|
|
0
|
$_[1] < $_[0]->fsize
|
3026
|
|
|
|
|
|
|
? $_[0]->capture->[$_[1]] = $_[2]
|
3027
|
|
|
|
|
|
|
: croak "index $_[1] out of range 0 .. ".($_[0]->size - 1)
|
3028
|
|
|
|
|
|
|
};
|
3029
|
|
|
|
|
|
|
|
3030
|
|
|
|
|
|
|
|
3031
|
|
|
|
|
|
|
=item list C< LIST >
|
3032
|
|
|
|
|
|
|
|
3033
|
|
|
|
|
|
|
C< list > converts a list to a generator. it is a thin wrapper around
|
3034
|
|
|
|
|
|
|
C< makegen > that simply passes its C< @_ > to C< makegen >. that means the
|
3035
|
|
|
|
|
|
|
values in the returned generator are aliases to C's arguments.
|
3036
|
|
|
|
|
|
|
|
3037
|
|
|
|
|
|
|
list(2, 5, 8, 11)->map('*2')->say; # '4 10 16 22'
|
3038
|
|
|
|
|
|
|
|
3039
|
|
|
|
|
|
|
is the same as writing:
|
3040
|
|
|
|
|
|
|
|
3041
|
|
|
|
|
|
|
(gen {$_*2} cap 2, 5, 8, 11)->say;
|
3042
|
|
|
|
|
|
|
|
3043
|
|
|
|
|
|
|
in the above example, C< list > can be used in place of C< cap > and has exactly
|
3044
|
|
|
|
|
|
|
the same functionality:
|
3045
|
|
|
|
|
|
|
|
3046
|
|
|
|
|
|
|
(gen {$_*2} list 2, 5, 8, 11)->say;
|
3047
|
|
|
|
|
|
|
|
3048
|
|
|
|
|
|
|
=cut
|
3049
|
|
|
|
|
|
|
|
3050
|
0
|
|
|
0
|
1
|
0
|
sub list {makegen @_}
|
3051
|
|
|
|
|
|
|
|
3052
|
|
|
|
|
|
|
|
3053
|
|
|
|
|
|
|
=item array C< [ARRAY] >
|
3054
|
|
|
|
|
|
|
|
3055
|
|
|
|
|
|
|
C< array > is similar to C< makegen > except the array is considered a mutable
|
3056
|
|
|
|
|
|
|
data source. because of this, certain optimizations are not possible, and the
|
3057
|
|
|
|
|
|
|
generator returned will be a bit slower than the one created by C< makegen > in
|
3058
|
|
|
|
|
|
|
most conditions (increasing as generator functions are stacked).
|
3059
|
|
|
|
|
|
|
|
3060
|
|
|
|
|
|
|
it is ok to modify C< ARRAY > after creating the generator. it is also possible
|
3061
|
|
|
|
|
|
|
to use normal array modification functions such as C< push >, C< pop >,
|
3062
|
|
|
|
|
|
|
C< shift >, C< unshift >, and C< splice > on the generator. all changes will
|
3063
|
|
|
|
|
|
|
translate back to the source array.
|
3064
|
|
|
|
|
|
|
|
3065
|
|
|
|
|
|
|
you can think of C< array > as converting an array to an array reference that
|
3066
|
|
|
|
|
|
|
is also a generator.
|
3067
|
|
|
|
|
|
|
|
3068
|
|
|
|
|
|
|
my @src = 1..5;
|
3069
|
|
|
|
|
|
|
my $gen = array @src;
|
3070
|
|
|
|
|
|
|
|
3071
|
|
|
|
|
|
|
push @$gen, 6;
|
3072
|
|
|
|
|
|
|
|
3073
|
|
|
|
|
|
|
$$gen[6] = 7; # assignment is ok too
|
3074
|
|
|
|
|
|
|
|
3075
|
|
|
|
|
|
|
say $gen->size; # 7
|
3076
|
|
|
|
|
|
|
say shift @$gen; # 1
|
3077
|
|
|
|
|
|
|
say $gen->size; # 6
|
3078
|
|
|
|
|
|
|
say $gen->str; # 2 3 4 5 6 7
|
3079
|
|
|
|
|
|
|
say "@src"; # 2 3 4 5 6 7
|
3080
|
|
|
|
|
|
|
|
3081
|
|
|
|
|
|
|
my $array = array; # no args creates an empty array
|
3082
|
|
|
|
|
|
|
|
3083
|
|
|
|
|
|
|
=cut
|
3084
|
|
|
|
|
|
|
|
3085
|
0
|
0
|
|
0
|
1
|
0
|
sub array (;\@) {tiegen Array => @_ ? @_ : []}
|
3086
|
|
|
|
|
|
|
mutable_gen Array => sub {
|
3087
|
0
|
|
|
0
|
|
0
|
my ($class, $src) = @_;
|
3088
|
0
|
|
|
0
|
|
0
|
curse {
|
3089
|
|
|
|
|
|
|
FETCH => sub {$$src[$_[1]]},
|
3090
|
0
|
|
|
0
|
|
0
|
STORE => sub {$$src[$_[1]] = $_[2]},
|
3091
|
0
|
|
|
0
|
|
0
|
fsize => sub {scalar @$src},
|
3092
|
0
|
|
|
0
|
|
0
|
capture => sub {$src},
|
3093
|
0
|
|
|
|
|
0
|
} => $class
|
3094
|
|
|
|
|
|
|
},
|
3095
|
0
|
|
|
0
|
|
0
|
PUSH => sub {push @{$_[0]->capture}, @_[1..$#_]},
|
|
0
|
|
|
|
|
0
|
|
3096
|
0
|
|
|
0
|
|
0
|
UNSHIFT => sub {unshift @{$_[0]->capture}, @_[1..$#_]},
|
|
0
|
|
|
|
|
0
|
|
3097
|
0
|
|
|
0
|
|
0
|
POP => sub {pop @{$_[0]->capture}},
|
|
0
|
|
|
|
|
0
|
|
3098
|
0
|
|
|
0
|
|
0
|
SHIFT => sub {shift @{$_[0]->capture}},
|
|
0
|
|
|
|
|
0
|
|
3099
|
|
|
|
|
|
|
SPLICE => sub {
|
3100
|
0
|
|
|
0
|
|
0
|
my $cap = shift->capture;
|
3101
|
0
|
0
|
|
|
|
0
|
@_ == 0 ? splice @$cap :
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3102
|
|
|
|
|
|
|
@_ == 1 ? splice @$cap, $_[0] :
|
3103
|
|
|
|
|
|
|
@_ == 2 ? splice @$cap, $_[0], $_[1] :
|
3104
|
|
|
|
|
|
|
splice @$cap, $_[0], $_[1], @_[2..$#_]
|
3105
|
|
|
|
|
|
|
},
|
3106
|
0
|
|
|
0
|
|
0
|
DELETE => sub {delete $_[0]->capture->[$_[1]]},
|
3107
|
0
|
|
|
0
|
|
0
|
STORESIZE => sub {$#{$_[0]->capture} = $_[1] - 1},
|
|
0
|
|
|
|
|
0
|
|
3108
|
0
|
|
|
0
|
|
0
|
CLEAR => sub { @{$_[0]->capture} = ()};
|
|
0
|
|
|
|
|
0
|
|
3109
|
|
|
|
|
|
|
|
3110
|
|
|
|
|
|
|
|
3111
|
|
|
|
|
|
|
=item file C<< FILE [OPTIONS] >>
|
3112
|
|
|
|
|
|
|
|
3113
|
|
|
|
|
|
|
C< file > creates an C< array > generator from a file name or file handle
|
3114
|
|
|
|
|
|
|
using C< Tie::File >. C< OPTIONS > are passed to C< Tie::File >
|
3115
|
|
|
|
|
|
|
|
3116
|
|
|
|
|
|
|
my $gen = file 'some_file.txt';
|
3117
|
|
|
|
|
|
|
|
3118
|
|
|
|
|
|
|
my $uc_file = $gen->map('uc');
|
3119
|
|
|
|
|
|
|
|
3120
|
|
|
|
|
|
|
my $with_line_numbers = <1..>->zip('"$a: $b"', $gen);
|
3121
|
|
|
|
|
|
|
|
3122
|
|
|
|
|
|
|
=cut
|
3123
|
|
|
|
|
|
|
|
3124
|
|
|
|
|
|
|
sub file {
|
3125
|
0
|
|
|
0
|
1
|
0
|
my $file = shift;
|
3126
|
0
|
|
|
|
|
0
|
my %args = (recsep => $/, @_);
|
3127
|
0
|
|
|
|
|
0
|
require Tie::File;
|
3128
|
0
|
0
|
|
|
|
0
|
tie my @array, 'Tie::File', $file, %args or die $!;
|
3129
|
0
|
|
|
|
|
0
|
array @array
|
3130
|
|
|
|
|
|
|
}
|
3131
|
|
|
|
|
|
|
|
3132
|
|
|
|
|
|
|
|
3133
|
|
|
|
|
|
|
=item repeat C<< SCALAR [SIZE] >>
|
3134
|
|
|
|
|
|
|
|
3135
|
|
|
|
|
|
|
an infinite generator that returns C for every position. it is
|
3136
|
|
|
|
|
|
|
equivalent to C< gen {SCALAR} > but a little faster.
|
3137
|
|
|
|
|
|
|
|
3138
|
|
|
|
|
|
|
=cut
|
3139
|
|
|
|
|
|
|
|
3140
|
|
|
|
|
|
|
sub repeat {
|
3141
|
5
|
|
|
5
|
1
|
15
|
tiegen Repeat => @_
|
3142
|
|
|
|
|
|
|
}
|
3143
|
|
|
|
|
|
|
generator Repeat => sub {
|
3144
|
5
|
|
|
5
|
|
12
|
my ($class, $x, $size) = (@_, 9**9**9);
|
3145
|
0
|
|
|
0
|
|
0
|
curse {
|
3146
|
|
|
|
|
|
|
FETCH => sub () {$x},
|
3147
|
0
|
|
|
0
|
|
0
|
fsize => sub () {$size},
|
3148
|
5
|
|
|
|
|
74
|
} => $class
|
3149
|
|
|
|
|
|
|
};
|
3150
|
|
|
|
|
|
|
|
3151
|
|
|
|
|
|
|
|
3152
|
|
|
|
|
|
|
=item iterate C< {CODE} [LIMIT|GENERATOR] >
|
3153
|
|
|
|
|
|
|
|
3154
|
|
|
|
|
|
|
C< iterate > returns a generator that is created iteratively. C< iterate >
|
3155
|
|
|
|
|
|
|
implicitly caches its values, this allows random access normally not
|
3156
|
|
|
|
|
|
|
possible with an iterative algorithm. LIMIT is an optional number of times to
|
3157
|
|
|
|
|
|
|
iterate. normally, inside the CODE block, C<$_> is set to the current iteration
|
3158
|
|
|
|
|
|
|
number. if passed a generator instead of a limit, C<$_> will be set to
|
3159
|
|
|
|
|
|
|
sequential values from that generator.
|
3160
|
|
|
|
|
|
|
|
3161
|
|
|
|
|
|
|
my $fib = do {
|
3162
|
|
|
|
|
|
|
my ($x, $y) = (0, 1);
|
3163
|
|
|
|
|
|
|
iterate {
|
3164
|
|
|
|
|
|
|
my $return = $x;
|
3165
|
|
|
|
|
|
|
($x, $y) = ($y, $x + $y);
|
3166
|
|
|
|
|
|
|
$return
|
3167
|
|
|
|
|
|
|
}
|
3168
|
|
|
|
|
|
|
};
|
3169
|
|
|
|
|
|
|
|
3170
|
|
|
|
|
|
|
generators produced by C< iterate > have an extra method, C<< ->from(LIST) >>.
|
3171
|
|
|
|
|
|
|
the method must be called before values are accessed from the generator. the
|
3172
|
|
|
|
|
|
|
passed C< LIST > will be the first values returned by the generator. the method
|
3173
|
|
|
|
|
|
|
also changes the behavior of C< $_ > inside the block. C< $_ > will contain the
|
3174
|
|
|
|
|
|
|
previous value generated by the iterator. this allows C< iterate > to behave the
|
3175
|
|
|
|
|
|
|
same way as the like named haskell function.
|
3176
|
|
|
|
|
|
|
|
3177
|
|
|
|
|
|
|
haskell: take 10 (iterate (2*) 1)
|
3178
|
|
|
|
|
|
|
perl: iterate{2*$_}->from(1)->take(10)
|
3179
|
|
|
|
|
|
|
<1, 2 * * ... 10>
|
3180
|
|
|
|
|
|
|
<1,2**...10>
|
3181
|
|
|
|
|
|
|
|
3182
|
|
|
|
|
|
|
which all return C< [1, 2, 4, 8, 16, 32, 64, 128, 256, 512] >
|
3183
|
|
|
|
|
|
|
|
3184
|
|
|
|
|
|
|
=cut
|
3185
|
|
|
|
|
|
|
|
3186
|
|
|
|
|
|
|
sub iterate (&;$) {
|
3187
|
7
|
50
|
|
7
|
1
|
15
|
goto &iterate_stream if $STREAM;
|
3188
|
7
|
|
|
|
|
14
|
my ($code, $size) = (@_, 9**9**9);
|
3189
|
7
|
50
|
33
|
|
|
11
|
if (isagen($size) and $size->is_mutable) {
|
3190
|
0
|
|
|
|
|
0
|
goto &iterate_multi
|
3191
|
|
|
|
|
|
|
}
|
3192
|
7
|
|
|
|
|
18
|
tiegen Iterate => $code, $size
|
3193
|
|
|
|
|
|
|
}
|
3194
|
|
|
|
|
|
|
generator Iterate => sub {
|
3195
|
7
|
|
|
7
|
|
13
|
my ($class, $code, $size) = @_;
|
3196
|
7
|
|
|
|
|
10
|
my (@list, $from, $source);
|
3197
|
7
|
50
|
|
|
|
11
|
if (isagen($size)) {
|
3198
|
7
|
|
|
|
|
21
|
$source = tied(@$size)->can('FETCH');
|
3199
|
7
|
|
|
|
|
21
|
$size = $size->size;
|
3200
|
|
|
|
|
|
|
}
|
3201
|
|
|
|
|
|
|
curse {
|
3202
|
|
|
|
|
|
|
FETCH => sub {
|
3203
|
58
|
50
|
|
58
|
|
120
|
(my $i = $_[1]) >= $size
|
3204
|
0
|
|
|
|
|
0
|
and croak "index $_[1] out of bounds [0 .. @{[$size - 1]}]";
|
3205
|
58
|
50
|
|
|
|
109
|
if ($i > $#list) {
|
3206
|
58
|
|
|
|
|
97
|
for (@list .. $i) {
|
3207
|
58
|
|
|
|
|
54
|
$list[$_] = do {
|
3208
|
58
|
50
|
|
|
|
150
|
$from ? local *_ = $list[$_ - 1] :
|
|
|
50
|
|
|
|
|
|
3209
|
|
|
|
|
|
|
$source ? local *_ = \$source->(undef, $_) : ();
|
3210
|
58
|
|
|
|
|
88
|
\$code->()
|
3211
|
|
|
|
|
|
|
}
|
3212
|
|
|
|
|
|
|
}
|
3213
|
|
|
|
|
|
|
}
|
3214
|
58
|
|
|
|
|
80
|
${$list[$i]}
|
|
58
|
|
|
|
|
161
|
|
3215
|
|
|
|
|
|
|
},
|
3216
|
7
|
|
|
7
|
|
19
|
fsize => sub { $size},
|
3217
|
0
|
|
|
0
|
|
0
|
cached => sub {\@list},
|
3218
|
|
|
|
|
|
|
from => sub {
|
3219
|
0
|
0
|
0
|
0
|
|
0
|
return $from if @_ == 2 and ref $_[1] eq 'List::Gen::From_Check';
|
3220
|
|
|
|
|
|
|
|
3221
|
0
|
0
|
0
|
|
|
0
|
croak "can not call ->from on started iterator"
|
3222
|
|
|
|
|
|
|
if @list or $from++;
|
3223
|
0
|
0
|
|
|
|
0
|
push @list, @_ > 1 ? \@_[1..$#_] : \List::Gen::Iterate::Default->new;
|
3224
|
|
|
|
|
|
|
},
|
3225
|
7
|
|
|
|
|
93
|
} => $class
|
3226
|
|
|
|
|
|
|
},
|
3227
|
0
|
|
|
0
|
|
0
|
load => sub {push @{$_[0]->cached}, \@_[1..$#_]},
|
|
0
|
|
|
|
|
0
|
|
3228
|
0
|
|
|
0
|
|
0
|
purge => sub {croak 'can not purge iterative generator'};
|
3229
|
|
|
|
|
|
|
|
3230
|
|
|
|
|
|
|
{package
|
3231
|
|
|
|
|
|
|
List::Gen::Iterate::Default;
|
3232
|
0
|
|
|
0
|
|
0
|
sub new {bless []}
|
3233
|
0
|
|
|
|
|
0
|
use overload fallback => 1,
|
3234
|
0
|
0
|
|
0
|
|
0
|
'""' => sub :lvalue {@{$_[0]} ? $_[0][0] : ($_[0][0] = '')},
|
3235
|
10
|
0
|
|
10
|
|
123
|
'0+' => sub :lvalue {@{$_[0]} ? $_[0][0] : ($_[0][0] = 0)};
|
|
10
|
|
|
0
|
|
20
|
|
|
10
|
|
|
|
|
164
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3236
|
|
|
|
|
|
|
}
|
3237
|
|
|
|
|
|
|
|
3238
|
|
|
|
|
|
|
|
3239
|
|
|
|
|
|
|
=item iterate_stream C< {CODE} [LIMIT] >
|
3240
|
|
|
|
|
|
|
|
3241
|
|
|
|
|
|
|
C< iterate_stream > is a version of C< iterate > that does not cache the
|
3242
|
|
|
|
|
|
|
generated values. because of this, access to the returned generator must be
|
3243
|
|
|
|
|
|
|
monotonically increasing (such as repeated calls to C<< $gen->next >>).
|
3244
|
|
|
|
|
|
|
|
3245
|
|
|
|
|
|
|
=cut
|
3246
|
|
|
|
|
|
|
|
3247
|
|
|
|
|
|
|
sub iterate_stream (&;$) {
|
3248
|
0
|
|
|
0
|
1
|
0
|
my ($code, $size) = (@_, 9**9**9);
|
3249
|
0
|
0
|
0
|
|
|
0
|
if (isagen($size) and $size->is_mutable) {
|
3250
|
0
|
|
|
|
|
0
|
goto &iterate_multi_stream
|
3251
|
|
|
|
|
|
|
}
|
3252
|
0
|
|
|
|
|
0
|
tiegen Iterate_Stream => $code, $size
|
3253
|
|
|
|
|
|
|
}
|
3254
|
10
|
|
|
10
|
|
11492
|
BEGIN {*iterateS = *iterate_stream}
|
3255
|
|
|
|
|
|
|
generator Iterate_Stream => sub {
|
3256
|
0
|
|
|
0
|
|
0
|
my ($class, $code, $size) = @_;
|
3257
|
0
|
|
|
|
|
0
|
my ($last, $from, $source);
|
3258
|
0
|
|
|
|
|
0
|
my $pos = 0;
|
3259
|
0
|
0
|
|
|
|
0
|
if (isagen($size)) {
|
3260
|
0
|
|
|
|
|
0
|
$source = tied(@$size)->can('FETCH');
|
3261
|
0
|
|
|
|
|
0
|
$size = $size->size;
|
3262
|
|
|
|
|
|
|
}
|
3263
|
|
|
|
|
|
|
curse {
|
3264
|
|
|
|
|
|
|
FETCH => sub {
|
3265
|
0
|
0
|
|
0
|
|
0
|
(my $i = $_[1]) >= $size
|
3266
|
0
|
|
|
|
|
0
|
and croak "index $_[1] out of bounds [0 .. @{[$size - 1]}]";
|
3267
|
0
|
0
|
|
|
|
0
|
$i < $pos and croak "non-monotone access of stream iterator, idx($i) < pos($pos)";
|
3268
|
|
|
|
|
|
|
|
3269
|
0
|
0
|
0
|
|
|
0
|
$pos++, return $$last if $i == 0 and $from;
|
3270
|
0
|
|
|
|
|
0
|
local *_;
|
3271
|
0
|
|
0
|
|
|
0
|
while ($i >= $pos and $pos < $size) {
|
3272
|
0
|
0
|
|
|
|
0
|
*_ = $from ? $last
|
|
|
0
|
|
|
|
|
|
3273
|
|
|
|
|
|
|
: $source ? \$source->(undef, $pos)
|
3274
|
|
|
|
|
|
|
: \(0+$pos);
|
3275
|
0
|
|
|
|
|
0
|
$last = \$code->();
|
3276
|
0
|
|
|
|
|
0
|
$pos++;
|
3277
|
|
|
|
|
|
|
}
|
3278
|
0
|
0
|
|
|
|
0
|
$pos < $size ? $$last : ()
|
3279
|
|
|
|
|
|
|
},
|
3280
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
3281
|
0
|
|
|
0
|
|
0
|
index => sub {\$pos},
|
3282
|
|
|
|
|
|
|
from => sub {
|
3283
|
0
|
0
|
0
|
0
|
|
0
|
croak "can not call ->from on started iterator"
|
3284
|
|
|
|
|
|
|
if $pos or $from++;
|
3285
|
0
|
0
|
|
|
|
0
|
$last = @_ > 1 ? \$_[1] : \List::Gen::Iterate::Default->new;
|
3286
|
|
|
|
|
|
|
},
|
3287
|
0
|
|
|
|
|
0
|
} => $class
|
3288
|
|
|
|
|
|
|
},
|
3289
|
0
|
|
|
0
|
|
0
|
purge => sub {croak 'can not purge iterative generator'};
|
3290
|
|
|
|
|
|
|
|
3291
|
|
|
|
|
|
|
|
3292
|
|
|
|
|
|
|
=item iterate_multi C< {CODE} [LIMIT] >
|
3293
|
|
|
|
|
|
|
|
3294
|
|
|
|
|
|
|
the same as C, except CODE can return a list of any size. inside CODE,
|
3295
|
|
|
|
|
|
|
C<$_> is set to the position in the returned generator where the block's
|
3296
|
|
|
|
|
|
|
returned list will be placed.
|
3297
|
|
|
|
|
|
|
|
3298
|
|
|
|
|
|
|
the returned generator from C< iterate_multi > can be modified with C,
|
3299
|
|
|
|
|
|
|
C, C, C, and C like a normal array. it is up to
|
3300
|
|
|
|
|
|
|
you to ensure that the iterative algorithm will still work after modifying the
|
3301
|
|
|
|
|
|
|
array.
|
3302
|
|
|
|
|
|
|
|
3303
|
|
|
|
|
|
|
the C<< ->from(...) >> method can be called on the returned generator. see
|
3304
|
|
|
|
|
|
|
C< iterate > for the rules and effects of this.
|
3305
|
|
|
|
|
|
|
|
3306
|
|
|
|
|
|
|
=cut
|
3307
|
|
|
|
|
|
|
|
3308
|
|
|
|
|
|
|
sub iterate_multi (&;$) {
|
3309
|
2
|
50
|
|
2
|
1
|
7
|
goto &iterate_multi_stream if $STREAM;
|
3310
|
2
|
|
|
|
|
7
|
tiegen Iterate_Multi => @_, 9**9**9
|
3311
|
10
|
|
|
10
|
|
16660
|
} BEGIN {*iterateM = *iterate_multi}
|
3312
|
|
|
|
|
|
|
mutable_gen Iterate_Multi => sub {
|
3313
|
2
|
|
|
2
|
|
3
|
my ($class, $code, $size) = @_;
|
3314
|
2
|
|
|
0
|
|
8
|
my ($iter, $when_done ) = (0, sub {});
|
|
0
|
|
|
|
|
0
|
|
3315
|
2
|
|
|
|
|
4
|
my ($from, @list, @tails, $source, $mutable);
|
3316
|
2
|
50
|
|
|
|
6
|
if (isagen $size) {
|
3317
|
0
|
|
|
|
|
0
|
my $src = tied @$size;
|
3318
|
0
|
|
|
|
|
0
|
$source = $src->can('FETCH');
|
3319
|
0
|
|
|
|
|
0
|
$size = $src->fsize;
|
3320
|
0
|
|
|
|
|
0
|
$mutable = $src->mutable;
|
3321
|
0
|
0
|
|
|
|
0
|
$src->tail_size($size) if $mutable;
|
3322
|
|
|
|
|
|
|
}
|
3323
|
|
|
|
|
|
|
curse {
|
3324
|
|
|
|
|
|
|
FETCH => sub {
|
3325
|
58
|
|
|
58
|
|
94
|
my $i = $_[1];
|
3326
|
58
|
|
|
|
|
127
|
while ($i > $#list) {
|
3327
|
22
|
50
|
|
|
|
50
|
$iter++ >= $size
|
3328
|
|
|
|
|
|
|
and croak "too many iterations requested: ".
|
3329
|
0
|
|
|
|
|
0
|
"$iter. index $i out of bounds [0 .. @{[$size - 1]}]";
|
3330
|
22
|
50
|
|
|
|
93
|
local *_ = $from ? $list[-1] :
|
|
|
50
|
|
|
|
|
|
3331
|
|
|
|
|
|
|
$source ? \$source->(undef, scalar @list) :
|
3332
|
|
|
|
|
|
|
\scalar @list;
|
3333
|
22
|
50
|
|
|
|
56
|
eval {push @list, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} $code->(); 1}
|
|
22
|
|
|
|
|
66
|
|
|
22
|
|
|
|
|
81
|
|
3334
|
22
|
50
|
0
|
|
|
32
|
or catch_done and do {
|
3335
|
0
|
0
|
|
|
|
0
|
if (ref $@) {
|
3336
|
0
|
0
|
|
|
|
0
|
push @list, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} @{$@};
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3337
|
0
|
|
|
|
|
0
|
$size = @list;
|
3338
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3339
|
0
|
|
|
|
|
0
|
$when_done->();
|
3340
|
0
|
0
|
|
|
|
0
|
return ${$list[$i < $#list ? $i : $#list]};
|
|
0
|
|
|
|
|
0
|
|
3341
|
|
|
|
|
|
|
} else {
|
3342
|
0
|
|
|
|
|
0
|
$iter--;
|
3343
|
0
|
|
|
|
|
0
|
$size = @list;
|
3344
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3345
|
0
|
|
|
|
|
0
|
$when_done->();
|
3346
|
|
|
|
|
|
|
return
|
3347
|
0
|
|
|
|
|
0
|
}
|
3348
|
|
|
|
|
|
|
}
|
3349
|
|
|
|
|
|
|
}
|
3350
|
58
|
50
|
|
|
|
156
|
if ($size < @list) {
|
|
|
50
|
|
|
|
|
|
3351
|
0
|
|
|
|
|
0
|
$size = @list;
|
3352
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3353
|
|
|
|
|
|
|
}
|
3354
|
|
|
|
|
|
|
elsif ($mutable) {
|
3355
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3356
|
|
|
|
|
|
|
}
|
3357
|
58
|
|
|
|
|
63
|
${$list[$i]}
|
|
58
|
|
|
|
|
567
|
|
3358
|
|
|
|
|
|
|
},
|
3359
|
2
|
|
|
2
|
|
5
|
fsize => sub {$size},
|
3360
|
0
|
|
|
0
|
|
0
|
cached => sub {\@list},
|
3361
|
|
|
|
|
|
|
set_size => sub {
|
3362
|
0
|
|
|
0
|
|
0
|
$size = int $_[1];
|
3363
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3364
|
0
|
0
|
|
|
|
0
|
$when_done->() if $size == @list
|
3365
|
|
|
|
|
|
|
},
|
3366
|
|
|
|
|
|
|
_resize => sub {
|
3367
|
0
|
0
|
|
0
|
|
0
|
$size += $_[1] if $size < 9**9**9;
|
3368
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3369
|
0
|
|
|
|
|
0
|
$iter += $_[1];
|
3370
|
|
|
|
|
|
|
},
|
3371
|
0
|
|
|
0
|
|
0
|
_when_done => sub :lvalue {$when_done},
|
3372
|
|
|
|
|
|
|
from => sub {
|
3373
|
0
|
0
|
0
|
0
|
|
0
|
croak "can not call ->from on started iterator"
|
3374
|
|
|
|
|
|
|
if @list or $from++;
|
3375
|
0
|
0
|
|
|
|
0
|
push @list, @_ > 1 ? \@_[1..$#_] : \List::Gen::Iterate::Default->new;
|
3376
|
|
|
|
|
|
|
},
|
3377
|
|
|
|
|
|
|
tail_size => sub {
|
3378
|
2
|
|
|
2
|
|
7
|
push @tails, \$_[1]; weaken $tails[-1];
|
|
2
|
|
|
|
|
9
|
|
3379
|
|
|
|
|
|
|
},
|
3380
|
2
|
|
|
|
|
54
|
} => $class
|
3381
|
|
|
|
|
|
|
},
|
3382
|
0
|
|
|
0
|
|
0
|
purge => sub {Carp::croak 'can not purge iterative generator'},
|
3383
|
0
|
|
|
0
|
|
0
|
load => sub {push @{$_[0]->cached}, \@_[1..$#_]},
|
|
0
|
|
|
|
|
0
|
|
3384
|
|
|
|
|
|
|
PUSH => sub {
|
3385
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
3386
|
0
|
|
|
|
|
0
|
$self->_resize(0+@_);
|
3387
|
0
|
|
|
|
|
0
|
push @{$self->cached}, \(@_)
|
|
0
|
|
|
|
|
0
|
|
3388
|
|
|
|
|
|
|
},
|
3389
|
|
|
|
|
|
|
UNSHIFT => sub {
|
3390
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
3391
|
0
|
|
|
|
|
0
|
$self->_resize(0+@_);
|
3392
|
0
|
|
|
|
|
0
|
unshift @{$self->cached}, \(@_)
|
|
0
|
|
|
|
|
0
|
|
3393
|
|
|
|
|
|
|
},
|
3394
|
|
|
|
|
|
|
POP => sub {
|
3395
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
3396
|
0
|
0
|
|
|
|
0
|
return unless $self->fsize > 0;
|
3397
|
0
|
|
|
|
|
0
|
$self->_resize(-1);
|
3398
|
0
|
|
|
|
|
0
|
${pop @{$self->cached}}
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3399
|
|
|
|
|
|
|
},
|
3400
|
|
|
|
|
|
|
SHIFT => sub {
|
3401
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
3402
|
0
|
0
|
|
|
|
0
|
return unless $self->fsize > 0;
|
3403
|
0
|
|
|
|
|
0
|
$self->_resize(-1);
|
3404
|
0
|
|
|
|
|
0
|
${shift @{$self->cached}}
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3405
|
|
|
|
|
|
|
},
|
3406
|
|
|
|
|
|
|
SPLICE => sub {
|
3407
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
3408
|
0
|
|
|
|
|
0
|
my $list = $self->cached;
|
3409
|
0
|
|
|
|
|
0
|
my $size = $self->fsize;
|
3410
|
0
|
0
|
|
|
|
0
|
my @ret =
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3411
|
|
|
|
|
|
|
@_ == 0 ? splice @$list :
|
3412
|
|
|
|
|
|
|
@_ == 1 ? splice @$list, shift :
|
3413
|
|
|
|
|
|
|
@_ == 2 ? splice @$list, shift, shift :
|
3414
|
|
|
|
|
|
|
splice @$list, shift, shift, \(@_) ;
|
3415
|
0
|
|
|
|
|
0
|
$self->_resize(@$list - $size);
|
3416
|
0
|
|
|
|
|
0
|
map {$$_} @ret
|
|
0
|
|
|
|
|
0
|
|
3417
|
|
|
|
|
|
|
};
|
3418
|
|
|
|
|
|
|
|
3419
|
|
|
|
|
|
|
|
3420
|
|
|
|
|
|
|
=item iterate_multi_stream C< {CODE} [LIMIT] >
|
3421
|
|
|
|
|
|
|
|
3422
|
|
|
|
|
|
|
C< iterate_multi_stream > is a version of C< iterate_multi > that does not cache
|
3423
|
|
|
|
|
|
|
the generated values. because of this, access to the returned generator must be
|
3424
|
|
|
|
|
|
|
monotonically increasing (such as repeated calls to C<< $gen->next >>).
|
3425
|
|
|
|
|
|
|
|
3426
|
|
|
|
|
|
|
keyword modification of a stream iterator (with C, C, ...) is not
|
3427
|
|
|
|
|
|
|
supported.
|
3428
|
|
|
|
|
|
|
|
3429
|
|
|
|
|
|
|
=cut
|
3430
|
|
|
|
|
|
|
|
3431
|
|
|
|
|
|
|
sub iterate_multi_stream (&;$) {
|
3432
|
0
|
|
|
0
|
1
|
0
|
tiegen Iterate_Multi_Stream => @_, 9**9**9
|
3433
|
|
|
|
|
|
|
}
|
3434
|
10
|
|
|
10
|
|
11856
|
BEGIN {*iterateMS = *iterate_multi_stream}
|
3435
|
|
|
|
|
|
|
mutable_gen Iterate_Multi_Stream => sub {
|
3436
|
0
|
|
|
0
|
|
0
|
my ($class, $code, $size) = @_;
|
3437
|
0
|
|
|
0
|
|
0
|
my ($pos, $when_done ) = (0, sub {});
|
|
0
|
|
|
|
|
0
|
|
3438
|
0
|
|
|
|
|
0
|
my ($from, @last, @tails, $source, $mutable);
|
3439
|
0
|
0
|
|
|
|
0
|
if (isagen $size) {
|
3440
|
0
|
|
|
|
|
0
|
$source = tied(@$size)->can('FETCH');
|
3441
|
0
|
|
|
|
|
0
|
$mutable = $size->is_mutable;
|
3442
|
0
|
|
|
|
|
0
|
$size = $size->size;
|
3443
|
|
|
|
|
|
|
}
|
3444
|
|
|
|
|
|
|
curse {
|
3445
|
|
|
|
|
|
|
FETCH => sub {
|
3446
|
0
|
|
|
0
|
|
0
|
my $i = $_[1];
|
3447
|
0
|
0
|
|
|
|
0
|
$i < $pos and croak "non-monotone access of iterate multi stream, idx($i) < pos($pos)";
|
3448
|
0
|
|
|
|
|
0
|
while ($i >= $pos) {
|
3449
|
0
|
0
|
|
|
|
0
|
$pos >= $size and croak "too many iterations requested: ".
|
3450
|
0
|
|
|
|
|
0
|
"$pos. index $i out of bounds [0 .. @{[$size - 1]}]";
|
3451
|
0
|
0
|
0
|
|
|
0
|
if ($i == $pos and @last) {
|
3452
|
0
|
|
|
|
|
0
|
$pos++;
|
3453
|
|
|
|
|
|
|
last
|
3454
|
0
|
|
|
|
|
0
|
}
|
3455
|
0
|
0
|
|
|
|
0
|
if (@last) {
|
3456
|
0
|
|
|
|
|
0
|
shift @last;
|
3457
|
0
|
|
|
|
|
0
|
$pos++;
|
3458
|
0
|
|
|
|
|
0
|
next;
|
3459
|
|
|
|
|
|
|
}
|
3460
|
0
|
0
|
|
|
|
0
|
local *_ = $from ? $from :
|
|
|
0
|
|
|
|
|
|
3461
|
|
|
|
|
|
|
$source ? \$source->(undef, $pos) :
|
3462
|
|
|
|
|
|
|
\$pos;
|
3463
|
0
|
0
|
|
|
|
0
|
eval {push @last, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} $code->(); 1}
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3464
|
0
|
0
|
0
|
|
|
0
|
or catch_done and do {
|
3465
|
0
|
0
|
|
|
|
0
|
if (ref $@) {
|
3466
|
0
|
0
|
|
|
|
0
|
push @last, map {ref eq 'List::Gen::Thunk' ? \$$_->() : \$_} @{$@};
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3467
|
0
|
|
|
|
|
0
|
$size = $pos;
|
3468
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3469
|
0
|
|
|
|
|
0
|
$when_done->();
|
3470
|
0
|
|
|
|
|
0
|
return ${shift @last};
|
|
0
|
|
|
|
|
0
|
|
3471
|
|
|
|
|
|
|
} else {
|
3472
|
0
|
|
|
|
|
0
|
$size = $pos;
|
3473
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3474
|
0
|
|
|
|
|
0
|
$when_done->();
|
3475
|
|
|
|
|
|
|
return
|
3476
|
0
|
|
|
|
|
0
|
}
|
3477
|
|
|
|
|
|
|
};
|
3478
|
0
|
0
|
|
|
|
0
|
$from = $last[-1] if $from;
|
3479
|
0
|
|
|
|
|
0
|
$pos++
|
3480
|
|
|
|
|
|
|
}
|
3481
|
0
|
0
|
|
|
|
0
|
if ($mutable) {
|
3482
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails
|
3483
|
|
|
|
|
|
|
}
|
3484
|
0
|
|
|
|
|
0
|
${shift @last};
|
|
0
|
|
|
|
|
0
|
|
3485
|
|
|
|
|
|
|
},
|
3486
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
3487
|
0
|
|
|
0
|
|
0
|
index => sub {\$pos},
|
3488
|
|
|
|
|
|
|
set_size => sub {
|
3489
|
0
|
|
|
0
|
|
0
|
$size = int $_[1];
|
3490
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
3491
|
0
|
|
|
|
|
0
|
$when_done->();
|
3492
|
|
|
|
|
|
|
},
|
3493
|
0
|
|
|
0
|
|
0
|
_when_done => sub :lvalue {$when_done},
|
3494
|
|
|
|
|
|
|
from => sub {
|
3495
|
0
|
0
|
0
|
0
|
|
0
|
croak "can not call ->from on started iterator"
|
3496
|
|
|
|
|
|
|
if @last or $from;
|
3497
|
0
|
0
|
|
|
|
0
|
push @last, @_ > 1 ? \@_[1..$#_] : \List::Gen::Iterate::Default->new;
|
3498
|
0
|
|
|
|
|
0
|
$from = $last[-1];
|
3499
|
|
|
|
|
|
|
},
|
3500
|
|
|
|
|
|
|
tail_size => sub {
|
3501
|
0
|
|
|
0
|
|
0
|
push @tails, \$_[1]; weaken $tails[-1];
|
|
0
|
|
|
|
|
0
|
|
3502
|
|
|
|
|
|
|
},
|
3503
|
0
|
|
|
|
|
0
|
} => $class
|
3504
|
|
|
|
|
|
|
},
|
3505
|
0
|
|
|
0
|
|
0
|
purge => sub {Carp::croak 'can not purge iterative generator'};
|
3506
|
|
|
|
|
|
|
|
3507
|
|
|
|
|
|
|
|
3508
|
|
|
|
|
|
|
=item gather C< {CODE} [LIMIT] >
|
3509
|
|
|
|
|
|
|
|
3510
|
|
|
|
|
|
|
C< gather > returns a generator that is created iteratively. rather than
|
3511
|
|
|
|
|
|
|
returning a value, you call C< take($return_value) > within the C< CODE >
|
3512
|
|
|
|
|
|
|
block. note that since perl5 does not have continuations, C< take(...) > does
|
3513
|
|
|
|
|
|
|
not pause execution of the block. rather, it stores the return value, the
|
3514
|
|
|
|
|
|
|
block finishes, and then the generator returns the stored value.
|
3515
|
|
|
|
|
|
|
|
3516
|
|
|
|
|
|
|
you can not import the C< take(...) > function from this module.
|
3517
|
|
|
|
|
|
|
C< take(...) > will be installed automatically into your namespace during
|
3518
|
|
|
|
|
|
|
the execution of the C< CODE > block. because of this, you must always call
|
3519
|
|
|
|
|
|
|
C< take(...) > with parenthesis. C< take > returns its argument unchanged.
|
3520
|
|
|
|
|
|
|
|
3521
|
|
|
|
|
|
|
gather implicitly caches its values, this allows random access normally not
|
3522
|
|
|
|
|
|
|
possible with an iterative algorithm. the algorithm in C< iterate > is a
|
3523
|
|
|
|
|
|
|
bit cleaner here, but C< gather > is slower than C< iterate >, so benchmark
|
3524
|
|
|
|
|
|
|
if speed is a concern
|
3525
|
|
|
|
|
|
|
|
3526
|
|
|
|
|
|
|
my $fib = do {
|
3527
|
|
|
|
|
|
|
my ($x, $y) = (0, 1);
|
3528
|
|
|
|
|
|
|
gather {
|
3529
|
|
|
|
|
|
|
($x, $y) = ($y, take($x) + $y)
|
3530
|
|
|
|
|
|
|
}
|
3531
|
|
|
|
|
|
|
};
|
3532
|
|
|
|
|
|
|
|
3533
|
|
|
|
|
|
|
a non-cached version C< gather_stream > is also available, see C< iterate_stream >
|
3534
|
|
|
|
|
|
|
|
3535
|
|
|
|
|
|
|
=cut
|
3536
|
|
|
|
|
|
|
|
3537
|
|
|
|
|
|
|
sub gather (&;$) {
|
3538
|
0
|
|
|
0
|
1
|
0
|
my $code = shift;
|
3539
|
0
|
|
|
|
|
0
|
my $take = $code->$cv_local('take');
|
3540
|
|
|
|
|
|
|
unshift @_, sub {
|
3541
|
0
|
|
|
0
|
|
0
|
my $ret;
|
3542
|
10
|
|
|
10
|
|
99
|
no warnings 'redefine';
|
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
2017
|
|
3543
|
0
|
|
|
|
|
0
|
local *$take = sub {$ret = $_[0]};
|
|
0
|
|
|
|
|
0
|
|
3544
|
0
|
|
|
|
|
0
|
$code->();
|
3545
|
0
|
|
|
|
|
0
|
$ret
|
3546
|
0
|
|
|
|
|
0
|
};
|
3547
|
0
|
|
|
|
|
0
|
goto &iterate
|
3548
|
|
|
|
|
|
|
}
|
3549
|
|
|
|
|
|
|
sub gather_stream (&;$) {
|
3550
|
0
|
|
|
0
|
0
|
0
|
local *iterate = *iterate_stream;
|
3551
|
0
|
|
|
|
|
0
|
&gather
|
3552
|
|
|
|
|
|
|
}
|
3553
|
10
|
|
|
10
|
|
1172
|
BEGIN {*gatherS = *gather_stream}
|
3554
|
|
|
|
|
|
|
|
3555
|
|
|
|
|
|
|
|
3556
|
|
|
|
|
|
|
=item gather_multi C< {CODE} [LIMIT] >
|
3557
|
|
|
|
|
|
|
|
3558
|
|
|
|
|
|
|
the same as C< gather > except you can C< take(...) > multiple times, and each
|
3559
|
|
|
|
|
|
|
can take a list. C< gather_multi_stream > is also available.
|
3560
|
|
|
|
|
|
|
|
3561
|
|
|
|
|
|
|
=cut
|
3562
|
|
|
|
|
|
|
|
3563
|
|
|
|
|
|
|
sub gather_multi (&;$) {
|
3564
|
0
|
|
|
0
|
1
|
0
|
my $code = shift;
|
3565
|
0
|
|
|
|
|
0
|
my $take = $code->$cv_local('take');
|
3566
|
|
|
|
|
|
|
unshift @_, sub {
|
3567
|
0
|
|
|
0
|
|
0
|
my @ret;
|
3568
|
10
|
|
|
10
|
|
76
|
no warnings 'redefine';
|
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
2483
|
|
3569
|
0
|
0
|
|
|
|
0
|
local *$take = sub {push @ret, @_; wantarray ? @_ : pop};
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3570
|
0
|
|
|
|
|
0
|
eval {$code->(); 1}
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3571
|
0
|
0
|
0
|
|
|
0
|
or catch_done and ref $@ and push @ret, @{$@};
|
|
|
|
0
|
|
|
|
|
3572
|
|
|
|
|
|
|
@ret
|
3573
|
0
|
|
|
|
|
0
|
};
|
|
0
|
|
|
|
|
0
|
|
3574
|
0
|
|
|
|
|
0
|
goto &iterate_multi
|
3575
|
|
|
|
|
|
|
}
|
3576
|
|
|
|
|
|
|
sub gather_multi_stream (&;$) {
|
3577
|
0
|
|
|
0
|
0
|
0
|
local *iterate_multi = *iterate_multi_stream;
|
3578
|
0
|
|
|
|
|
0
|
&gather_multi
|
3579
|
|
|
|
|
|
|
}
|
3580
|
|
|
|
|
|
|
BEGIN {
|
3581
|
10
|
|
|
10
|
|
33
|
*gatherM = *gather_multi;
|
3582
|
10
|
|
|
|
|
5634
|
*gatherMS = *gather_multi_stream
|
3583
|
|
|
|
|
|
|
}
|
3584
|
|
|
|
|
|
|
|
3585
|
|
|
|
|
|
|
|
3586
|
|
|
|
|
|
|
=item stream C< {CODE} >
|
3587
|
|
|
|
|
|
|
|
3588
|
|
|
|
|
|
|
in the C< CODE > block, calls to functions or methods with stream versions will
|
3589
|
|
|
|
|
|
|
be replaced by those versions. this applies also to functions that are called
|
3590
|
|
|
|
|
|
|
internally by C< List::Gen > (such as in the glob syntax). C< stream > returns
|
3591
|
|
|
|
|
|
|
what C< CODE > returns.
|
3592
|
|
|
|
|
|
|
|
3593
|
|
|
|
|
|
|
say iterate{}->type; # List::Gen::Iterate
|
3594
|
|
|
|
|
|
|
say iterate_stream{}->type; # List::Gen::Iterate_Stream
|
3595
|
|
|
|
|
|
|
stream {
|
3596
|
|
|
|
|
|
|
say iterate{}->type; # List::Gen::Iterate_Stream
|
3597
|
|
|
|
|
|
|
};
|
3598
|
|
|
|
|
|
|
say stream{iterate{}}->type; # List::Gen::Iterate_Stream
|
3599
|
|
|
|
|
|
|
say stream{<1.. if even>}->type; # List::Gen::Filter_Stream
|
3600
|
|
|
|
|
|
|
|
3601
|
|
|
|
|
|
|
placing code inside a C< stream > block is exactly the same as placing
|
3602
|
|
|
|
|
|
|
C< local $List::Gen::STREAM = 1; > at the top of a block.
|
3603
|
|
|
|
|
|
|
|
3604
|
|
|
|
|
|
|
=cut
|
3605
|
|
|
|
|
|
|
|
3606
|
|
|
|
|
|
|
sub stream (&) {
|
3607
|
0
|
|
|
0
|
1
|
0
|
local $STREAM = 1;
|
3608
|
0
|
|
|
|
|
0
|
$_[0]->()
|
3609
|
|
|
|
|
|
|
}
|
3610
|
|
|
|
|
|
|
|
3611
|
|
|
|
|
|
|
|
3612
|
|
|
|
|
|
|
=item glob C< STRING >
|
3613
|
|
|
|
|
|
|
|
3614
|
|
|
|
|
|
|
=item
|
3615
|
|
|
|
|
|
|
|
3616
|
|
|
|
|
|
|
by default, this module overrides perl's default C< glob > function. this is
|
3617
|
|
|
|
|
|
|
because the C< glob > function provides the behavior of the angle bracket
|
3618
|
|
|
|
|
|
|
delimited C<< <*.ext> >> operator, which is a nice place for inserting list
|
3619
|
|
|
|
|
|
|
comprehensions into perl's syntax. the override causes C< glob() > and the
|
3620
|
|
|
|
|
|
|
C<< <*.ext> >> operator to have a few special cases overridden, but any case
|
3621
|
|
|
|
|
|
|
that is not overridden will be passed to perl's internal C< glob > function
|
3622
|
|
|
|
|
|
|
(C<< my @files = <*.txt>; >> works as normal).
|
3623
|
|
|
|
|
|
|
|
3624
|
|
|
|
|
|
|
=over 4
|
3625
|
|
|
|
|
|
|
|
3626
|
|
|
|
|
|
|
=item * there are several types of overridden operations:
|
3627
|
|
|
|
|
|
|
|
3628
|
|
|
|
|
|
|
range: < [prefix,] low .. [high] [by step] >
|
3629
|
|
|
|
|
|
|
|
3630
|
|
|
|
|
|
|
iterate: < [prefix,] code ... [size] >
|
3631
|
|
|
|
|
|
|
|
3632
|
|
|
|
|
|
|
list comprehension: < [code for] (range|iterate) [if code] [while code] >
|
3633
|
|
|
|
|
|
|
|
3634
|
|
|
|
|
|
|
reduction: < \[op|name\] (range|iterate|list comprehension) >
|
3635
|
|
|
|
|
|
|
|
3636
|
|
|
|
|
|
|
=item * range strings match the following pattern:
|
3637
|
|
|
|
|
|
|
|
3638
|
|
|
|
|
|
|
(prefix,)? number .. number? ((by | += | -= | [-+]) number)?
|
3639
|
|
|
|
|
|
|
|
3640
|
|
|
|
|
|
|
here are a few examples of valid ranges:
|
3641
|
|
|
|
|
|
|
|
3642
|
|
|
|
|
|
|
<1 .. 10> ~~ range 1, 10
|
3643
|
|
|
|
|
|
|
<0 .. > ~~ range 0, 9**9**9
|
3644
|
|
|
|
|
|
|
<0 .. *> ~~ range 0, 9**9**9
|
3645
|
|
|
|
|
|
|
<1 .. 10 by 2> ~~ range 1, 10, 2
|
3646
|
|
|
|
|
|
|
<10 .. 1 -= 2> ~~ range 10, 1, -2
|
3647
|
|
|
|
|
|
|
~~ range 'a', 'z'
|
3648
|
|
|
|
|
|
|
~~ range 'A', 'ZZ'
|
3649
|
|
|
|
|
|
|
~~ range 'a', 9**9**9
|
3650
|
|
|
|
|
|
|
~~ range 'a', 9**9**9, 2
|
3651
|
|
|
|
|
|
|
<0, 0..> ~~ [0] + range 0, 9**9**9
|
3652
|
|
|
|
|
|
|
<'a','ab', 0..> ~~ ['a','ab'] + range 0, 9**9**9
|
3653
|
|
|
|
|
|
|
~~ [qw(a ab)] + range 0, 9**9**9
|
3654
|
|
|
|
|
|
|
|
3655
|
|
|
|
|
|
|
=item * iterate strings match the following pattern:
|
3656
|
|
|
|
|
|
|
|
3657
|
|
|
|
|
|
|
(.+? ,)+ (.*[*].* | \{ .+ }) ... number?
|
3658
|
|
|
|
|
|
|
|
3659
|
|
|
|
|
|
|
such as:
|
3660
|
|
|
|
|
|
|
|
3661
|
|
|
|
|
|
|
my $fib = <0, 1, * + * ... *>;
|
3662
|
|
|
|
|
|
|
|
3663
|
|
|
|
|
|
|
which means something like:
|
3664
|
|
|
|
|
|
|
|
3665
|
|
|
|
|
|
|
my $fib = do {
|
3666
|
|
|
|
|
|
|
my @pre = (0, 1);
|
3667
|
|
|
|
|
|
|
my $self;
|
3668
|
|
|
|
|
|
|
$self = iterate {
|
3669
|
|
|
|
|
|
|
@pre ? shift @pre : $self->get($_ - 2) + $self->get($_ - 1)
|
3670
|
|
|
|
|
|
|
} 9**9**9
|
3671
|
|
|
|
|
|
|
};
|
3672
|
|
|
|
|
|
|
|
3673
|
|
|
|
|
|
|
a few more examples:
|
3674
|
|
|
|
|
|
|
|
3675
|
|
|
|
|
|
|
my $fib = <0, 1, {$^a + $^b} ... *>;
|
3676
|
|
|
|
|
|
|
|
3677
|
|
|
|
|
|
|
my $fac = <1, * * _ ... *>;
|
3678
|
|
|
|
|
|
|
|
3679
|
|
|
|
|
|
|
my $int = <0, * + 1 ... *>;
|
3680
|
|
|
|
|
|
|
|
3681
|
|
|
|
|
|
|
my $fib = <0,1,*+*...>; # ending star is optional
|
3682
|
|
|
|
|
|
|
|
3683
|
|
|
|
|
|
|
=item * list comprehension strings match:
|
3684
|
|
|
|
|
|
|
|
3685
|
|
|
|
|
|
|
( .+ (for | [:|]) )? (range | iterate) ( (if | unless | [?,]) .+ )?
|
3686
|
|
|
|
|
|
|
( (while | until ) .+ )?
|
3687
|
|
|
|
|
|
|
|
3688
|
|
|
|
|
|
|
examples:
|
3689
|
|
|
|
|
|
|
|
3690
|
|
|
|
|
|
|
<**2: 1 .. 10> ~~ gen {$_**2} range 1, 10
|
3691
|
|
|
|
|
|
|
<**2: 1 .. 10 ? %2> ~~ gen {$_**2} filter {$_ % 2} range 1, 10
|
3692
|
|
|
|
|
|
|
~~ gen {sin} range 0, 3.14, 0.01
|
3693
|
|
|
|
|
|
|
<1 .. 10 if % 2> ~~ filter {$_ % 2} range 1, 10
|
3694
|
|
|
|
|
|
|
~~ gen {sin} filter {/5/} range 0, 10, 3
|
3695
|
|
|
|
|
|
|
<*3 for 0 .. 10 unless %3> ~~ gen {$_ * 3} filter {not $_ % 3} 0, 10
|
3696
|
|
|
|
|
|
|
<0 .. 100 while \< 10> ~~ While {$_ < 10} range 0, 100
|
3697
|
|
|
|
|
|
|
<*2 for 0.. if %2 while \<10> ~~ <0..>->grep('%2')->while('<10')->map('*2')
|
3698
|
|
|
|
|
|
|
|
3699
|
|
|
|
|
|
|
there are three delimiter types available for basic list comprehensions:
|
3700
|
|
|
|
|
|
|
|
3701
|
|
|
|
|
|
|
terse: <*2: 1.. ?%3>
|
3702
|
|
|
|
|
|
|
haskell: <*2| 1.., %3>
|
3703
|
|
|
|
|
|
|
verbose: <*2 for 1.. if %3>
|
3704
|
|
|
|
|
|
|
|
3705
|
|
|
|
|
|
|
you can mix and match C<< <*2 for 1.., %3> >>, C<< <*2| 1.. ?%3> >>
|
3706
|
|
|
|
|
|
|
|
3707
|
|
|
|
|
|
|
in the above examples, most of the code areas are using abbreviated syntax.
|
3708
|
|
|
|
|
|
|
here are a few equivalencies:
|
3709
|
|
|
|
|
|
|
|
3710
|
|
|
|
|
|
|
<*2:1..?%3> ~~ <*2 for 1.. if %3> ~~ <\$_ * 2 for 1 .. * if \$_ % 3>
|
3711
|
|
|
|
|
|
|
|
3712
|
|
|
|
|
|
|
<1.. if even> ~~ <1.. if not %2> ~~ <1..?!%2> ~~ <1.. if not _ % 2>
|
3713
|
|
|
|
|
|
|
~~ <1.. unless %2> ~~ <1..* if not \$_ % 2>
|
3714
|
|
|
|
|
|
|
|
3715
|
|
|
|
|
|
|
<1.. if %2> ~~ <1.. if _%2> ~~ <1..* ?odd> ~~ <1.. ? \$_ % 2>
|
3716
|
|
|
|
|
|
|
|
3717
|
|
|
|
|
|
|
=item * reduction strings match:
|
3718
|
|
|
|
|
|
|
|
3719
|
|
|
|
|
|
|
\[operator | function_name\] (range | iterate | list comp)
|
3720
|
|
|
|
|
|
|
|
3721
|
|
|
|
|
|
|
examples:
|
3722
|
|
|
|
|
|
|
|
3723
|
|
|
|
|
|
|
say <[+] 1..10>; # prints 55
|
3724
|
|
|
|
|
|
|
|
3725
|
|
|
|
|
|
|
pre/post fixing the operator with '..' uses the C< scan > function instead of
|
3726
|
|
|
|
|
|
|
C< reduce >
|
3727
|
|
|
|
|
|
|
|
3728
|
|
|
|
|
|
|
my $fac = <[..*] 1..>; # read as "a running product of one to infinity"
|
3729
|
|
|
|
|
|
|
|
3730
|
|
|
|
|
|
|
my $sum = <[+]>; # no argument returns the reduction function
|
3731
|
|
|
|
|
|
|
|
3732
|
|
|
|
|
|
|
say $sum->(1 .. 10); # 55
|
3733
|
|
|
|
|
|
|
say $sum->(<1..10>); # 55
|
3734
|
|
|
|
|
|
|
|
3735
|
|
|
|
|
|
|
my $rev_cat = <[R.]>; # prefix the operator with `R` to reverse it
|
3736
|
|
|
|
|
|
|
|
3737
|
|
|
|
|
|
|
say $rev_cat->(1 .. 9); # 987654321
|
3738
|
|
|
|
|
|
|
|
3739
|
|
|
|
|
|
|
=item * all of these features can be used together:
|
3740
|
|
|
|
|
|
|
|
3741
|
|
|
|
|
|
|
<[+..] *2 for 0 .. 100 by 2 unless %3 >
|
3742
|
|
|
|
|
|
|
|
3743
|
|
|
|
|
|
|
which is the same as:
|
3744
|
|
|
|
|
|
|
|
3745
|
|
|
|
|
|
|
range(0, 100, 2)->grep('not %3')->map('*2')->scan('+')
|
3746
|
|
|
|
|
|
|
|
3747
|
|
|
|
|
|
|
when multiple features are used together, the following construction order is
|
3748
|
|
|
|
|
|
|
used:
|
3749
|
|
|
|
|
|
|
|
3750
|
|
|
|
|
|
|
1. prefix
|
3751
|
|
|
|
|
|
|
2. range or iterate
|
3752
|
|
|
|
|
|
|
3. if / unless (grep)
|
3753
|
|
|
|
|
|
|
4. while / until (while)
|
3754
|
|
|
|
|
|
|
5. for (map)
|
3755
|
|
|
|
|
|
|
6. reduce / scan
|
3756
|
|
|
|
|
|
|
|
3757
|
|
|
|
|
|
|
([prefix] + (range|iterate))->grep(...)->while(...)->map(...)->reduce(...)
|
3758
|
|
|
|
|
|
|
|
3759
|
|
|
|
|
|
|
=item * bignums
|
3760
|
|
|
|
|
|
|
|
3761
|
|
|
|
|
|
|
when run in perl 5.9.4+, glob strings will honor the lexical pragmas C< bignum >,
|
3762
|
|
|
|
|
|
|
C< bigint >, and C< bigrat >.
|
3763
|
|
|
|
|
|
|
|
3764
|
|
|
|
|
|
|
*factorial = do {use bigint; <[..*] 1, 1..>->code};
|
3765
|
|
|
|
|
|
|
|
3766
|
|
|
|
|
|
|
say factorial(25); # 15511210043330985984000000
|
3767
|
|
|
|
|
|
|
|
3768
|
|
|
|
|
|
|
=item * special characters
|
3769
|
|
|
|
|
|
|
|
3770
|
|
|
|
|
|
|
since the angle brackets (C<< < >> and C<< > >>) are used as delimiters of the
|
3771
|
|
|
|
|
|
|
glob string, they both must be escaped with C< \ > if used in the C<< <...> >>
|
3772
|
|
|
|
|
|
|
construct.
|
3773
|
|
|
|
|
|
|
|
3774
|
|
|
|
|
|
|
<1..10 if \< 5>->say; # 1 2 3 4
|
3775
|
|
|
|
|
|
|
|
3776
|
|
|
|
|
|
|
due to C<< <...> >> being a C< qq{} > string, in the code areas if you need to
|
3777
|
|
|
|
|
|
|
write C< $_ > write it without the sigil as C< _ >
|
3778
|
|
|
|
|
|
|
|
3779
|
|
|
|
|
|
|
<1 .. 10 if _**2 \> 40>->say; # 7 8 9 10
|
3780
|
|
|
|
|
|
|
|
3781
|
|
|
|
|
|
|
it can be escaped C< \$_ > as well.
|
3782
|
|
|
|
|
|
|
|
3783
|
|
|
|
|
|
|
neither of these issues apply to calling glob directly with a single quoted
|
3784
|
|
|
|
|
|
|
string:
|
3785
|
|
|
|
|
|
|
|
3786
|
|
|
|
|
|
|
glob('1..10 if $_ < 5')->say; # 1 2 3 4
|
3787
|
|
|
|
|
|
|
|
3788
|
|
|
|
|
|
|
=back
|
3789
|
|
|
|
|
|
|
|
3790
|
|
|
|
|
|
|
=cut
|
3791
|
|
|
|
|
|
|
|
3792
|
|
|
|
|
|
|
my $get_pragma = do {
|
3793
|
|
|
|
|
|
|
my @pragmas;
|
3794
|
|
|
|
|
|
|
my $init = 1;
|
3795
|
|
|
|
|
|
|
sub {
|
3796
|
|
|
|
|
|
|
if ($init) {
|
3797
|
|
|
|
|
|
|
$init = 0;
|
3798
|
|
|
|
|
|
|
@pragmas = grep {$INC{"$_.pm"}} qw (bignum bigint bigrat);
|
3799
|
|
|
|
|
|
|
}
|
3800
|
|
|
|
|
|
|
return '' if @pragmas == 0 or $] < 5.009004;
|
3801
|
|
|
|
|
|
|
my $caller = 1;
|
3802
|
|
|
|
|
|
|
$caller++ while (substr caller $caller, 0 => 9) eq 'List::Gen';
|
3803
|
|
|
|
|
|
|
join '' => map {
|
3804
|
|
|
|
|
|
|
(($_->can('in_effect') or sub{})->($caller + 1)) ? "use $_; " : ''
|
3805
|
|
|
|
|
|
|
} @pragmas
|
3806
|
|
|
|
|
|
|
}
|
3807
|
|
|
|
|
|
|
};
|
3808
|
|
|
|
|
|
|
|
3809
|
|
|
|
|
|
|
{
|
3810
|
|
|
|
|
|
|
my $number = qr{
|
3811
|
|
|
|
|
|
|
(?: - \s* )?
|
3812
|
|
|
|
|
|
|
(?:
|
3813
|
|
|
|
|
|
|
(?: \d[\d_]* | (?: \d*\.\d+ ) ) (?: e -? \d+ )?
|
3814
|
|
|
|
|
|
|
| [a-zA-Z]+?
|
3815
|
|
|
|
|
|
|
)
|
3816
|
|
|
|
|
|
|
}x;
|
3817
|
|
|
|
|
|
|
my $prefix = qr{
|
3818
|
|
|
|
|
|
|
(?:
|
3819
|
|
|
|
|
|
|
(?: $number | "[^"]+" | '[^']+' | [^,]+ ) \s*
|
3820
|
|
|
|
|
|
|
, \s*
|
3821
|
|
|
|
|
|
|
)+
|
3822
|
|
|
|
|
|
|
}x;
|
3823
|
|
|
|
|
|
|
my $build_iterate;
|
3824
|
|
|
|
|
|
|
my $glob = sub {glob $_[0]};
|
3825
|
10
|
|
|
10
|
|
10875
|
use subs 'glob';
|
|
10
|
|
|
|
|
335
|
|
|
10
|
|
|
|
|
55
|
|
3826
|
|
|
|
|
|
|
sub glob {
|
3827
|
40
|
50
|
|
40
|
|
1903
|
local *_ = @_ ? \"$_[0]" : \"$_";
|
3828
|
40
|
|
|
|
|
147
|
s/^\s+|\s+$//g;
|
3829
|
40
|
|
|
|
|
41
|
my $reduce;
|
3830
|
40
|
|
|
|
|
85
|
my $pkg = $external_package->(1);
|
3831
|
40
|
100
|
|
|
|
533
|
if (s{^
|
3832
|
|
|
|
|
|
|
\[
|
3833
|
|
|
|
|
|
|
( (?: \\ | \.\.? | , ) (?! \] ) )?
|
3834
|
|
|
|
|
|
|
(?:
|
3835
|
|
|
|
|
|
|
(?: ( [Rr]{0,1} ) \s* ( $ops ) )
|
3836
|
|
|
|
|
|
|
| ( (?=[^Rr0-9_])\w | [a-zA-Z_]\w+ )
|
3837
|
|
|
|
|
|
|
)
|
3838
|
|
|
|
|
|
|
( (?: \.\.? | , ) )?
|
3839
|
|
|
|
|
|
|
\]
|
3840
|
|
|
|
|
|
|
}{}x) {
|
3841
|
8
|
|
66
|
|
|
52
|
my ($rev, $op, $word, $scan) = ($2, $3, $4, $1 || $5);
|
3842
|
8
|
50
|
|
|
|
18
|
if ($op) {
|
3843
|
8
|
100
|
|
|
|
22
|
$op = 'R'.$op if $rev
|
3844
|
|
|
|
|
|
|
} else {
|
3845
|
0
|
0
|
|
|
|
0
|
if (my $sub = $pkg->can($word)) {
|
3846
|
0
|
|
|
0
|
|
0
|
$op = $rev ? sub {$sub->($b, $a)}
|
3847
|
0
|
|
|
0
|
|
0
|
: sub {$sub->($a, $b)}
|
3848
|
0
|
0
|
|
|
|
0
|
} else {
|
3849
|
0
|
|
|
|
|
0
|
croak "subroutine '&${pkg}::$word' not found"
|
3850
|
|
|
|
|
|
|
}
|
3851
|
|
|
|
|
|
|
}
|
3852
|
7
|
|
|
7
|
|
30
|
$reduce = $scan ? sub {$_[0]->scan ($op)}
|
3853
|
7
|
|
|
7
|
|
28
|
: sub {$_[0]->reduce($op)}
|
3854
|
8
|
100
|
|
|
|
58
|
}
|
3855
|
40
|
|
|
|
|
88
|
my $pragma = $get_pragma->();
|
3856
|
40
|
100
|
|
|
|
1178
|
if (my ($gen, $pre, $low, $high, $step, $iterate, $filter, $while) = m{^
|
3857
|
|
|
|
|
|
|
(?: \s* ( .+? ) \s*
|
3858
|
|
|
|
|
|
|
(?: [|:] | \b for \b)
|
3859
|
|
|
|
|
|
|
){0,1} \s*
|
3860
|
|
|
|
|
|
|
(?: ( $prefix ) ){0,1} \s*
|
3861
|
|
|
|
|
|
|
(?:
|
3862
|
|
|
|
|
|
|
( $number ) \s*
|
3863
|
|
|
|
|
|
|
\.\. (?!\.) \s*
|
3864
|
|
|
|
|
|
|
( $number | -?(?:\*|) ) \s*
|
3865
|
|
|
|
|
|
|
(?:
|
3866
|
|
|
|
|
|
|
(?: \b by \b | [+]= | \+ | (?=-) ) \s*
|
3867
|
|
|
|
|
|
|
( (?: -= \s* )? $number )
|
3868
|
|
|
|
|
|
|
)? \s*
|
3869
|
|
|
|
|
|
|
|
|
3870
|
|
|
|
|
|
|
(.*? \s* \.\.\. \s* (?:$number|\*)?) \s*
|
3871
|
|
|
|
|
|
|
)
|
3872
|
|
|
|
|
|
|
(?:
|
3873
|
|
|
|
|
|
|
(?: \b if \b | (?=\b unless \b) | [?,] ) \s*
|
3874
|
|
|
|
|
|
|
( .+? ) \s*
|
3875
|
|
|
|
|
|
|
)?
|
3876
|
|
|
|
|
|
|
(
|
3877
|
|
|
|
|
|
|
\b (?: while | until ) \b \s*
|
3878
|
|
|
|
|
|
|
.+?
|
3879
|
|
|
|
|
|
|
)? \s*
|
3880
|
|
|
|
|
|
|
$}sxo) {
|
3881
|
32
|
50
|
|
|
|
108
|
$filter =~ s/^unless\b/not / if $filter;
|
3882
|
32
|
50
|
0
|
|
|
73
|
$while =~ s/^while\s*/not / or
|
3883
|
|
|
|
|
|
|
$while =~ s/^until\s*// if $while;
|
3884
|
32
|
|
50
|
|
|
121
|
$pre ||= '';
|
3885
|
32
|
|
|
|
|
37
|
my $ret;
|
3886
|
32
|
100
|
|
|
|
47
|
if ($iterate) {
|
3887
|
5
|
|
|
|
|
17
|
$ret = $build_iterate->($pre.$iterate, $pragma, $pkg);
|
3888
|
5
|
|
|
|
|
10
|
$pre = '';
|
3889
|
|
|
|
|
|
|
} else {
|
3890
|
27
|
100
|
|
|
|
112
|
$high = 9**9**9 if $high =~ /^\*?$/;
|
3891
|
27
|
50
|
|
|
|
98
|
if ($high eq '-*') {
|
3892
|
0
|
|
|
|
|
0
|
$high = -9**9**9;
|
3893
|
0
|
|
0
|
|
|
0
|
$step ||= -1;
|
3894
|
|
|
|
|
|
|
}
|
3895
|
27
|
50
|
|
|
|
58
|
$high = -9**9**9 if $high eq '-*';
|
3896
|
27
|
|
66
|
|
|
188
|
$_ and s/_//g, s/^-\s+/-/ for $low, $high, $step;
|
3897
|
27
|
50
|
|
|
|
62
|
$step =~ s/^-=\s*/-/ if $step;
|
3898
|
27
|
|
50
|
|
|
154
|
$ret = &range($low, $high, $step || 1);
|
3899
|
|
|
|
|
|
|
}
|
3900
|
32
|
50
|
|
|
|
73
|
if ($pre) {
|
3901
|
0
|
|
|
|
|
0
|
$pre =~ s/,\s*$//g;
|
3902
|
0
|
|
|
|
|
0
|
$pre = 'prefix'->$eval($pragma."do {[$pre]}");
|
3903
|
0
|
0
|
|
|
|
0
|
$ret = $pre + $ret if @$pre;
|
3904
|
|
|
|
|
|
|
}
|
3905
|
32
|
|
|
|
|
166
|
for ([filter => $filter], [until => $while], [gen => $gen]) {
|
3906
|
96
|
50
|
|
|
|
212
|
$$_[1] or next;
|
3907
|
0
|
|
|
|
|
0
|
my ($method, $code) = @$_;
|
3908
|
0
|
|
|
|
|
0
|
$code =~ s'\b(?:(?
|
3909
|
0
|
|
|
|
|
0
|
$ret = $ret->$method($code);
|
3910
|
|
|
|
|
|
|
}
|
3911
|
32
|
50
|
|
|
|
412
|
$reduce ? $reduce->($ret) : $ret
|
3912
|
|
|
|
|
|
|
}
|
3913
|
|
|
|
|
|
|
else {
|
3914
|
|
|
|
|
|
|
$reduce && !$_ ? sub {
|
3915
|
14
|
|
66
|
14
|
|
70
|
$reduce->(@_ == 1 && isagen $_[0] or &makegen(\@_))
|
3916
|
8
|
50
|
33
|
|
|
74
|
} : $glob->($_[0])
|
3917
|
|
|
|
|
|
|
}
|
3918
|
|
|
|
|
|
|
}
|
3919
|
|
|
|
|
|
|
$build_iterate = sub {
|
3920
|
|
|
|
|
|
|
(local $_, my ($pragma, $pkg)) = @_;
|
3921
|
|
|
|
|
|
|
if (my ($x, $n) = /^
|
3922
|
|
|
|
|
|
|
( \w+ | '[^']*' | "[^"]*" )
|
3923
|
|
|
|
|
|
|
\s* \.{3} \s*
|
3924
|
|
|
|
|
|
|
(\*|\d*)
|
3925
|
|
|
|
|
|
|
$/x) {
|
3926
|
|
|
|
|
|
|
$n = '' if $n eq '*';
|
3927
|
|
|
|
|
|
|
$x =~ s/^('|")(.*)\1$/$2/s;
|
3928
|
|
|
|
|
|
|
return repeat($x, length $n ? $n : ())
|
3929
|
|
|
|
|
|
|
}
|
3930
|
|
|
|
|
|
|
s/$^/\$^/g;
|
3931
|
|
|
|
|
|
|
my ($pre, $block, $star, $end) = /^
|
3932
|
|
|
|
|
|
|
($prefix)? \s*
|
3933
|
|
|
|
|
|
|
(?: \{ (.*\$\^\w.*) \}
|
3934
|
|
|
|
|
|
|
| (
|
3935
|
|
|
|
|
|
|
.*(?: \* | \b_\b ).*
|
3936
|
|
|
|
|
|
|
| $number
|
3937
|
|
|
|
|
|
|
| '(?:[^']|\\')*'
|
3938
|
|
|
|
|
|
|
| "(?:[^"]|\\")*"
|
3939
|
|
|
|
|
|
|
)
|
3940
|
|
|
|
|
|
|
) \s*
|
3941
|
|
|
|
|
|
|
\.{3} \s*
|
3942
|
|
|
|
|
|
|
([\d\*]+ | )
|
3943
|
|
|
|
|
|
|
$/xs
|
3944
|
|
|
|
|
|
|
or croak "parse error: $_";
|
3945
|
|
|
|
|
|
|
|
3946
|
|
|
|
|
|
|
$end = '9**9**9' if $end eq '' or $end eq '*';
|
3947
|
|
|
|
|
|
|
$pre ||= '';
|
3948
|
|
|
|
|
|
|
my $self;
|
3949
|
|
|
|
|
|
|
if ($pre) {
|
3950
|
|
|
|
|
|
|
$pre =~ s/,\s*$//g;
|
3951
|
|
|
|
|
|
|
$pre = 'prefix '->$eval($pragma."[do {$pre}]");
|
3952
|
|
|
|
|
|
|
}
|
3953
|
|
|
|
|
|
|
my $i = 1;
|
3954
|
|
|
|
|
|
|
my $from;
|
3955
|
|
|
|
|
|
|
if ($block) {
|
3956
|
|
|
|
|
|
|
$block =~ s'\b(?:\$\^_|(?
|
3957
|
|
|
|
|
|
|
for (sort keys %{{$block =~ /((\$\^\w+))/g}}) {
|
3958
|
|
|
|
|
|
|
$block =~ s/\Q$_/\$fetch->(undef, \$_ - $i)/g;
|
3959
|
|
|
|
|
|
|
$i++;
|
3960
|
|
|
|
|
|
|
}
|
3961
|
|
|
|
|
|
|
$self = $block;
|
3962
|
|
|
|
|
|
|
}
|
3963
|
|
|
|
|
|
|
else {
|
3964
|
|
|
|
|
|
|
$star =~ s'\b(?
|
3965
|
|
|
|
|
|
|
|
3966
|
|
|
|
|
|
|
$star =~ s/(?<=[\*\w\]\}\)])\s*\*\*(?=\s*\S)/{#exp#}/g;
|
3967
|
|
|
|
|
|
|
|
3968
|
|
|
|
|
|
|
$i = $star =~ s{
|
3969
|
|
|
|
|
|
|
\* (?= \s* ( \*{1,2} \s* \S
|
3970
|
|
|
|
|
|
|
| [-+%.\/\)\]\};,]
|
3971
|
|
|
|
|
|
|
| $
|
3972
|
|
|
|
|
|
|
| \{\#.+?\#\}
|
3973
|
|
|
|
|
|
|
)
|
3974
|
|
|
|
|
|
|
)} '{*}'gx;
|
3975
|
|
|
|
|
|
|
$star =~ s/\{#exp#\}/**/g;
|
3976
|
|
|
|
|
|
|
if ($i == 1 and $star !~ /\$_(?:\b|$)/) {
|
3977
|
|
|
|
|
|
|
$star =~ s/\Q{*}\E(?=\W|$)/\$_/g;
|
3978
|
|
|
|
|
|
|
$star =~ s/\Q{*}/\$_ /g;
|
3979
|
|
|
|
|
|
|
$from = 1;
|
3980
|
|
|
|
|
|
|
} else {
|
3981
|
|
|
|
|
|
|
$star =~ s/\Q{*}/'$fetch->(undef, $_ - '.$i--.')'/ge
|
3982
|
|
|
|
|
|
|
}
|
3983
|
|
|
|
|
|
|
$self = $star
|
3984
|
|
|
|
|
|
|
}
|
3985
|
|
|
|
|
|
|
$self = "List::Gen::iterate {package $pkg; $pragma$self} $end";
|
3986
|
|
|
|
|
|
|
|
3987
|
|
|
|
|
|
|
'iterate'->$say_eval($self) if $SAY_EVAL or DEBUG;
|
3988
|
|
|
|
|
|
|
|
3989
|
|
|
|
|
|
|
my $say = $self =~ /(?:\b|^)say(?:\b|$)/
|
3990
|
|
|
|
|
|
|
? "use feature 'say';"
|
3991
|
|
|
|
|
|
|
: '';
|
3992
|
|
|
|
|
|
|
my $fetch;
|
3993
|
|
|
|
|
|
|
$self = (eval $say.$self
|
3994
|
|
|
|
|
|
|
or Carp::croak "iterate error: $@\n$say$self\n");
|
3995
|
|
|
|
|
|
|
|
3996
|
|
|
|
|
|
|
return $self->from(@$pre) if $from and $pre;
|
3997
|
|
|
|
|
|
|
$self->load(@$pre) if $pre and @$pre;
|
3998
|
|
|
|
|
|
|
$fetch = tied(@$self)->can('FETCH');
|
3999
|
|
|
|
|
|
|
weaken $fetch;
|
4000
|
|
|
|
|
|
|
$self
|
4001
|
|
|
|
|
|
|
}}
|
4002
|
|
|
|
|
|
|
|
4003
|
|
|
|
|
|
|
|
4004
|
|
|
|
|
|
|
=item List::Gen C< ... >
|
4005
|
|
|
|
|
|
|
|
4006
|
|
|
|
|
|
|
the subroutine C< Gen > in the package C< List:: > is a dwimmy function that
|
4007
|
|
|
|
|
|
|
produces a generator from a variety of sources. since C< List::Gen > is a fully
|
4008
|
|
|
|
|
|
|
qualified name, it is available from all packages without the need to import it.
|
4009
|
|
|
|
|
|
|
|
4010
|
|
|
|
|
|
|
if given only one argument, the following table describes what is done:
|
4011
|
|
|
|
|
|
|
|
4012
|
|
|
|
|
|
|
array ref: List::Gen \@array ~~ makegen @array
|
4013
|
|
|
|
|
|
|
code ref: List::Gen sub {$_**2} ~~ <0..>->map(sub {$_**2})
|
4014
|
|
|
|
|
|
|
scalar ref: List::Gen \'*2' ~~ <0..>->map('*2')
|
4015
|
|
|
|
|
|
|
glob string: List::Gen '1.. by 2' ~~ <1.. by 2>
|
4016
|
|
|
|
|
|
|
glob string: List::Gen '0, 1, *+*' ~~ <0, 1, *+*...>
|
4017
|
|
|
|
|
|
|
file handle: List::Gen $fh ~~ file $fh
|
4018
|
|
|
|
|
|
|
|
4019
|
|
|
|
|
|
|
if the argument does not match the table, or the method is given more than one
|
4020
|
|
|
|
|
|
|
argument, the list is converted to a generator with C< list(...) >
|
4021
|
|
|
|
|
|
|
|
4022
|
|
|
|
|
|
|
List::Gen(1, 2, 3)->map('2**')->say; # 2 4 8
|
4023
|
|
|
|
|
|
|
|
4024
|
|
|
|
|
|
|
since it results in longer code than any of the equivalent constructs, it is
|
4025
|
|
|
|
|
|
|
mostly for if you have not imported anything: C< use List::Gen (); >
|
4026
|
|
|
|
|
|
|
|
4027
|
|
|
|
|
|
|
=cut
|
4028
|
|
|
|
|
|
|
|
4029
|
|
|
|
|
|
|
sub List::Gen {
|
4030
|
1
|
50
|
|
1
|
|
2
|
do {
|
4031
|
1
|
50
|
|
|
|
4
|
if (@_ == 0) {'List::Gen'}
|
|
1
|
0
|
|
|
|
16
|
|
4032
|
|
|
|
|
|
|
elsif (@_ == 1) {
|
4033
|
0
|
0
|
|
|
|
0
|
if (ref $_[0]) {
|
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
4034
|
0
|
0
|
|
|
|
0
|
if (ref $_[0] eq 'ARRAY' ) {&makegen}
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
0
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
4035
|
0
|
|
|
|
|
0
|
elsif (ref $_[0] eq 'CODE' ) {&range(0, 9**9**9)->map($_[0])}
|
4036
|
0
|
|
|
|
|
0
|
elsif (ref $_[0] eq 'SCALAR') {&range(0, 9**9**9)->map(${$_[0]})}
|
|
0
|
|
|
|
|
0
|
|
4037
|
0
|
|
|
|
|
0
|
elsif (isagen $_[0] ) {$_[0]->copy}
|
4038
|
|
|
|
|
|
|
elsif (openhandle $_[0] ) {&file}
|
4039
|
|
|
|
|
|
|
}
|
4040
|
0
|
|
|
|
|
0
|
elsif ($_[0] =~ /.[.]{2,3}/) {&glob}
|
4041
|
|
|
|
|
|
|
elsif ($_[0] =~ /\*/) {&glob($_[0].'...')}
|
4042
|
|
|
|
|
|
|
}
|
4043
|
|
|
|
|
|
|
} or &list
|
4044
|
|
|
|
|
|
|
}
|
4045
|
10
|
|
|
10
|
|
30127
|
BEGIN {*List::Generator = *List::Gen}
|
4046
|
|
|
|
|
|
|
|
4047
|
|
|
|
|
|
|
|
4048
|
|
|
|
|
|
|
=item vecgen C< [BITS] [SIZE] [DATA] >
|
4049
|
|
|
|
|
|
|
|
4050
|
|
|
|
|
|
|
C< vecgen > wraps a bit vector in a generator. BITS defaults to 8. SIZE
|
4051
|
|
|
|
|
|
|
defaults to infinite. DATA defaults to an empty string.
|
4052
|
|
|
|
|
|
|
|
4053
|
|
|
|
|
|
|
cells of the generator can be assigned to using array dereferencing:
|
4054
|
|
|
|
|
|
|
|
4055
|
|
|
|
|
|
|
my $vec = vecgen;
|
4056
|
|
|
|
|
|
|
$$vec[3] = 5;
|
4057
|
|
|
|
|
|
|
|
4058
|
|
|
|
|
|
|
or with the C<< ->set(...) >> method:
|
4059
|
|
|
|
|
|
|
|
4060
|
|
|
|
|
|
|
$vec->set(3, 5);
|
4061
|
|
|
|
|
|
|
|
4062
|
|
|
|
|
|
|
=cut
|
4063
|
|
|
|
|
|
|
|
4064
|
|
|
|
|
|
|
sub vecgen {
|
4065
|
0
|
|
|
0
|
1
|
0
|
tiegen Vec => @_
|
4066
|
|
|
|
|
|
|
}
|
4067
|
|
|
|
|
|
|
generator Vec => sub {
|
4068
|
0
|
|
|
0
|
|
0
|
my ($class, $bits, $size, $str) = @_;
|
4069
|
0
|
|
0
|
|
|
0
|
$str ||= '';
|
4070
|
0
|
|
0
|
|
|
0
|
$bits ||= 8;
|
4071
|
0
|
|
0
|
|
|
0
|
$size ||= 9**9**9;
|
4072
|
0
|
|
|
0
|
|
0
|
List::Gen::curse {
|
4073
|
|
|
|
|
|
|
FETCH => sub {vec $str, $_[1], $bits},
|
4074
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
4075
|
0
|
|
|
0
|
|
0
|
map {$_ => sub {vec($str, $_[1], $bits) = $_[2]}} qw (STORE set)
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
4076
|
|
|
|
|
|
|
} => $class
|
4077
|
|
|
|
|
|
|
};
|
4078
|
|
|
|
|
|
|
|
4079
|
|
|
|
|
|
|
|
4080
|
|
|
|
|
|
|
=item primes
|
4081
|
|
|
|
|
|
|
|
4082
|
|
|
|
|
|
|
utilizing the same mechanism as the C<< <1..>->grep('prime') >> construct, the
|
4083
|
|
|
|
|
|
|
C< primes > function returns an equivalent, but more efficiently constructed
|
4084
|
|
|
|
|
|
|
generator.
|
4085
|
|
|
|
|
|
|
|
4086
|
|
|
|
|
|
|
prime numbers below 1e7 are tested with a sieve of eratosthenes and should be
|
4087
|
|
|
|
|
|
|
reasonably efficient. beyond that, simple trial division is used.
|
4088
|
|
|
|
|
|
|
|
4089
|
|
|
|
|
|
|
C< primes > always returns the same generator.
|
4090
|
|
|
|
|
|
|
|
4091
|
|
|
|
|
|
|
=cut
|
4092
|
|
|
|
|
|
|
|
4093
|
|
|
|
|
|
|
{
|
4094
|
|
|
|
|
|
|
our $DEBUG_PRIME;
|
4095
|
|
|
|
|
|
|
BEGIN {
|
4096
|
|
|
|
|
|
|
*List::Gen::DEBUG_PRIME = sub () {0}
|
4097
|
10
|
50
|
|
10
|
|
4338
|
unless defined &List::Gen::DEBUG_PRIME;
|
4098
|
|
|
|
|
|
|
}
|
4099
|
|
|
|
|
|
|
my ($max, $prime, $primes_gen) = -1;
|
4100
|
0
|
|
|
0
|
|
0
|
sub _reset_prime {$max = -1; $primes_gen = $prime = ''}
|
|
0
|
|
|
|
|
0
|
|
4101
|
|
|
|
|
|
|
my $build = sub {
|
4102
|
|
|
|
|
|
|
return if $_[0] < $max;
|
4103
|
|
|
|
|
|
|
$max = $_[0] > 1000
|
4104
|
|
|
|
|
|
|
? $_[0] : 1000;
|
4105
|
|
|
|
|
|
|
$max = min $max, 1e7;
|
4106
|
|
|
|
|
|
|
$prime = '001' . '10' x ($max/2);
|
4107
|
|
|
|
|
|
|
my ($n, $i) = 1;
|
4108
|
|
|
|
|
|
|
while (($n += 2) < $max) {
|
4109
|
|
|
|
|
|
|
if (substr $prime, $n, 1) { init: $i = $n;
|
4110
|
|
|
|
|
|
|
substr $prime, $i, 1, 0 while ($i += $n) < $max}}
|
4111
|
|
|
|
|
|
|
};
|
4112
|
|
|
|
|
|
|
sub primes () {
|
4113
|
0
|
|
0
|
0
|
1
|
0
|
$primes_gen ||= do {
|
4114
|
0
|
|
|
|
|
0
|
$build->(1000);
|
4115
|
0
|
|
|
|
|
0
|
my ($n, $lim, $i) = 2;
|
4116
|
|
|
|
|
|
|
&iterate(sub {
|
4117
|
0
|
|
|
0
|
|
0
|
if (List::Gen::DEBUG_PRIME and $DEBUG_PRIME) {
|
4118
|
|
|
|
|
|
|
return $n++ if $n == 2;
|
4119
|
10
|
|
|
10
|
|
175
|
no warnings;
|
|
10
|
|
|
|
|
25
|
|
|
10
|
|
|
|
|
3550
|
|
4120
|
|
|
|
|
|
|
goto trial_division
|
4121
|
|
|
|
|
|
|
}
|
4122
|
0
|
0
|
|
|
|
0
|
if ($n < 1e7) {
|
4123
|
0
|
|
0
|
|
|
0
|
$n > $max and $build->($n * 10)
|
4124
|
|
|
|
|
|
|
until substr $prime, $n++, 1;
|
4125
|
0
|
|
|
|
|
0
|
$n - 1
|
4126
|
|
|
|
|
|
|
}
|
4127
|
|
|
|
|
|
|
else {trial_division:
|
4128
|
0
|
|
|
|
|
0
|
while (1) {
|
4129
|
0
|
0
|
|
|
|
0
|
$n++, next unless $n & 1;
|
4130
|
0
|
|
|
|
|
0
|
($i, $lim) = (3, 1 + int sqrt $n);
|
4131
|
0
|
|
|
|
|
0
|
while ($i < $lim) {
|
4132
|
0
|
0
|
|
|
|
0
|
$n % $i or $n++, next trial_division;
|
4133
|
0
|
|
|
|
|
0
|
$i += 2;
|
4134
|
|
|
|
|
|
|
}
|
4135
|
0
|
|
|
|
|
0
|
return $n++
|
4136
|
|
|
|
|
|
|
}
|
4137
|
|
|
|
|
|
|
}
|
4138
|
|
|
|
|
|
|
})
|
4139
|
0
|
|
|
|
|
0
|
}
|
4140
|
|
|
|
|
|
|
}
|
4141
|
|
|
|
|
|
|
$ops{prime} = sub ($) {
|
4142
|
|
|
|
|
|
|
my $n = @_ ? $_[0] : $_;
|
4143
|
|
|
|
|
|
|
return $n == 2 if not $n & 1 or $n < 2;
|
4144
|
|
|
|
|
|
|
if (List::Gen::DEBUG_PRIME and $DEBUG_PRIME) {
|
4145
|
10
|
|
|
10
|
|
60
|
no warnings;
|
|
10
|
|
|
|
|
25
|
|
|
10
|
|
|
|
|
27338
|
|
4146
|
|
|
|
|
|
|
goto trial_division
|
4147
|
|
|
|
|
|
|
}
|
4148
|
|
|
|
|
|
|
if ($n < 1e7) {
|
4149
|
|
|
|
|
|
|
$build->($n * 10) if $n > $max;
|
4150
|
|
|
|
|
|
|
substr $prime, $n, 1
|
4151
|
|
|
|
|
|
|
}
|
4152
|
|
|
|
|
|
|
else {trial_division:
|
4153
|
|
|
|
|
|
|
my ($i, $lim) = (1, 1 + int sqrt $n);
|
4154
|
|
|
|
|
|
|
$n % $i or return 0 while ($i += 2) < $lim;
|
4155
|
|
|
|
|
|
|
1
|
4156
|
|
|
|
|
|
|
}
|
4157
|
|
|
|
|
|
|
}
|
4158
|
|
|
|
|
|
|
}
|
4159
|
|
|
|
|
|
|
|
4160
|
|
|
|
|
|
|
|
4161
|
|
|
|
|
|
|
=back
|
4162
|
|
|
|
|
|
|
|
4163
|
|
|
|
|
|
|
=head2 modifying generators
|
4164
|
|
|
|
|
|
|
|
4165
|
|
|
|
|
|
|
=over 4
|
4166
|
|
|
|
|
|
|
|
4167
|
|
|
|
|
|
|
=item slice C< SOURCE_GEN RANGE_GEN >
|
4168
|
|
|
|
|
|
|
|
4169
|
|
|
|
|
|
|
C< slice > uses C< RANGE_GEN > to generate the indices used to take a lazy
|
4170
|
|
|
|
|
|
|
slice of C< SOURCE_GEN >.
|
4171
|
|
|
|
|
|
|
|
4172
|
|
|
|
|
|
|
my $gen = gen {$_ ** 2};
|
4173
|
|
|
|
|
|
|
|
4174
|
|
|
|
|
|
|
my $s1 = slice $gen, range 1, 9**9**9;
|
4175
|
|
|
|
|
|
|
my $s2 = slice $gen, <1..>;
|
4176
|
|
|
|
|
|
|
my $s3 = $gen->slice(<1..>);
|
4177
|
|
|
|
|
|
|
my $s4 = $gen->(<1..>);
|
4178
|
|
|
|
|
|
|
|
4179
|
|
|
|
|
|
|
$s1 ~~ $s2 ~~ $s3 ~~ $s4 ~~ $gen->tail
|
4180
|
|
|
|
|
|
|
|
4181
|
|
|
|
|
|
|
C< slice > will perform some optimizations if it detects that C< RANGE_GEN > is
|
4182
|
|
|
|
|
|
|
sufficiently simple (something like C< range $x, $y, 1 >). also, stacked simple
|
4183
|
|
|
|
|
|
|
slices will collapse into a single slice, which turns repeated tailing of a
|
4184
|
|
|
|
|
|
|
generator into a relatively efficient operation.
|
4185
|
|
|
|
|
|
|
|
4186
|
|
|
|
|
|
|
$gen->(<1..>)->(<1..>)->(<1..>) ~~ $gen->(<3..>) ~~ $gen->tail->tail->tail
|
4187
|
|
|
|
|
|
|
|
4188
|
|
|
|
|
|
|
=cut
|
4189
|
|
|
|
|
|
|
|
4190
|
|
|
|
|
|
|
sub slice {
|
4191
|
9
|
|
|
9
|
1
|
18
|
tiegen Slice => @_
|
4192
|
|
|
|
|
|
|
}
|
4193
|
|
|
|
|
|
|
generator Slice => sub {
|
4194
|
9
|
|
|
9
|
|
12
|
my $class = $_[0];
|
4195
|
9
|
|
|
|
|
10
|
my $source = tied @{$_[1]};
|
|
9
|
|
|
|
|
15
|
|
4196
|
9
|
|
|
|
|
9
|
my $range = tied @{dwim(@_[2..$#_])};
|
|
9
|
|
|
|
|
34
|
|
4197
|
9
|
|
|
|
|
66
|
my $fetch = $source->can('FETCH');
|
4198
|
9
|
50
|
|
|
|
40
|
if (my $ranger = $range->can('range')) {
|
4199
|
9
|
|
|
|
|
14
|
my ($drop, $step, $take) = $ranger->();
|
4200
|
9
|
50
|
|
|
|
21
|
if ($step == 1) {
|
4201
|
9
|
|
|
|
|
75
|
while (my $slicer = $source->can('slice')) {
|
4202
|
0
|
|
|
|
|
0
|
my ($pdrop, $ptake) = $slicer->();
|
4203
|
|
|
|
|
|
|
|
4204
|
0
|
|
|
|
|
0
|
$take = min $take, $ptake - $drop;
|
4205
|
0
|
|
|
|
|
0
|
$drop += $pdrop;
|
4206
|
|
|
|
|
|
|
|
4207
|
0
|
|
|
|
|
0
|
$source = $source->source;
|
4208
|
0
|
|
|
|
|
0
|
$fetch = $source->can('FETCH');
|
4209
|
|
|
|
|
|
|
}
|
4210
|
9
|
|
|
|
|
20
|
$take = min $take, $source->fsize - $drop;
|
4211
|
9
|
50
|
|
|
|
23
|
$take > 0 or $take = 0;
|
4212
|
0
|
|
|
0
|
|
0
|
return curse {
|
4213
|
|
|
|
|
|
|
FETCH => ($drop == 0
|
4214
|
|
|
|
|
|
|
? $fetch
|
4215
|
|
|
|
|
|
|
: sub {$fetch->(undef, $_[1] + $drop)}),
|
4216
|
9
|
|
|
9
|
|
18
|
$source->mutable ? do {
|
4217
|
0
|
|
|
|
|
0
|
my $size = $source->fsize;
|
4218
|
0
|
|
|
|
|
0
|
$source->tail_size($size);
|
4219
|
0
|
|
|
0
|
|
0
|
fsize => sub {min $take, $size - $drop},
|
4220
|
0
|
|
|
0
|
|
0
|
mutable => sub {1}
|
4221
|
0
|
|
|
|
|
0
|
} : (
|
4222
|
|
|
|
|
|
|
fsize => sub {$take}
|
4223
|
0
|
|
|
0
|
|
0
|
),
|
4224
|
|
|
|
|
|
|
source => sub {$source},
|
4225
|
0
|
|
|
0
|
|
0
|
slice => sub {$drop, $take},
|
4226
|
9
|
50
|
|
|
|
72
|
} => $class
|
|
|
50
|
|
|
|
|
|
4227
|
|
|
|
|
|
|
}
|
4228
|
|
|
|
|
|
|
}
|
4229
|
0
|
|
|
|
|
0
|
my $index = $range->can('FETCH');
|
4230
|
0
|
|
|
0
|
|
0
|
curse {
|
4231
|
|
|
|
|
|
|
FETCH => sub {$fetch->(undef, $index->(undef, $_[1]))},
|
4232
|
0
|
|
|
0
|
|
0
|
source => sub {$source},
|
4233
|
0
|
|
|
0
|
|
0
|
$range->mutable ? (
|
4234
|
|
|
|
|
|
|
fsize => $range->can('fsize'),
|
4235
|
|
|
|
|
|
|
mutable => sub {1}
|
4236
|
0
|
0
|
|
|
|
0
|
) : do {
|
4237
|
0
|
|
|
|
|
0
|
my $size = min $range->fsize, $source->fsize - $index->(undef, 0) - 1;
|
4238
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size}
|
4239
|
0
|
|
|
|
|
0
|
},
|
4240
|
|
|
|
|
|
|
} => $class
|
4241
|
|
|
|
|
|
|
},
|
4242
|
9
|
|
|
9
|
|
14
|
mutable => sub {0};
|
4243
|
|
|
|
|
|
|
|
4244
|
|
|
|
|
|
|
|
4245
|
|
|
|
|
|
|
=item test C< {CODE} [ARGS_FOR_GEN] >
|
4246
|
|
|
|
|
|
|
|
4247
|
|
|
|
|
|
|
C< test > attaches a code block to a generator. it takes arguments suitable for
|
4248
|
|
|
|
|
|
|
the C< gen > function. accessing an element of the returned generator will call
|
4249
|
|
|
|
|
|
|
the code block first with the element in C< $_ >, and if it returns true, the
|
4250
|
|
|
|
|
|
|
element is returned, otherwise an empty list (undef in scalar context) is
|
4251
|
|
|
|
|
|
|
returned.
|
4252
|
|
|
|
|
|
|
|
4253
|
|
|
|
|
|
|
when accessing a slice of a tested generator, if you use the C<< ->(x .. y) >>
|
4254
|
|
|
|
|
|
|
syntax, the the empty lists will collapse and you may receive a shorter slice.
|
4255
|
|
|
|
|
|
|
an array dereference slice will always be the size you ask for, and will have
|
4256
|
|
|
|
|
|
|
undef in each failed slot
|
4257
|
|
|
|
|
|
|
|
4258
|
|
|
|
|
|
|
the C<< $gen->nxt >> method is a version of C<< $gen->next >> that continues
|
4259
|
|
|
|
|
|
|
to call C<< ->next >> until a call returns a value, or the generator
|
4260
|
|
|
|
|
|
|
is exhausted. this makes the C<< ->nxt >> method the easiest way to iterate
|
4261
|
|
|
|
|
|
|
over only the passing values of a tested generator.
|
4262
|
|
|
|
|
|
|
|
4263
|
|
|
|
|
|
|
=cut
|
4264
|
|
|
|
|
|
|
|
4265
|
|
|
|
|
|
|
sub test (&;$$$) {
|
4266
|
0
|
|
|
0
|
1
|
0
|
my $code = shift;
|
4267
|
0
|
0
|
|
0
|
|
0
|
unshift @_, sub {$code->() ? $_ : ()};
|
|
0
|
|
|
|
|
0
|
|
4268
|
0
|
|
|
|
|
0
|
goto &gen
|
4269
|
|
|
|
|
|
|
}
|
4270
|
|
|
|
|
|
|
|
4271
|
|
|
|
|
|
|
|
4272
|
|
|
|
|
|
|
=item cache C< {CODE} >
|
4273
|
|
|
|
|
|
|
|
4274
|
|
|
|
|
|
|
=item cache C< GENERATOR >
|
4275
|
|
|
|
|
|
|
|
4276
|
|
|
|
|
|
|
=item cache C<< list => ... >>
|
4277
|
|
|
|
|
|
|
|
4278
|
|
|
|
|
|
|
C< cache > will return a cached version of the generators returned by functions
|
4279
|
|
|
|
|
|
|
in this package. when passed a code reference, cache returns a memoized code ref
|
4280
|
|
|
|
|
|
|
(arguments joined with C< $; >). when in 'list' mode, the source is in list
|
4281
|
|
|
|
|
|
|
context, otherwise scalar context is used.
|
4282
|
|
|
|
|
|
|
|
4283
|
|
|
|
|
|
|
my $gen = cache gen {slow($_)} \@source; # calls = 0
|
4284
|
|
|
|
|
|
|
|
4285
|
|
|
|
|
|
|
print $gen->[123]; # calls += 1
|
4286
|
|
|
|
|
|
|
...
|
4287
|
|
|
|
|
|
|
print @$gen[123, 456] # calls += 1
|
4288
|
|
|
|
|
|
|
|
4289
|
|
|
|
|
|
|
=cut
|
4290
|
|
|
|
|
|
|
|
4291
|
|
|
|
|
|
|
sub cache ($;$) {
|
4292
|
0
|
|
|
0
|
1
|
0
|
my $gen = pop;
|
4293
|
0
|
|
|
|
|
0
|
my $list = "@_" =~ /list/i;
|
4294
|
0
|
0
|
|
|
|
0
|
if (isagen $gen) {
|
|
|
0
|
|
|
|
|
|
4295
|
0
|
|
|
|
|
0
|
tiegen Cache => tied @$gen, $list
|
4296
|
0
|
|
|
|
|
0
|
} elsif (ref $gen eq 'CODE') {
|
4297
|
0
|
|
|
|
|
0
|
my %cache;
|
4298
|
0
|
|
|
|
|
0
|
my $sep = $;;
|
4299
|
0
|
|
0
|
|
|
0
|
$list
|
4300
|
0
|
|
|
0
|
|
0
|
? sub {@{$cache{join $sep => @_} ||= cap &$gen}}
|
4301
|
|
|
|
|
|
|
: sub {
|
4302
|
0
|
|
|
0
|
|
0
|
my $arg = join $sep => @_;
|
4303
|
0
|
0
|
|
|
|
0
|
exists $cache{$arg}
|
4304
|
|
|
|
|
|
|
? $cache{$arg}
|
4305
|
|
|
|
|
|
|
:($cache{$arg} = &$gen)
|
4306
|
|
|
|
|
|
|
}
|
4307
|
0
|
0
|
|
|
|
0
|
} else {croak 'cache takes generator or coderef'}
|
4308
|
|
|
|
|
|
|
}
|
4309
|
|
|
|
|
|
|
generator Cache => sub {
|
4310
|
0
|
|
|
0
|
|
0
|
my ($class, $source, $list) = @_;
|
4311
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize, %cache) = $source->closures;
|
4312
|
|
|
|
|
|
|
curse {
|
4313
|
|
|
|
|
|
|
FETCH => (
|
4314
|
|
|
|
|
|
|
$list ? sub {
|
4315
|
0
|
|
0
|
0
|
|
0
|
@{$cache{$_[1]} ||= cap $fetch->(undef, $_[1])}
|
|
0
|
|
|
|
|
0
|
|
4316
|
|
|
|
|
|
|
} : sub {
|
4317
|
0
|
0
|
|
0
|
|
0
|
exists $cache{$_[1]}
|
4318
|
|
|
|
|
|
|
? $cache{$_[1]}
|
4319
|
|
|
|
|
|
|
:($cache{$_[1]} = $fetch->(undef, $_[1]))
|
4320
|
|
|
|
|
|
|
}
|
4321
|
0
|
|
|
0
|
|
0
|
),
|
4322
|
|
|
|
|
|
|
fsize => $fsize,
|
4323
|
|
|
|
|
|
|
source => sub {$source},
|
4324
|
0
|
|
|
0
|
|
0
|
cached => sub {\%cache},
|
4325
|
0
|
0
|
|
|
|
0
|
} => $class
|
4326
|
|
|
|
|
|
|
},
|
4327
|
0
|
|
|
0
|
|
0
|
purge => sub {%{$_[0]->cached} = ()};
|
|
0
|
|
|
|
|
0
|
|
4328
|
|
|
|
|
|
|
|
4329
|
|
|
|
|
|
|
|
4330
|
|
|
|
|
|
|
=item flip C< GENERATOR >
|
4331
|
|
|
|
|
|
|
|
4332
|
|
|
|
|
|
|
C< flip > is C< reverse > for generators. the C<< ->apply >> method is called on
|
4333
|
|
|
|
|
|
|
C< GENERATOR >. C<< $gen->flip >> and C<< $gen->reverse >> do the same thing.
|
4334
|
|
|
|
|
|
|
|
4335
|
|
|
|
|
|
|
flip gen {$_**2} 0, 10 ~~ gen {$_**2} 10, 0, -1
|
4336
|
|
|
|
|
|
|
|
4337
|
|
|
|
|
|
|
=cut
|
4338
|
|
|
|
|
|
|
|
4339
|
|
|
|
|
|
|
sub flip ($) {
|
4340
|
0
|
0
|
|
0
|
1
|
0
|
croak 'not generator' unless isagen $_[0];
|
4341
|
0
|
|
|
|
|
0
|
my $gen = tied @{$_[0]};
|
|
0
|
|
|
|
|
0
|
|
4342
|
0
|
0
|
|
|
|
0
|
$_[0]->apply if $gen->mutable;
|
4343
|
0
|
|
|
|
|
0
|
tiegen Flip => $gen
|
4344
|
|
|
|
|
|
|
}
|
4345
|
|
|
|
|
|
|
generator Flip => sub {
|
4346
|
0
|
|
|
0
|
|
0
|
my ($class, $source) = @_;
|
4347
|
0
|
|
|
|
|
0
|
my $size = $source->fsize;
|
4348
|
0
|
|
|
|
|
0
|
my $end = $size - 1;
|
4349
|
0
|
|
|
|
|
0
|
my $fetch = $source->can('FETCH');
|
4350
|
0
|
|
|
0
|
|
0
|
curse {
|
4351
|
|
|
|
|
|
|
FETCH => sub {$fetch->(undef, $end - $_[1])},
|
4352
|
0
|
|
|
0
|
|
0
|
fsize => $source->can('fsize'),
|
4353
|
|
|
|
|
|
|
source => sub {$source}
|
4354
|
0
|
|
|
|
|
0
|
} => $class
|
4355
|
|
|
|
|
|
|
};
|
4356
|
|
|
|
|
|
|
|
4357
|
|
|
|
|
|
|
|
4358
|
|
|
|
|
|
|
=item expand C< GENERATOR >
|
4359
|
|
|
|
|
|
|
|
4360
|
|
|
|
|
|
|
=item expand C< SCALE GENERATOR >
|
4361
|
|
|
|
|
|
|
|
4362
|
|
|
|
|
|
|
C< expand > scales a generator with elements that return equal sized lists. it
|
4363
|
|
|
|
|
|
|
can be passed a list length, or will automatically determine it from the length
|
4364
|
|
|
|
|
|
|
of the list returned by the first element of the generator. C< expand >
|
4365
|
|
|
|
|
|
|
implicitly caches its returned generator.
|
4366
|
|
|
|
|
|
|
|
4367
|
|
|
|
|
|
|
my $multigen = gen {$_, $_/2, $_/4} 1, 10; # each element returns a list
|
4368
|
|
|
|
|
|
|
|
4369
|
|
|
|
|
|
|
say join ' '=> $$multigen[0]; # 0.25 # only last element
|
4370
|
|
|
|
|
|
|
say join ' '=> &$multigen(0); # 1 0.5 0.25 # works
|
4371
|
|
|
|
|
|
|
say scalar @$multigen; # 10
|
4372
|
|
|
|
|
|
|
say $multigen->size; # 10
|
4373
|
|
|
|
|
|
|
|
4374
|
|
|
|
|
|
|
my $expanded = expand $multigen;
|
4375
|
|
|
|
|
|
|
|
4376
|
|
|
|
|
|
|
say join ' '=> @$expanded[0 .. 2]; # 1 0.5 0.25
|
4377
|
|
|
|
|
|
|
say join ' '=> &$expanded(0 .. 2); # 1 0.5 0.25
|
4378
|
|
|
|
|
|
|
say scalar @$expanded; # 30
|
4379
|
|
|
|
|
|
|
say $expanded->size; # 30
|
4380
|
|
|
|
|
|
|
|
4381
|
|
|
|
|
|
|
my $expanded = expand gen {$_, $_/2, $_/4} 1, 10; # in one line
|
4382
|
|
|
|
|
|
|
|
4383
|
|
|
|
|
|
|
C< expand > can also scale a generator that returns array references:
|
4384
|
|
|
|
|
|
|
|
4385
|
|
|
|
|
|
|
my $refs = gen {[$_, $_.$_]} 3;
|
4386
|
|
|
|
|
|
|
|
4387
|
|
|
|
|
|
|
say $refs->join(', '); # ARRAY(0x272514), ARRAY(0x272524), ARRAY(0x272544)
|
4388
|
|
|
|
|
|
|
say $refs->expand->join(', '); # 0, 00, 1, 11, 2, 22
|
4389
|
|
|
|
|
|
|
|
4390
|
|
|
|
|
|
|
C< expand > in array ref mode is the same as calling the C<< ->deref >> method.
|
4391
|
|
|
|
|
|
|
|
4392
|
|
|
|
|
|
|
=cut
|
4393
|
|
|
|
|
|
|
|
4394
|
|
|
|
|
|
|
sub expand ($;$) {
|
4395
|
0
|
|
|
0
|
1
|
0
|
my $gen = pop;
|
4396
|
0
|
|
|
|
|
0
|
my ($scale, @first);
|
4397
|
0
|
0
|
|
|
|
0
|
croak "not generator" unless isagen $gen;
|
4398
|
0
|
0
|
|
|
|
0
|
if (@_) {
|
4399
|
0
|
|
|
|
|
0
|
$scale = shift;
|
4400
|
|
|
|
|
|
|
}
|
4401
|
|
|
|
|
|
|
else {
|
4402
|
0
|
|
|
|
|
0
|
$scale = @first = $gen->head;
|
4403
|
0
|
0
|
0
|
|
|
0
|
if (@first == 1 and ref $first[0] eq 'ARRAY') {
|
4404
|
0
|
|
|
|
|
0
|
return $gen->deref
|
4405
|
|
|
|
|
|
|
}
|
4406
|
|
|
|
|
|
|
}
|
4407
|
0
|
|
|
|
|
0
|
tiegen Expand => tied @$gen, $scale, @first
|
4408
|
|
|
|
|
|
|
}
|
4409
|
|
|
|
|
|
|
generator Expand => sub {
|
4410
|
0
|
|
|
0
|
|
0
|
my ($class, $source, $scale) = splice @_, 0, 3;
|
4411
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize, %cache) = $source->closures;
|
4412
|
0
|
0
|
|
|
|
0
|
@cache{0 .. $#_} = @_ if @_;
|
4413
|
0
|
|
|
|
|
0
|
my ($src_i, $ret_i);
|
4414
|
|
|
|
|
|
|
curse {
|
4415
|
|
|
|
|
|
|
FETCH => sub {
|
4416
|
0
|
0
|
|
0
|
|
0
|
unless (exists $cache{$_[1]}) {
|
4417
|
0
|
|
|
|
|
0
|
$src_i = int ($_[1] / $scale);
|
4418
|
0
|
|
|
|
|
0
|
$ret_i = $src_i * $scale;
|
4419
|
0
|
|
|
|
|
0
|
@cache{$ret_i .. $ret_i + $scale - 1} = $fetch->(undef, $src_i);
|
4420
|
|
|
|
|
|
|
}
|
4421
|
0
|
|
|
|
|
0
|
$cache{$_[1]}
|
4422
|
|
|
|
|
|
|
},
|
4423
|
0
|
|
|
0
|
|
0
|
fsize => (
|
4424
|
|
|
|
|
|
|
$source->mutable
|
4425
|
|
|
|
|
|
|
? sub {$scale * $fsize->()}
|
4426
|
0
|
|
|
0
|
|
0
|
: do {
|
4427
|
0
|
|
|
|
|
0
|
my $size = $scale * $fsize->();
|
4428
|
0
|
|
|
0
|
|
0
|
sub {$size}
|
4429
|
0
|
|
|
|
|
0
|
}
|
4430
|
|
|
|
|
|
|
),
|
4431
|
|
|
|
|
|
|
source => sub {$source},
|
4432
|
0
|
|
|
0
|
|
0
|
cached => sub {\%cache},
|
4433
|
0
|
|
|
0
|
|
0
|
purge => sub {%cache = ()},
|
4434
|
0
|
0
|
|
|
|
0
|
} => $class
|
4435
|
|
|
|
|
|
|
};
|
4436
|
|
|
|
|
|
|
|
4437
|
|
|
|
|
|
|
|
4438
|
|
|
|
|
|
|
=item contract C< SCALE GENERATOR >
|
4439
|
|
|
|
|
|
|
|
4440
|
|
|
|
|
|
|
C< contract > is the inverse of C< expand >
|
4441
|
|
|
|
|
|
|
|
4442
|
|
|
|
|
|
|
also called C< collect >
|
4443
|
|
|
|
|
|
|
|
4444
|
|
|
|
|
|
|
=cut
|
4445
|
|
|
|
|
|
|
|
4446
|
|
|
|
|
|
|
sub contract ($$) {
|
4447
|
0
|
|
|
0
|
1
|
0
|
my ($scale, $gen) = @_;
|
4448
|
0
|
0
|
|
|
|
0
|
croak '$_[0] >= 1' if $scale < 1;
|
4449
|
0
|
0
|
|
|
|
0
|
croak 'not generator' unless isagen $gen;
|
4450
|
0
|
|
|
0
|
|
0
|
$scale == 1
|
4451
|
|
|
|
|
|
|
? $gen
|
4452
|
0
|
0
|
|
|
|
0
|
: gen {&$gen($_ .. $_ + $scale - 1)} 0 => $gen->size - 1, $scale
|
4453
|
|
|
|
|
|
|
}
|
4454
|
10
|
|
|
10
|
|
3798
|
BEGIN {*collect = \&contract}
|
4455
|
|
|
|
|
|
|
|
4456
|
|
|
|
|
|
|
|
4457
|
|
|
|
|
|
|
=item scan C< {CODE} GENERATOR >
|
4458
|
|
|
|
|
|
|
|
4459
|
|
|
|
|
|
|
=item scan C< {CODE} LIST >
|
4460
|
|
|
|
|
|
|
|
4461
|
|
|
|
|
|
|
C< scan > is a C< reduce > that builds a list of all the intermediate values.
|
4462
|
|
|
|
|
|
|
C< scan > returns a generator, and is the function behind the C<< <[..+]> >>
|
4463
|
|
|
|
|
|
|
globstring reduction operator.
|
4464
|
|
|
|
|
|
|
|
4465
|
|
|
|
|
|
|
(scan {$a * $b} <1, 1..>)->say(8); # 1 1 2 6 24 120 720 5040 40320
|
4466
|
|
|
|
|
|
|
|
4467
|
|
|
|
|
|
|
say <[..*] 1, 1..>->str(8); # 1 1 2 6 24 120 720 5040 40320
|
4468
|
|
|
|
|
|
|
|
4469
|
|
|
|
|
|
|
say <1, 1..>->scan('*')->str(8); # 1 1 2 6 24 120 720 5040 40320
|
4470
|
|
|
|
|
|
|
|
4471
|
|
|
|
|
|
|
say <[..*]>->(1, 1 .. 7)->str; # 1 1 2 6 24 120 720 5040 40320
|
4472
|
|
|
|
|
|
|
|
4473
|
|
|
|
|
|
|
you can even use the C<< ->code >> method to tersely define a factorial
|
4474
|
|
|
|
|
|
|
function:
|
4475
|
|
|
|
|
|
|
|
4476
|
|
|
|
|
|
|
*factorial = <[..*] 1, 1..>->code;
|
4477
|
|
|
|
|
|
|
|
4478
|
|
|
|
|
|
|
say factorial(5); # 120
|
4479
|
|
|
|
|
|
|
|
4480
|
|
|
|
|
|
|
a stream version C< scan_stream > is also available.
|
4481
|
|
|
|
|
|
|
|
4482
|
|
|
|
|
|
|
=cut
|
4483
|
|
|
|
|
|
|
|
4484
|
|
|
|
|
|
|
sub scan (&@) {
|
4485
|
7
|
50
|
|
7
|
1
|
18
|
local *iterate = *iterate_stream if $STREAM;
|
4486
|
7
|
|
|
|
|
10
|
my $binop = shift;
|
4487
|
7
|
|
33
|
|
|
28
|
my $gen = (@_ == 1 && List::Gen::isagen($_[0]) or &makegen(\@_));
|
4488
|
7
|
|
|
|
|
13
|
my $last;
|
4489
|
7
|
50
|
|
|
|
15
|
if ($binop->$cv_wants_2_args) {
|
4490
|
7
|
100
|
|
58
|
|
37
|
iterate {$last = defined $last ? $binop->($last, $_) : $_} $gen
|
|
58
|
|
|
|
|
682
|
|
4491
|
|
|
|
|
|
|
} else {
|
4492
|
0
|
|
|
|
|
0
|
my ($a, $b) = $binop->$cv_ab_ref;
|
4493
|
0
|
0
|
|
0
|
|
0
|
iterate {$last = defined $last ? do {
|
4494
|
0
|
|
|
|
|
0
|
local (*$a, *$b) = \($last, $_);
|
4495
|
0
|
|
|
|
|
0
|
$binop->()
|
4496
|
0
|
|
|
|
|
0
|
} : $_} $gen
|
4497
|
|
|
|
|
|
|
}
|
4498
|
|
|
|
|
|
|
}
|
4499
|
|
|
|
|
|
|
sub scan_stream (&@) {
|
4500
|
0
|
|
|
0
|
0
|
0
|
local *iterate = *iterate_stream;
|
4501
|
0
|
|
|
|
|
0
|
&scan
|
4502
|
|
|
|
|
|
|
}
|
4503
|
10
|
|
|
10
|
|
4985
|
BEGIN {*scanS = *scan_stream}
|
4504
|
|
|
|
|
|
|
|
4505
|
|
|
|
|
|
|
|
4506
|
|
|
|
|
|
|
=item overlay C< GENERATOR PAIRS >
|
4507
|
|
|
|
|
|
|
|
4508
|
|
|
|
|
|
|
overlay allows you to replace the values of specific generator cells. to set
|
4509
|
|
|
|
|
|
|
the values, either pass the overlay constructor a list of pairs in the form
|
4510
|
|
|
|
|
|
|
C<< index => value, ... >>, or assign values to the returned generator using
|
4511
|
|
|
|
|
|
|
normal array ref syntax
|
4512
|
|
|
|
|
|
|
|
4513
|
|
|
|
|
|
|
my $fib; $fib = overlay gen {$$fib[$_ - 1] + $$fib[$_ - 2]};
|
4514
|
|
|
|
|
|
|
@$fib[0, 1] = (0, 1);
|
4515
|
|
|
|
|
|
|
|
4516
|
|
|
|
|
|
|
# or
|
4517
|
|
|
|
|
|
|
my $fib; $fib = gen {$$fib[$_ - 1] + $$fib[$_ - 2]}
|
4518
|
|
|
|
|
|
|
->overlay( 0 => 0, 1 => 1 );
|
4519
|
|
|
|
|
|
|
|
4520
|
|
|
|
|
|
|
print "@$fib[0 .. 15]"; # '0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'
|
4521
|
|
|
|
|
|
|
|
4522
|
|
|
|
|
|
|
=cut
|
4523
|
|
|
|
|
|
|
|
4524
|
|
|
|
|
|
|
sub overlay ($%) {
|
4525
|
0
|
0
|
|
0
|
1
|
0
|
isagen (my $source = shift)
|
4526
|
|
|
|
|
|
|
or croak '$_[0] to overlay must be a generator';
|
4527
|
0
|
|
|
|
|
0
|
tiegen Overlay => tied @$source, @_
|
4528
|
|
|
|
|
|
|
}
|
4529
|
|
|
|
|
|
|
generator Overlay => sub {
|
4530
|
0
|
|
|
0
|
|
0
|
my ($class, $source, %overlay) = @_;
|
4531
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = $source->closures;
|
4532
|
|
|
|
|
|
|
curse {
|
4533
|
|
|
|
|
|
|
FETCH => sub {
|
4534
|
0
|
0
|
|
0
|
|
0
|
exists $overlay{$_[1]}
|
4535
|
|
|
|
|
|
|
? $overlay{$_[1]}
|
4536
|
|
|
|
|
|
|
: $fetch->(undef, $_[1])
|
4537
|
|
|
|
|
|
|
},
|
4538
|
0
|
|
|
0
|
|
0
|
STORE => sub {$overlay{$_[1]} = $_[2]},
|
4539
|
0
|
|
|
0
|
|
0
|
fsize => $fsize,
|
4540
|
|
|
|
|
|
|
source => sub {$source}
|
4541
|
0
|
|
|
|
|
0
|
} => $class
|
4542
|
|
|
|
|
|
|
};
|
4543
|
|
|
|
|
|
|
|
4544
|
|
|
|
|
|
|
|
4545
|
|
|
|
|
|
|
=item recursive C< [NAME] GENERATOR >
|
4546
|
|
|
|
|
|
|
|
4547
|
|
|
|
|
|
|
C< recursive > defines a subroutine named C< self(...) > or C< NAME(...) >
|
4548
|
|
|
|
|
|
|
during generator execution. when called with no arguments it returns the
|
4549
|
|
|
|
|
|
|
generator. when called with one or more numeric arguments, it fetches those
|
4550
|
|
|
|
|
|
|
indices from the generator. when called with a generator, it returns a lazy
|
4551
|
|
|
|
|
|
|
slice from the source generator. since the subroutine created by C< recursive >
|
4552
|
|
|
|
|
|
|
is installed at runtime, you must call the subroutine with parenthesis.
|
4553
|
|
|
|
|
|
|
|
4554
|
|
|
|
|
|
|
my $fib = gen {self($_ - 1) + self($_ - 2)}
|
4555
|
|
|
|
|
|
|
->overlay( 0 => 0, 1 => 1 )
|
4556
|
|
|
|
|
|
|
->cache
|
4557
|
|
|
|
|
|
|
->recursive;
|
4558
|
|
|
|
|
|
|
|
4559
|
|
|
|
|
|
|
print "@$fib[0 .. 15]"; # '0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'
|
4560
|
|
|
|
|
|
|
|
4561
|
|
|
|
|
|
|
when used as a method, C<< $gen->recursive >> can be shortened to C<< $gen->rec >>.
|
4562
|
|
|
|
|
|
|
|
4563
|
|
|
|
|
|
|
my $fib = ([0, 1] + iterate {sum fib($_, $_ + 1)})->rec('fib');
|
4564
|
|
|
|
|
|
|
|
4565
|
|
|
|
|
|
|
print "@$fib[0 .. 15]"; # '0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610'
|
4566
|
|
|
|
|
|
|
|
4567
|
|
|
|
|
|
|
of course the fibonacci sequence is better written with the glob syntax as
|
4568
|
|
|
|
|
|
|
C<< <0, 1, *+*...> >> which is compiled into something similar to the example
|
4569
|
|
|
|
|
|
|
with C< iterate > above.
|
4570
|
|
|
|
|
|
|
|
4571
|
|
|
|
|
|
|
=cut
|
4572
|
|
|
|
|
|
|
|
4573
|
|
|
|
|
|
|
sub recursive {
|
4574
|
0
|
0
|
|
0
|
1
|
0
|
isagen (my $source = pop)
|
4575
|
|
|
|
|
|
|
or croak '$_[0] to recursive must be a generator';
|
4576
|
0
|
|
|
|
|
0
|
tiegen Recursive => $source, tied @$source, scalar caller, @_;
|
4577
|
|
|
|
|
|
|
}
|
4578
|
|
|
|
|
|
|
generator Recursive => sub {
|
4579
|
0
|
|
|
0
|
|
0
|
my ($class, $gen, $source) = @_;
|
4580
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = $source->closures;
|
4581
|
0
|
|
|
|
|
0
|
my $caller = do {
|
4582
|
10
|
|
|
10
|
|
90
|
no strict 'refs';
|
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
1442
|
|
4583
|
0
|
0
|
|
|
|
0
|
\*{$_[3].'::'.(@_ > 4 ? $_[4] : 'self')}
|
|
0
|
|
|
|
|
0
|
|
4584
|
|
|
|
|
|
|
};
|
4585
|
0
|
|
|
|
|
0
|
my $code = $gen->code;
|
4586
|
0
|
0
|
|
0
|
|
0
|
my $self = sub {@_ ? &$code : $gen};
|
|
0
|
|
|
|
|
0
|
|
4587
|
|
|
|
|
|
|
curse {
|
4588
|
|
|
|
|
|
|
FETCH => sub {
|
4589
|
10
|
|
|
10
|
|
59
|
no warnings 'redefine';
|
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
9181
|
|
4590
|
0
|
|
|
0
|
|
0
|
local *$caller = $self;
|
4591
|
0
|
|
|
|
|
0
|
$fetch->(undef, $_[1])
|
4592
|
|
|
|
|
|
|
},
|
4593
|
0
|
|
|
0
|
|
0
|
fsize => $fsize,
|
4594
|
|
|
|
|
|
|
source => sub {$source}
|
4595
|
0
|
|
|
|
|
0
|
} => $class
|
4596
|
|
|
|
|
|
|
};
|
4597
|
|
|
|
|
|
|
|
4598
|
|
|
|
|
|
|
|
4599
|
|
|
|
|
|
|
=back
|
4600
|
|
|
|
|
|
|
|
4601
|
|
|
|
|
|
|
=head2 mutable generators
|
4602
|
|
|
|
|
|
|
|
4603
|
|
|
|
|
|
|
=over 4
|
4604
|
|
|
|
|
|
|
|
4605
|
|
|
|
|
|
|
=item filter C< {CODE} [ARGS_FOR_GEN] >
|
4606
|
|
|
|
|
|
|
|
4607
|
|
|
|
|
|
|
C< filter > is a lazy version of C< grep > which attaches a code block to a
|
4608
|
|
|
|
|
|
|
generator. it returns a generator that will test elements with the code
|
4609
|
|
|
|
|
|
|
block on demand. C< filter > processes its argument list the same way C< gen >
|
4610
|
|
|
|
|
|
|
does.
|
4611
|
|
|
|
|
|
|
|
4612
|
|
|
|
|
|
|
C< filter > provides the functionality of the identical C<< ->filter(...) >> and
|
4613
|
|
|
|
|
|
|
C<< ->grep(...) >> methods.
|
4614
|
|
|
|
|
|
|
|
4615
|
|
|
|
|
|
|
normal generators, such as those produced by C< range > or C< gen >, have a
|
4616
|
|
|
|
|
|
|
fixed length, and that is used to allow random access within the range. however,
|
4617
|
|
|
|
|
|
|
there is no way to know how many elements will pass a filter. because of this,
|
4618
|
|
|
|
|
|
|
random access within the filter is not always C< O(1) >. C< filter > will
|
4619
|
|
|
|
|
|
|
attempt to be as lazy as possible, but to access the 10th element of a filter,
|
4620
|
|
|
|
|
|
|
the first 9 passing elements must be found first. depending on the coderef and
|
4621
|
|
|
|
|
|
|
the source, the filter may need to process significantly more elements from its
|
4622
|
|
|
|
|
|
|
source than just 10.
|
4623
|
|
|
|
|
|
|
|
4624
|
|
|
|
|
|
|
in addition, since filters don't know their true size, entire filter arrays do
|
4625
|
|
|
|
|
|
|
not expand to the correct number of elements in list context. to correct this,
|
4626
|
|
|
|
|
|
|
call the C<< ->apply >> method which will test the filter on all of its source
|
4627
|
|
|
|
|
|
|
elements. after that, the filter will return a properly sized array. calling
|
4628
|
|
|
|
|
|
|
C<< ->apply >> on an infinite (or very large) range wouldn't be a good idea. if
|
4629
|
|
|
|
|
|
|
you are using C<< ->apply >> frequently, you should probably just be using
|
4630
|
|
|
|
|
|
|
C< grep >. you can call C<< ->apply >> on any stack of generator functions, it
|
4631
|
|
|
|
|
|
|
will start from the deepest filter and move up.
|
4632
|
|
|
|
|
|
|
|
4633
|
|
|
|
|
|
|
the method C<< ->all >> will first call C<< ->apply >> on itself and then return
|
4634
|
|
|
|
|
|
|
the complete list
|
4635
|
|
|
|
|
|
|
|
4636
|
|
|
|
|
|
|
filters implicitly cache their values. accessing any element below the highest
|
4637
|
|
|
|
|
|
|
element already accessed is C< O(1) >.
|
4638
|
|
|
|
|
|
|
|
4639
|
|
|
|
|
|
|
accessing individual elements or slices works as you would expect.
|
4640
|
|
|
|
|
|
|
|
4641
|
|
|
|
|
|
|
my $filter = filter {$_ % 2} 0, 100;
|
4642
|
|
|
|
|
|
|
|
4643
|
|
|
|
|
|
|
say $#$filter; # incorrectly reports 100
|
4644
|
|
|
|
|
|
|
|
4645
|
|
|
|
|
|
|
say "@$filter[5 .. 10]"; # reads the source range up to element 23
|
4646
|
|
|
|
|
|
|
# prints 11 13 15 17 19 21
|
4647
|
|
|
|
|
|
|
|
4648
|
|
|
|
|
|
|
say $#$filter; # reports 88, closer but still wrong
|
4649
|
|
|
|
|
|
|
|
4650
|
|
|
|
|
|
|
$filter->apply; # reads remaining elements from the source
|
4651
|
|
|
|
|
|
|
|
4652
|
|
|
|
|
|
|
say $#$filter; # 49 as it should be
|
4653
|
|
|
|
|
|
|
|
4654
|
|
|
|
|
|
|
note: C< filter > now reads one element past the last element accessed, this
|
4655
|
|
|
|
|
|
|
allows filters to behave properly when dereferenced in a foreach loop (without
|
4656
|
|
|
|
|
|
|
having to call C<< ->apply >>). if you prefer the old behavior, set
|
4657
|
|
|
|
|
|
|
C< $List::Gen::LOOKAHEAD = 0 > or use C< filter_ ... >
|
4658
|
|
|
|
|
|
|
|
4659
|
|
|
|
|
|
|
=cut
|
4660
|
|
|
|
|
|
|
|
4661
|
|
|
|
|
|
|
sub filter (&;$$$) {
|
4662
|
0
|
0
|
|
0
|
1
|
0
|
goto &filter_stream if $STREAM;
|
4663
|
0
|
|
|
|
|
0
|
tiegen Filter => shift, tied @{&dwim}
|
|
0
|
|
|
|
|
0
|
|
4664
|
|
|
|
|
|
|
}
|
4665
|
|
|
|
|
|
|
mutable_gen Filter => sub {
|
4666
|
0
|
|
|
0
|
|
0
|
my ($class, $check, $source) = @_;
|
4667
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = $source->closures;
|
4668
|
0
|
|
|
|
|
0
|
my ($size, $src_size) = ($fsize->()) x 2;
|
4669
|
0
|
0
|
|
|
|
0
|
if ($source->mutable) {
|
4670
|
0
|
|
|
|
|
0
|
$source->tail_size($src_size)
|
4671
|
|
|
|
|
|
|
}
|
4672
|
0
|
|
|
0
|
|
0
|
my $when_done = sub {};
|
|
0
|
|
|
|
|
0
|
|
4673
|
0
|
|
|
|
|
0
|
my ($pos, @list, @tails) = 0;
|
4674
|
0
|
|
0
|
|
|
0
|
my $lookahead = $LOOKAHEAD || 0;
|
4675
|
|
|
|
|
|
|
curse {
|
4676
|
|
|
|
|
|
|
FETCH => sub {
|
4677
|
0
|
|
|
0
|
|
0
|
my $i = $_[1];
|
4678
|
0
|
0
|
|
|
|
0
|
unless ($i < $size) {
|
4679
|
0
|
|
|
|
|
0
|
croak "filter index '$i' out of range [0 .. ".($size - 1).']';
|
4680
|
|
|
|
|
|
|
}
|
4681
|
0
|
|
|
|
|
0
|
local *_;
|
4682
|
0
|
|
|
|
|
0
|
while ($#list < $i + $lookahead) {
|
4683
|
0
|
0
|
|
|
|
0
|
if ($pos < $src_size) {
|
4684
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, $pos);
|
4685
|
0
|
0
|
0
|
|
|
0
|
if ($pos < $src_size and $check->()) {
|
4686
|
0
|
|
|
|
|
0
|
push @list, \$_;
|
4687
|
|
|
|
|
|
|
}
|
4688
|
0
|
|
|
|
|
0
|
$pos++
|
4689
|
|
|
|
|
|
|
}
|
4690
|
|
|
|
|
|
|
else {
|
4691
|
0
|
|
|
|
|
0
|
$size = @list;
|
4692
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
4693
|
0
|
|
|
|
|
0
|
$when_done->();
|
4694
|
0
|
0
|
|
|
|
0
|
$i <= $#list ? last : return
|
4695
|
|
|
|
|
|
|
}
|
4696
|
|
|
|
|
|
|
}
|
4697
|
0
|
0
|
|
|
|
0
|
$size = $pos < $src_size
|
4698
|
|
|
|
|
|
|
? @list + ($src_size - $pos)
|
4699
|
|
|
|
|
|
|
: @list;
|
4700
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
4701
|
|
|
|
|
|
|
|
4702
|
0
|
|
|
|
|
0
|
${ $list[$i] }
|
|
0
|
|
|
|
|
0
|
|
4703
|
|
|
|
|
|
|
},
|
4704
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
4705
|
0
|
|
|
0
|
|
0
|
tail_size => sub {push @tails, \$_[1]; weaken $tails[-1]},
|
|
0
|
|
|
|
|
0
|
|
4706
|
0
|
|
|
0
|
|
0
|
source => sub {$source},
|
4707
|
0
|
|
|
0
|
|
0
|
_when_done => sub :lvalue {$when_done},
|
4708
|
0
|
|
|
|
|
0
|
} => $class
|
4709
|
|
|
|
|
|
|
};
|
4710
|
|
|
|
|
|
|
|
4711
|
|
|
|
|
|
|
sub filter_ (&;$$$) {
|
4712
|
0
|
|
|
0
|
0
|
0
|
local $LOOKAHEAD;
|
4713
|
0
|
|
|
|
|
0
|
&filter
|
4714
|
|
|
|
|
|
|
}
|
4715
|
|
|
|
|
|
|
|
4716
|
|
|
|
|
|
|
|
4717
|
|
|
|
|
|
|
=item filter_stream C< {CODE} ... >
|
4718
|
|
|
|
|
|
|
|
4719
|
|
|
|
|
|
|
as C< filter > runs, it builds up a cache of the elements that pass the filter.
|
4720
|
|
|
|
|
|
|
this enables efficient random access in the returned generator. sometimes this
|
4721
|
|
|
|
|
|
|
caching behavior causes certain algorithms to use too much memory.
|
4722
|
|
|
|
|
|
|
C< filter_stream > is a version of C< filter > that does not maintain a cache.
|
4723
|
|
|
|
|
|
|
|
4724
|
|
|
|
|
|
|
normally, access to C< *_stream > iterators must be monotonically increasing
|
4725
|
|
|
|
|
|
|
since their source can only produce values in one direction. filtering is a
|
4726
|
|
|
|
|
|
|
reversible algorithm, and subsequently filter streams are able to rewind
|
4727
|
|
|
|
|
|
|
themselves to any previous index. however, unlike C< filter >, the
|
4728
|
|
|
|
|
|
|
C< filter_stream > generator must test previously tested elements to rewind.
|
4729
|
|
|
|
|
|
|
things probably wont end well if the test code is non-deterministic or if the
|
4730
|
|
|
|
|
|
|
source values are changing.
|
4731
|
|
|
|
|
|
|
|
4732
|
|
|
|
|
|
|
when used as a method, it can be spelled C<< $gen->filter_stream(...) >> or
|
4733
|
|
|
|
|
|
|
C<< $gen->grep_stream(...) >>
|
4734
|
|
|
|
|
|
|
|
4735
|
|
|
|
|
|
|
=cut
|
4736
|
|
|
|
|
|
|
|
4737
|
|
|
|
|
|
|
sub filter_stream (&;$$$) {
|
4738
|
0
|
|
|
0
|
1
|
0
|
tiegen Filter_Stream => shift, tied @{&dwim}
|
|
0
|
|
|
|
|
0
|
|
4739
|
|
|
|
|
|
|
}
|
4740
|
10
|
|
|
10
|
|
11267
|
BEGIN {*filterS = *filter_stream}
|
4741
|
|
|
|
|
|
|
|
4742
|
|
|
|
|
|
|
mutable_gen Filter_Stream => sub {
|
4743
|
0
|
|
|
0
|
|
0
|
my ($class, $code, $src) = @_;
|
4744
|
0
|
|
|
0
|
|
0
|
my ($when_done, @tails ) = sub {};
|
|
0
|
|
|
|
|
0
|
|
4745
|
0
|
|
|
0
|
|
0
|
my $rewind = sub {};
|
|
0
|
|
|
|
|
0
|
|
4746
|
0
|
|
|
|
|
0
|
my $idx = 0;
|
4747
|
0
|
|
|
|
|
0
|
my $fetch = $src->can('FETCH');
|
4748
|
0
|
|
|
|
|
0
|
my $size =
|
4749
|
|
|
|
|
|
|
my $src_size = $src->fsize;
|
4750
|
0
|
0
|
|
|
|
0
|
$src->tail_size($src_size) if $src->mutable;
|
4751
|
0
|
|
|
|
|
0
|
my @window;
|
4752
|
0
|
|
|
|
|
0
|
my $pos = 0;
|
4753
|
0
|
|
|
|
|
0
|
my $index = 0;
|
4754
|
0
|
|
|
|
|
0
|
my ($next, $prev) = do {
|
4755
|
10
|
|
|
10
|
|
77
|
no warnings 'exiting';
|
|
10
|
|
|
|
|
22
|
|
|
10
|
|
|
|
|
17433
|
|
4756
|
|
|
|
|
|
|
sub {
|
4757
|
0
|
|
|
0
|
|
0
|
while ($pos < $src_size) {
|
4758
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, $pos);
|
4759
|
0
|
0
|
|
|
|
0
|
$pos < $src_size or last;
|
4760
|
0
|
|
|
|
|
0
|
$pos++;
|
4761
|
0
|
0
|
|
|
|
0
|
if (&$code) {
|
4762
|
0
|
|
|
|
|
0
|
$idx++;
|
4763
|
0
|
0
|
|
|
|
0
|
$pos = $src_size if $pos > $src_size;
|
4764
|
0
|
|
|
|
|
0
|
return $_
|
4765
|
|
|
|
|
|
|
}
|
4766
|
|
|
|
|
|
|
}
|
4767
|
0
|
|
|
|
|
0
|
$pos = $src_size;
|
4768
|
|
|
|
|
|
|
last outer
|
4769
|
0
|
|
|
|
|
0
|
},
|
4770
|
|
|
|
|
|
|
sub {
|
4771
|
0
|
|
|
0
|
|
0
|
while ($pos > 0) {
|
4772
|
0
|
|
|
|
|
0
|
*_ = \$fetch->(undef, --$pos);
|
4773
|
0
|
0
|
|
|
|
0
|
if (&$code) {
|
4774
|
0
|
|
|
|
|
0
|
$idx--;
|
4775
|
0
|
0
|
|
|
|
0
|
$index = $idx = $pos = 0 if $pos < 0;
|
4776
|
0
|
|
|
|
|
0
|
return $_
|
4777
|
|
|
|
|
|
|
}
|
4778
|
|
|
|
|
|
|
}
|
4779
|
0
|
|
|
|
|
0
|
$index = $idx = $pos = 0;
|
4780
|
|
|
|
|
|
|
last outer
|
4781
|
0
|
|
|
|
|
0
|
}
|
4782
|
0
|
|
|
|
|
0
|
};
|
4783
|
0
|
|
|
|
|
0
|
my $last;
|
4784
|
|
|
|
|
|
|
curse {
|
4785
|
|
|
|
|
|
|
FETCH =>
|
4786
|
|
|
|
|
|
|
($LOOKAHEAD and ! $src->can('index')
|
4787
|
|
|
|
|
|
|
|| $src->isa($class))
|
4788
|
|
|
|
|
|
|
? sub {
|
4789
|
0
|
|
|
0
|
|
0
|
my ($want, $ret) = $_[1];
|
4790
|
0
|
|
|
|
|
0
|
outer: {
|
4791
|
0
|
|
|
|
|
0
|
local *_;
|
4792
|
0
|
0
|
|
|
|
0
|
if ($idx > $want) {
|
4793
|
0
|
|
|
|
|
0
|
while ($idx > $want) {
|
4794
|
0
|
|
|
|
|
0
|
undef $ret;
|
4795
|
0
|
|
|
|
|
0
|
$ret = $prev->();
|
4796
|
0
|
|
|
|
|
0
|
$index--;
|
4797
|
|
|
|
|
|
|
}
|
4798
|
|
|
|
|
|
|
}
|
4799
|
|
|
|
|
|
|
else {
|
4800
|
0
|
|
|
|
|
0
|
my $end = $want + 1;
|
4801
|
0
|
|
|
|
|
0
|
while ($idx <= $end) {
|
4802
|
0
|
|
|
|
|
0
|
$ret = $last;
|
4803
|
0
|
|
|
|
|
0
|
undef $last;
|
4804
|
0
|
|
|
|
|
0
|
$last = $next->();
|
4805
|
0
|
|
|
|
|
0
|
$index++;
|
4806
|
|
|
|
|
|
|
}
|
4807
|
|
|
|
|
|
|
}
|
4808
|
|
|
|
|
|
|
}
|
4809
|
0
|
|
|
|
|
0
|
for ($src_size - $pos + $idx) {
|
4810
|
0
|
0
|
|
|
|
0
|
if ($size > $_) {
|
4811
|
0
|
|
|
|
|
0
|
$size = $_;
|
4812
|
0
|
0
|
|
|
|
0
|
$size = $idx if $pos == $src_size;
|
4813
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
4814
|
|
|
|
|
|
|
}
|
4815
|
|
|
|
|
|
|
}
|
4816
|
0
|
0
|
|
|
|
0
|
defined $ret ? $ret : ()
|
4817
|
|
|
|
|
|
|
}
|
4818
|
|
|
|
|
|
|
: sub {
|
4819
|
0
|
|
|
0
|
|
0
|
my ($want, $ret) = $_[1];
|
4820
|
0
|
|
|
|
|
0
|
outer: {
|
4821
|
0
|
|
|
|
|
0
|
local *_;
|
4822
|
0
|
0
|
|
|
|
0
|
if ($idx > $want) {$ret = $prev->() while $idx > $want}
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
0
|
|
|
|
0
|
|
4823
|
0
|
|
|
|
|
0
|
elsif ($idx == $want) {$ret = $next->() }
|
4824
|
|
|
|
|
|
|
elsif ($idx < $want) {$ret = $next->() while $idx <= $want}
|
4825
|
|
|
|
|
|
|
}
|
4826
|
0
|
|
|
|
|
0
|
$index = $idx;
|
4827
|
0
|
|
|
|
|
0
|
for ($src_size - $pos + $idx) {
|
4828
|
0
|
0
|
|
|
|
0
|
if ($size > $_) {
|
4829
|
0
|
|
|
|
|
0
|
$size = $_;
|
4830
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
4831
|
|
|
|
|
|
|
}
|
4832
|
|
|
|
|
|
|
}
|
4833
|
0
|
0
|
|
|
|
0
|
defined $ret ? $ret : ()
|
4834
|
|
|
|
|
|
|
},
|
4835
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
4836
|
0
|
|
|
0
|
|
0
|
tail_size => sub {push @tails, \$_[1]; &weaken($tails[-1])},
|
|
0
|
|
|
|
|
0
|
|
4837
|
0
|
|
|
0
|
|
0
|
_when_done => sub :lvalue {$when_done},
|
4838
|
0
|
|
|
0
|
|
0
|
rewind => $rewind,
|
4839
|
|
|
|
|
|
|
index => sub {\$index},
|
4840
|
0
|
0
|
0
|
|
|
0
|
} => $class;
|
4841
|
|
|
|
|
|
|
};
|
4842
|
|
|
|
|
|
|
|
4843
|
|
|
|
|
|
|
|
4844
|
|
|
|
|
|
|
=item While C<< {CODE} GENERATOR >>
|
4845
|
|
|
|
|
|
|
|
4846
|
|
|
|
|
|
|
=item Until C<< {CODE} GENERATOR >>
|
4847
|
|
|
|
|
|
|
|
4848
|
|
|
|
|
|
|
C<< While / ->while(...) >> returns a new generator that will end when its
|
4849
|
|
|
|
|
|
|
passed in subroutine returns false. the C< until > pair ends when the subroutine
|
4850
|
|
|
|
|
|
|
returns true.
|
4851
|
|
|
|
|
|
|
|
4852
|
|
|
|
|
|
|
if C< $List::Gen::LOOKAHEAD > is true (the default), each reads one element past
|
4853
|
|
|
|
|
|
|
its requested element, and saves this value only until the next call for
|
4854
|
|
|
|
|
|
|
efficiency, no other values are saved. each supports random access, but is
|
4855
|
|
|
|
|
|
|
optimized for sequential access.
|
4856
|
|
|
|
|
|
|
|
4857
|
|
|
|
|
|
|
these functions have all of the caveats of C< filter >, should be considered
|
4858
|
|
|
|
|
|
|
experimental, and may change in future versions. the generator returned should
|
4859
|
|
|
|
|
|
|
only be dereferenced in a C< foreach > loop, otherwise, just like a C< filter >
|
4860
|
|
|
|
|
|
|
perl will expand it to the wrong size.
|
4861
|
|
|
|
|
|
|
|
4862
|
|
|
|
|
|
|
the generator will return undef the first time an access is made and the check
|
4863
|
|
|
|
|
|
|
code indicates it is past the end.
|
4864
|
|
|
|
|
|
|
|
4865
|
|
|
|
|
|
|
the generator will throw an error if accessed beyond its dynamically found limit
|
4866
|
|
|
|
|
|
|
subsequent times.
|
4867
|
|
|
|
|
|
|
|
4868
|
|
|
|
|
|
|
my $pow = While {$_ < 20} gen {$_**2};
|
4869
|
|
|
|
|
|
|
<0..>->map('**2')->while('< 20')
|
4870
|
|
|
|
|
|
|
|
4871
|
|
|
|
|
|
|
say for @$pow;
|
4872
|
|
|
|
|
|
|
|
4873
|
|
|
|
|
|
|
prints:
|
4874
|
|
|
|
|
|
|
|
4875
|
|
|
|
|
|
|
0
|
4876
|
|
|
|
|
|
|
1
|
4877
|
|
|
|
|
|
|
4
|
4878
|
|
|
|
|
|
|
9
|
4879
|
|
|
|
|
|
|
16
|
4880
|
|
|
|
|
|
|
|
4881
|
|
|
|
|
|
|
in general, it is faster to write it this way:
|
4882
|
|
|
|
|
|
|
|
4883
|
|
|
|
|
|
|
my $pow = gen {$_**2};
|
4884
|
|
|
|
|
|
|
$gen->do(sub {
|
4885
|
|
|
|
|
|
|
last if $_ > 20;
|
4886
|
|
|
|
|
|
|
say;
|
4887
|
|
|
|
|
|
|
});
|
4888
|
|
|
|
|
|
|
|
4889
|
|
|
|
|
|
|
=cut
|
4890
|
|
|
|
|
|
|
|
4891
|
|
|
|
|
|
|
sub While (&$) {
|
4892
|
0
|
|
|
0
|
1
|
0
|
my ($code, $source) = @_;
|
4893
|
0
|
0
|
|
|
|
0
|
isagen $source
|
4894
|
|
|
|
|
|
|
or croak '$_[1] to While must be a generator';
|
4895
|
0
|
|
|
|
|
0
|
tiegen While => tied @$source, $code
|
4896
|
|
|
|
|
|
|
}
|
4897
|
|
|
|
|
|
|
sub Until (&$) {
|
4898
|
0
|
|
|
0
|
1
|
0
|
my ($code, $source) = @_;
|
4899
|
0
|
0
|
|
|
|
0
|
isagen $source
|
4900
|
|
|
|
|
|
|
or croak '$_[1] to Until must be a generator';
|
4901
|
0
|
|
|
0
|
|
0
|
tiegen While => tied @$source, sub {not &$code}
|
4902
|
0
|
|
|
|
|
0
|
}
|
4903
|
0
|
|
|
0
|
0
|
0
|
sub while_ (&$) {local $LOOKAHEAD; &While}
|
|
0
|
|
|
|
|
0
|
|
4904
|
0
|
|
|
0
|
0
|
0
|
sub until_ (&$) {local $LOOKAHEAD; &Until}
|
|
0
|
|
|
|
|
0
|
|
4905
|
|
|
|
|
|
|
|
4906
|
|
|
|
|
|
|
BEGIN {
|
4907
|
10
|
|
|
10
|
|
44
|
*take_while = *While;
|
4908
|
10
|
|
|
|
|
25662
|
*take_until = *Until;
|
4909
|
|
|
|
|
|
|
}
|
4910
|
|
|
|
|
|
|
|
4911
|
0
|
|
|
0
|
0
|
0
|
sub drop_while (&$) {$_[1]->drop_while($_[0])}
|
4912
|
0
|
|
|
0
|
0
|
0
|
sub drop_until (&$) {$_[1]->drop_until($_[0])}
|
4913
|
|
|
|
|
|
|
|
4914
|
|
|
|
|
|
|
mutable_gen While => sub {
|
4915
|
0
|
|
|
0
|
|
0
|
my ($class, $source, $check) = @_;
|
4916
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize) = $source->closures;
|
4917
|
0
|
|
|
|
|
0
|
my ($size, $src_size) = ($fsize->()) x 2;
|
4918
|
0
|
0
|
|
|
|
0
|
if ($source->mutable) {
|
4919
|
0
|
|
|
|
|
0
|
$source->tail_size($src_size)
|
4920
|
|
|
|
|
|
|
}
|
4921
|
0
|
|
|
|
|
0
|
my $lookahead = $LOOKAHEAD;
|
4922
|
0
|
|
|
|
|
0
|
my (@next, @tails) = -1;
|
4923
|
0
|
|
|
0
|
|
0
|
my $when_done = sub {};
|
|
0
|
|
|
|
|
0
|
|
4924
|
|
|
|
|
|
|
my $done = sub {
|
4925
|
0
|
|
|
0
|
|
0
|
$size = $_[0];
|
4926
|
0
|
|
|
|
|
0
|
$$_ = $size for @tails;
|
4927
|
0
|
|
|
|
|
0
|
$when_done->();
|
4928
|
0
|
|
|
|
|
0
|
@next = -1;
|
4929
|
|
|
|
|
|
|
return
|
4930
|
0
|
|
|
|
|
0
|
};
|
|
0
|
|
|
|
|
0
|
|
4931
|
|
|
|
|
|
|
curse {
|
4932
|
|
|
|
|
|
|
FETCH => sub {
|
4933
|
0
|
|
|
0
|
|
0
|
my $i = $_[1];
|
4934
|
0
|
0
|
|
|
|
0
|
unless ($i < $size) {
|
4935
|
0
|
|
|
|
|
0
|
croak "while/until: index '$i' past end '".($size - 1)."'"
|
4936
|
|
|
|
|
|
|
}
|
4937
|
0
|
0
|
|
|
|
0
|
if ($i < $src_size) {
|
4938
|
0
|
0
|
|
|
|
0
|
local *_ = $i == $next[0] ? $next[1] : \$fetch->(undef, $i);
|
4939
|
0
|
0
|
0
|
|
|
0
|
return $done->($i) unless $i < $src_size and $check->();
|
4940
|
|
|
|
|
|
|
|
4941
|
0
|
0
|
0
|
|
|
0
|
if ($lookahead and $i + 1 < $src_size) {
|
4942
|
0
|
|
|
|
|
0
|
local *_ = \$fetch->(undef, $i + 1);
|
4943
|
0
|
0
|
0
|
|
|
0
|
if ($i + 1 < $src_size and $check->()) {
|
4944
|
0
|
|
|
|
|
0
|
@next = ($i + 1, \$_)
|
4945
|
|
|
|
|
|
|
}
|
4946
|
|
|
|
|
|
|
else {
|
4947
|
0
|
|
|
|
|
0
|
$done->($i + 1)
|
4948
|
|
|
|
|
|
|
}
|
4949
|
|
|
|
|
|
|
}
|
4950
|
0
|
|
|
|
|
0
|
return $_
|
4951
|
|
|
|
|
|
|
}
|
4952
|
|
|
|
|
|
|
else {
|
4953
|
0
|
|
|
|
|
0
|
$done->($src_size)
|
4954
|
|
|
|
|
|
|
}
|
4955
|
|
|
|
|
|
|
},
|
4956
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
4957
|
0
|
|
|
0
|
|
0
|
tail_size => sub {push @tails, \$_[1]; weaken $tails[-1]},
|
|
0
|
|
|
|
|
0
|
|
4958
|
0
|
|
|
0
|
|
0
|
source => sub {$source},
|
4959
|
0
|
|
|
0
|
|
0
|
_when_done => sub :lvalue {$when_done},
|
4960
|
0
|
|
|
|
|
0
|
} => $class
|
4961
|
|
|
|
|
|
|
};
|
4962
|
|
|
|
|
|
|
|
4963
|
|
|
|
|
|
|
|
4964
|
|
|
|
|
|
|
=item mutable C< GENERATOR >
|
4965
|
|
|
|
|
|
|
|
4966
|
|
|
|
|
|
|
=item C<< $gen->mutable >>
|
4967
|
|
|
|
|
|
|
|
4968
|
|
|
|
|
|
|
C< mutable > takes a single fixed size (immutable) generator, such as those
|
4969
|
|
|
|
|
|
|
produced by C< gen > and converts it into a variable size (mutable) generator,
|
4970
|
|
|
|
|
|
|
such as those returned by C< filter >.
|
4971
|
|
|
|
|
|
|
|
4972
|
|
|
|
|
|
|
as with filter, it is important to not use full array dereferencing (C< @$gen >)
|
4973
|
|
|
|
|
|
|
with mutable generators, since perl will expand the generator to the wrong size.
|
4974
|
|
|
|
|
|
|
to access all of the elements, use the C<< $gen->all >> method, or call
|
4975
|
|
|
|
|
|
|
C<< $gen->apply >> before C< @$gen >. using a slice C< @$gen[5 .. 10] > is
|
4976
|
|
|
|
|
|
|
always ok, and does not require calling C<< ->apply >>.
|
4977
|
|
|
|
|
|
|
|
4978
|
|
|
|
|
|
|
mutable generators respond to the C< List::Gen::Done > exception, which can be
|
4979
|
|
|
|
|
|
|
produced with either C< done >, C< done_if >, or C< done_unless >. when the
|
4980
|
|
|
|
|
|
|
exception is caught, it causes the generator to set its size, and it also
|
4981
|
|
|
|
|
|
|
triggers any C<< ->when_done >> actions.
|
4982
|
|
|
|
|
|
|
|
4983
|
|
|
|
|
|
|
my $gen = mutable gen {done if $_ > 5; $_**2};
|
4984
|
|
|
|
|
|
|
|
4985
|
|
|
|
|
|
|
say $gen->size; # inf
|
4986
|
|
|
|
|
|
|
say $gen->str; # 0 1 4 9 16 25
|
4987
|
|
|
|
|
|
|
say $gen->size; # 6
|
4988
|
|
|
|
|
|
|
|
4989
|
|
|
|
|
|
|
generators returned from C< mutable > have a C<< ->set_size(int) >> method
|
4990
|
|
|
|
|
|
|
that will set the generator's size and then trigger any
|
4991
|
|
|
|
|
|
|
C<< ->when_done(sub{...}) >> methods.
|
4992
|
|
|
|
|
|
|
|
4993
|
|
|
|
|
|
|
=cut
|
4994
|
|
|
|
|
|
|
|
4995
|
|
|
|
|
|
|
sub mutable {
|
4996
|
0
|
0
|
|
0
|
1
|
0
|
tiegen Mutable => tied @{isagen $_[0] or croak "var takes a generator"}
|
|
0
|
|
|
|
|
0
|
|
4997
|
|
|
|
|
|
|
}
|
4998
|
|
|
|
|
|
|
generator Mutable => sub {
|
4999
|
0
|
|
|
0
|
|
0
|
my ($class, $source ) = @_;
|
5000
|
0
|
|
|
|
|
0
|
my ($fetch, $fsize ) = $source->closures;
|
5001
|
0
|
|
|
0
|
|
0
|
my ($when_done, $size) = sub {};
|
|
0
|
|
|
|
|
0
|
|
5002
|
|
|
|
|
|
|
curse {
|
5003
|
|
|
|
|
|
|
FETCH => sub {
|
5004
|
0
|
0
|
0
|
0
|
|
0
|
defined $size and $_[1] >= $size
|
5005
|
0
|
|
|
|
|
0
|
and croak "index $_[1] out of bounds [0 .. ${\($size - 1)}";
|
5006
|
|
|
|
|
|
|
|
5007
|
0
|
|
|
|
|
0
|
my $ret = eval {cap($fetch->(undef, $_[1]))}
|
5008
|
|
|
|
|
|
|
or catch_done and ref $@ ? do {
|
5009
|
0
|
|
|
|
|
0
|
my $val = $@;
|
5010
|
0
|
|
|
|
|
0
|
$size = $_[1] + 1;
|
5011
|
0
|
|
|
|
|
0
|
$when_done->();
|
5012
|
0
|
0
|
|
|
|
0
|
return wantarray ? @$val : pop @$val
|
5013
|
0
|
0
|
0
|
|
|
0
|
} : do {
|
|
|
0
|
|
|
|
|
|
5014
|
0
|
|
|
|
|
0
|
$size = $_[1];
|
5015
|
0
|
|
|
|
|
0
|
$when_done->();
|
5016
|
|
|
|
|
|
|
return
|
5017
|
0
|
|
|
|
|
0
|
};
|
5018
|
0
|
0
|
|
|
|
0
|
wantarray ? @$ret : pop @$ret
|
5019
|
|
|
|
|
|
|
},
|
5020
|
0
|
0
|
|
0
|
|
0
|
fsize => $source->mutable
|
5021
|
|
|
|
|
|
|
? sub {defined $size ? $size : $fsize->()}
|
5022
|
0
|
0
|
|
0
|
|
0
|
: sub {defined $size ? $size : ($size = $fsize->())},
|
5023
|
0
|
|
|
0
|
|
0
|
set_size => sub {$size = int $_[1]; $when_done->()},
|
|
0
|
|
|
|
|
0
|
|
5024
|
0
|
|
|
0
|
|
0
|
_when_done => sub :lvalue {$when_done},
|
5025
|
0
|
|
|
0
|
|
0
|
source => sub {$source},
|
5026
|
0
|
0
|
|
|
|
0
|
} => $class
|
5027
|
|
|
|
|
|
|
},
|
5028
|
|
|
|
|
|
|
when_done => sub {
|
5029
|
0
|
|
|
0
|
|
0
|
my ($self, @next) = @_;
|
5030
|
0
|
|
|
|
|
0
|
my $when_done = $self->_when_done;
|
5031
|
0
|
0
|
|
|
|
0
|
if (@next) {
|
|
0
|
|
|
|
|
0
|
|
5032
|
|
|
|
|
|
|
$self->_when_done = sub {
|
5033
|
0
|
|
|
0
|
|
0
|
$_->($self) for $when_done, @next;
|
5034
|
|
|
|
|
|
|
}
|
5035
|
0
|
|
|
|
|
0
|
} else {$when_done}
|
5036
|
|
|
|
|
|
|
},
|
5037
|
|
|
|
|
|
|
clear_done => sub {
|
5038
|
0
|
|
|
0
|
|
0
|
$_[0]->_when_done = sub {};
|
|
0
|
|
|
|
|
0
|
|
5039
|
0
|
|
|
|
|
0
|
$_[0]
|
5040
|
|
|
|
|
|
|
},
|
5041
|
|
|
|
|
|
|
mutable => sub () {1},
|
5042
|
|
|
|
|
|
|
apply => sub {
|
5043
|
0
|
|
|
0
|
|
0
|
my $self = shift;
|
5044
|
0
|
|
|
|
|
0
|
my $code = $self->can('FETCH');
|
5045
|
0
|
|
|
|
|
0
|
my ($i, $ok) = (0, 1);
|
5046
|
0
|
|
|
0
|
|
0
|
$self->when_done(sub{undef $ok});
|
|
0
|
|
|
|
|
0
|
|
5047
|
0
|
|
|
|
|
0
|
my $size = $self->fsize;
|
5048
|
0
|
|
0
|
|
|
0
|
$code->(undef, $i++) while $ok and $i < $size;
|
5049
|
0
|
0
|
|
|
|
0
|
$self->when_done->() if $ok;
|
5050
|
0
|
|
|
|
|
0
|
$self->clear_done
|
5051
|
|
|
|
|
|
|
};
|
5052
|
|
|
|
|
|
|
|
5053
|
|
|
|
|
|
|
|
5054
|
|
|
|
|
|
|
=item done C< [LAST_RETURN_VALUE] >
|
5055
|
|
|
|
|
|
|
|
5056
|
|
|
|
|
|
|
throws an exception that will be caught by a mutable generator indicating that
|
5057
|
|
|
|
|
|
|
the generator should set its size. if a value is passed to done, that will be
|
5058
|
|
|
|
|
|
|
the final value returned by the generator, otherwise, the final value will be
|
5059
|
|
|
|
|
|
|
the value returned on the previous call.
|
5060
|
|
|
|
|
|
|
|
5061
|
|
|
|
|
|
|
=cut
|
5062
|
|
|
|
|
|
|
|
5063
|
0
|
|
|
0
|
1
|
0
|
sub done {die bless [@_] => 'List::Gen::Done'}
|
5064
|
|
|
|
|
|
|
sub catch_done () {
|
5065
|
0
|
|
|
|
|
0
|
ref $@
|
5066
|
|
|
|
|
|
|
? ref $@ eq 'List::Gen::Done'
|
5067
|
0
|
0
|
|
0
|
0
|
0
|
? @{$@} ? [@{$@}] : eval {1}
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
0
|
|
|
|
0
|
|
5068
|
|
|
|
|
|
|
: die $@
|
5069
|
|
|
|
|
|
|
: croak $@
|
5070
|
|
|
|
|
|
|
}
|
5071
|
|
|
|
|
|
|
|
5072
|
|
|
|
|
|
|
|
5073
|
|
|
|
|
|
|
=item done_if C< COND VALUE >
|
5074
|
|
|
|
|
|
|
|
5075
|
|
|
|
|
|
|
=item done_unless C< COND VALUE >
|
5076
|
|
|
|
|
|
|
|
5077
|
|
|
|
|
|
|
these are convenience functions for throwing C< done > exceptions. if the
|
5078
|
|
|
|
|
|
|
condition does not indicate C< done > then the function returns C< VALUE >
|
5079
|
|
|
|
|
|
|
|
5080
|
|
|
|
|
|
|
=cut
|
5081
|
|
|
|
|
|
|
|
5082
|
0
|
0
|
|
0
|
1
|
0
|
sub done_if ($@) { shift @_ ? &done : wantarray ? @_ : pop}
|
|
|
0
|
|
|
|
|
|
5083
|
0
|
0
|
|
0
|
1
|
0
|
sub done_unless ($@) {!shift @_ ? &done : wantarray ? @_ : pop}
|
|
|
0
|
|
|
|
|
|
5084
|
|
|
|
|
|
|
|
5085
|
|
|
|
|
|
|
|
5086
|
|
|
|
|
|
|
=item strict C< {CODE} >
|
5087
|
|
|
|
|
|
|
|
5088
|
|
|
|
|
|
|
in the C< CODE > block, calls to functions or methods are subject to the
|
5089
|
|
|
|
|
|
|
following localizations:
|
5090
|
|
|
|
|
|
|
|
5091
|
|
|
|
|
|
|
=over 4
|
5092
|
|
|
|
|
|
|
|
5093
|
|
|
|
|
|
|
=item * C< local $List::Gen::LOOKAHEAD = 0; >
|
5094
|
|
|
|
|
|
|
|
5095
|
|
|
|
|
|
|
the functions C< filter >, C< While > and their various forms normally stay an
|
5096
|
|
|
|
|
|
|
element ahead of the last requested element so that an array dereference in a
|
5097
|
|
|
|
|
|
|
C< foreach > loop ends properly. this localization disables this behavior, which
|
5098
|
|
|
|
|
|
|
might be needed for certain algorithms. it is therefore important to never
|
5099
|
|
|
|
|
|
|
write code like: C< for(@$strict_filtered){...} >, instead write
|
5100
|
|
|
|
|
|
|
C<< $strict_filtered->do(sub{...}) >> which is faster as well. the following
|
5101
|
|
|
|
|
|
|
code illustrates the difference in behavior:
|
5102
|
|
|
|
|
|
|
|
5103
|
|
|
|
|
|
|
my $test = sub {
|
5104
|
|
|
|
|
|
|
my $loud = filter {print "$_, "; $_ % 2};
|
5105
|
|
|
|
|
|
|
print "($_:", $loud->next, '), ' for 0 .. 2;
|
5106
|
|
|
|
|
|
|
print $/;
|
5107
|
|
|
|
|
|
|
};
|
5108
|
|
|
|
|
|
|
print 'normal: '; $test->();
|
5109
|
|
|
|
|
|
|
print 'strict: '; strict {$test->()};
|
5110
|
|
|
|
|
|
|
|
5111
|
|
|
|
|
|
|
normal: 0, 1, 2, 3, (0:1), 4, 5, (1:3), 6, 7, (2:5),
|
5112
|
|
|
|
|
|
|
strict: 0, 1, (0:1), 2, 3, (1:3), 4, 5, (2:5),
|
5113
|
|
|
|
|
|
|
|
5114
|
|
|
|
|
|
|
=item * C< local $List::Gen::DWIM_CODE_STRINGS = 0; >
|
5115
|
|
|
|
|
|
|
|
5116
|
|
|
|
|
|
|
in the dwim C<< $gen->(...) >> code deref syntax, if C< $DWIM_CODE_STRINGS > has
|
5117
|
|
|
|
|
|
|
been set to a true value, bare strings that look like code will be interpreted
|
5118
|
|
|
|
|
|
|
as code and passed to C< gen > (string refs to C< filter >). since this
|
5119
|
|
|
|
|
|
|
behavior is fun for golf, but potentially error prone, it is off by default.
|
5120
|
|
|
|
|
|
|
C< strict > turns it back off if it had been turned on.
|
5121
|
|
|
|
|
|
|
|
5122
|
|
|
|
|
|
|
=back
|
5123
|
|
|
|
|
|
|
|
5124
|
|
|
|
|
|
|
C< strict > returns what C< CODE > returns. C< strict > may have additional
|
5125
|
|
|
|
|
|
|
restrictions added to it in the future.
|
5126
|
|
|
|
|
|
|
|
5127
|
|
|
|
|
|
|
=cut
|
5128
|
|
|
|
|
|
|
|
5129
|
|
|
|
|
|
|
sub strict (&) {
|
5130
|
0
|
|
|
0
|
1
|
0
|
local $STRICT = 1;
|
5131
|
0
|
|
|
|
|
0
|
local $LOOKAHEAD = 0;
|
5132
|
0
|
|
|
|
|
0
|
local $DWIM_CODE_STRINGS = 0;
|
5133
|
0
|
|
|
|
|
0
|
$_[0]->()
|
5134
|
|
|
|
|
|
|
}
|
5135
|
|
|
|
|
|
|
|
5136
|
|
|
|
|
|
|
|
5137
|
|
|
|
|
|
|
=back
|
5138
|
|
|
|
|
|
|
|
5139
|
|
|
|
|
|
|
=head2 combining generators
|
5140
|
|
|
|
|
|
|
|
5141
|
|
|
|
|
|
|
=over 4
|
5142
|
|
|
|
|
|
|
|
5143
|
|
|
|
|
|
|
=item sequence C< LIST >
|
5144
|
|
|
|
|
|
|
|
5145
|
|
|
|
|
|
|
string generators, arrays, and scalars together.
|
5146
|
|
|
|
|
|
|
|
5147
|
|
|
|
|
|
|
C< sequence > provides the functionality of the overloaded C< + > operator on
|
5148
|
|
|
|
|
|
|
generators:
|
5149
|
|
|
|
|
|
|
|
5150
|
|
|
|
|
|
|
my $seq = <1 .. 10> + <20 .. 30> + <40 .. 50>;
|
5151
|
|
|
|
|
|
|
|
5152
|
|
|
|
|
|
|
is exactly the same as:
|
5153
|
|
|
|
|
|
|
|
5154
|
|
|
|
|
|
|
my $seq = sequence <1 .. 10>, <20 .. 30>, <40 .. 50>;
|
5155
|
|
|
|
|
|
|
|
5156
|
|
|
|
|
|
|
you can even write things like:
|
5157
|
|
|
|
|
|
|
|
5158
|
|
|
|
|
|
|
my $fib; $fib = [0, 1] + iterate {sum $fib->($_, $_ + 1)};
|
5159
|
|
|
|
|
|
|
|
5160
|
|
|
|
|
|
|
say "@$fib[0 .. 10]"; # 0 1 1 2 3 5 8 13 21 34 55
|
5161
|
|
|
|
|
|
|
|
5162
|
|
|
|
|
|
|
=cut
|
5163
|
|
|
|
|
|
|
|
5164
|
|
|
|
|
|
|
{
|
5165
|
|
|
|
|
|
|
sub sequence {
|
5166
|
0
|
|
|
0
|
1
|
0
|
tiegen Sequence => @_
|
5167
|
|
|
|
|
|
|
}
|
5168
|
|
|
|
|
|
|
my %seq_const;
|
5169
|
|
|
|
|
|
|
BEGIN {
|
5170
|
10
|
|
|
10
|
|
92
|
%seq_const = (
|
5171
|
|
|
|
|
|
|
FETCH => 0,
|
5172
|
|
|
|
|
|
|
SIZE => 1, LOW => 1,
|
5173
|
|
|
|
|
|
|
MUTABLE => 2, HIGH => 2,
|
5174
|
|
|
|
|
|
|
);
|
5175
|
10
|
|
50
|
|
|
1120
|
eval "sub $_ () {$seq_const{$_}} 1" or die $@ for keys %seq_const
|
5176
|
|
|
|
|
|
|
}
|
5177
|
|
|
|
|
|
|
generator Sequence => sub {
|
5178
|
0
|
|
|
0
|
|
0
|
my $class = shift;
|
5179
|
0
|
|
|
|
|
0
|
my $size = 0;
|
5180
|
0
|
|
|
0
|
|
0
|
my @sequence = map {
|
5181
|
0
|
0
|
0
|
|
|
0
|
(isagen) ? @{(tied(@$_)->can('sequence') or sub {[$_]})->()}
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
5182
|
|
|
|
|
|
|
: ref eq 'ARRAY' ? makegen @$_ : &makegen([$_])
|
5183
|
|
|
|
|
|
|
} @_;
|
5184
|
0
|
|
|
|
|
0
|
my $mutable;
|
5185
|
|
|
|
|
|
|
my @source;
|
5186
|
|
|
|
|
|
|
my $build = sub {
|
5187
|
0
|
|
|
0
|
|
0
|
$mutable = first {$_->is_mutable} @sequence;
|
|
0
|
|
|
|
|
0
|
|
5188
|
0
|
0
|
|
|
|
0
|
@source = map {
|
5189
|
0
|
|
|
|
|
0
|
$mutable ? [tied(@$_)->closures, $_->is_mutable]
|
5190
|
|
|
|
|
|
|
: [tied(@$_)->{FETCH}, $size+0, $size += $_->size]
|
5191
|
|
|
|
|
|
|
} @sequence;
|
5192
|
0
|
0
|
|
|
|
0
|
$size = 9**9**9 if $mutable;
|
5193
|
0
|
|
|
|
|
0
|
};
|
5194
|
0
|
|
|
|
|
0
|
$build->();
|
5195
|
|
|
|
|
|
|
curse {
|
5196
|
|
|
|
|
|
|
FETCH => $mutable ? sub {
|
5197
|
0
|
|
|
0
|
|
0
|
my $i = $_[1];
|
5198
|
0
|
0
|
|
|
|
0
|
croak "sequence index $i out of bounds [0 .. @{[$size - 1]}]"
|
|
0
|
|
|
|
|
0
|
|
5199
|
|
|
|
|
|
|
if $i >= $size;
|
5200
|
0
|
|
|
|
|
0
|
my $depth = 0;
|
5201
|
0
|
|
|
|
|
0
|
for (@source) {
|
5202
|
0
|
|
|
|
|
0
|
my $cur_size = $$_[SIZE]->();
|
5203
|
0
|
0
|
|
|
|
0
|
if (($depth + $cur_size) > $i) {
|
5204
|
0
|
0
|
|
|
|
0
|
if ($$_[MUTABLE]) {
|
5205
|
0
|
|
|
|
|
0
|
my $got = \$$_[FETCH]->(undef, $i - $depth);
|
5206
|
0
|
|
|
|
|
0
|
$cur_size = $$_[SIZE]->();
|
5207
|
0
|
0
|
|
|
|
0
|
return $$got if ($depth + $cur_size) > $i;
|
5208
|
|
|
|
|
|
|
} else {
|
5209
|
0
|
|
|
|
|
0
|
return $$_[FETCH]->(undef, $i - $depth)
|
5210
|
|
|
|
|
|
|
}
|
5211
|
|
|
|
|
|
|
}
|
5212
|
0
|
|
|
|
|
0
|
$depth += $cur_size;
|
5213
|
|
|
|
|
|
|
}
|
5214
|
0
|
|
|
|
|
0
|
$size = $depth;
|
5215
|
0
|
|
|
|
|
0
|
return;
|
5216
|
0
|
|
|
0
|
|
0
|
} : do {
|
5217
|
0
|
|
|
|
|
0
|
my $pos = $#source >> 1;
|
5218
|
0
|
|
|
|
|
0
|
my $src = $source[$pos];
|
5219
|
0
|
|
|
|
|
0
|
my $i;
|
5220
|
0
|
|
|
|
|
0
|
my ($min, $max);
|
5221
|
|
|
|
|
|
|
sub {
|
5222
|
0
|
|
|
0
|
|
0
|
$i = $_[1];
|
5223
|
0
|
0
|
|
|
|
0
|
croak "sequence index $i out of bounds [0 .. @{[$size - 1]}]"
|
|
0
|
|
|
|
|
0
|
|
5224
|
|
|
|
|
|
|
if $i >= $size;
|
5225
|
0
|
|
|
|
|
0
|
$min = 0;
|
5226
|
0
|
|
|
|
|
0
|
$max = $#source;
|
5227
|
0
|
|
|
|
|
0
|
while ($min <= $max) {
|
5228
|
0
|
0
|
|
|
|
0
|
if ($$src[HIGH] <= $i) {$min = $pos + 1}
|
|
0
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
5229
|
|
|
|
|
|
|
elsif ($$src[LOW] > $i) {$max = $pos - 1}
|
5230
|
|
|
|
|
|
|
else {
|
5231
|
0
|
|
|
|
|
0
|
return $$src[FETCH]->(undef, $i - $$src[LOW])
|
5232
|
|
|
|
|
|
|
}
|
5233
|
0
|
|
|
|
|
0
|
$pos = ($min + $max) >> 1;
|
5234
|
0
|
|
|
|
|
0
|
$src = $source[$pos];
|
5235
|
|
|
|
|
|
|
}
|
5236
|
0
|
|
|
|
|
0
|
croak "sequence error at index: $i"
|
5237
|
|
|
|
|
|
|
}
|
5238
|
0
|
|
|
|
|
0
|
},
|
5239
|
|
|
|
|
|
|
fsize => sub {$size},
|
5240
|
0
|
|
|
0
|
|
0
|
sequence => sub {\@sequence},
|
5241
|
0
|
|
|
0
|
|
0
|
$mutable ? (mutable => sub {1}) : (),
|
5242
|
|
|
|
|
|
|
rebuild => $build,
|
5243
|
0
|
0
|
|
|
|
0
|
source => do {
|
|
|
0
|
|
|
|
|
|
5244
|
0
|
|
|
|
|
0
|
my @src = map tied @$_, @sequence;
|
5245
|
0
|
|
|
0
|
|
0
|
sub {\@src}
|
5246
|
0
|
|
|
|
|
0
|
},
|
5247
|
|
|
|
|
|
|
} => $class
|
5248
|
0
|
|
|
0
|
|
0
|
}, mutable => sub {0};
|
5249
|
10
|
|
|
10
|
|
1588
|
BEGIN {delete $List::Gen::{$_} for keys %seq_const}
|
5250
|
|
|
|
|
|
|
}
|
5251
|
|
|
|
|
|
|
|
5252
|
|
|
|
|
|
|
|
5253
|
|
|
|
|
|
|
=item zipgen C< LIST >
|
5254
|
|
|
|
|
|
|
|
5255
|
|
|
|
|
|
|
C< zipgen > is a lazy version of C< zip >. it takes any combination of
|
5256
|
|
|
|
|
|
|
generators and array refs and returns a generator. it is called automatically
|
5257
|
|
|
|
|
|
|
when C< zip > is used in scalar context.
|
5258
|
|
|
|
|
|
|
|
5259
|
|
|
|
|
|
|
C< zipgen > can be spelled C< genzip >
|
5260
|
|
|
|
|
|
|
|
5261
|
|
|
|
|
|
|
=cut
|
5262
|
|
|
|
|
|
|
|
5263
|
|
|
|
|
|
|
sub zipgen {
|
5264
|
2
|
50
|
|
2
|
1
|
6
|
tiegen Zip => map tied @{isagen or makegen @$_} => @_
|
|
4
|
|
|
|
|
10
|
|
5265
|
|
|
|
|
|
|
}
|
5266
|
10
|
|
|
10
|
|
63358
|
BEGIN {*genzip = *zipgen}
|
5267
|
|
|
|
|
|
|
generator Zip => sub {
|
5268
|
2
|
|
|
2
|
|
6
|
my ($class, @src) = @_;
|
5269
|
2
|
|
|
|
|
33
|
my @fetch = map $_->can('FETCH') => @src;
|
5270
|
2
|
|
|
|
|
14
|
my @size = map $_->can('fsize') => @src;
|
5271
|
2
|
|
50
|
|
|
16
|
my @mutable = map $_->mutable || 0 => @src;
|
5272
|
2
|
50
|
|
|
|
6
|
if (grep {$_} @mutable) {
|
|
4
|
|
|
|
|
10
|
|
5273
|
0
|
|
|
|
|
0
|
my ($size, @cache, $cached);
|
5274
|
|
|
|
|
|
|
my $set_size = sub {
|
5275
|
0
|
|
|
0
|
|
0
|
@cache = ();
|
5276
|
0
|
|
|
|
|
0
|
$cached = -1;
|
5277
|
0
|
|
|
|
|
0
|
$size = @src * min(map $_->() => @size);
|
5278
|
0
|
|
|
|
|
0
|
};
|
5279
|
0
|
|
|
|
|
0
|
$set_size->();
|
5280
|
|
|
|
|
|
|
curse {
|
5281
|
|
|
|
|
|
|
FETCH => sub {
|
5282
|
0
|
0
|
|
0
|
|
0
|
croak "zipgen index $_[1] out of range [0 .. ".($size-1)."]"
|
5283
|
|
|
|
|
|
|
if $_[1] >= $size;
|
5284
|
|
|
|
|
|
|
|
5285
|
0
|
|
|
|
|
0
|
my ($src, $i) = (($_[1] % @src), int ($_[1] / @src));
|
5286
|
|
|
|
|
|
|
|
5287
|
0
|
0
|
|
|
|
0
|
unless ($cached == $i) {
|
5288
|
0
|
|
|
|
|
0
|
@cache = ();
|
5289
|
0
|
|
|
|
|
0
|
$cached = $i;
|
5290
|
0
|
|
|
|
|
0
|
for my $sid (0 .. $#src) {
|
5291
|
0
|
0
|
|
|
|
0
|
if ($mutable[$sid]) {
|
5292
|
0
|
0
|
|
|
|
0
|
if ($i < $size[$sid]()) {
|
5293
|
0
|
|
|
|
|
0
|
$cache[$sid] = \$fetch[$sid](undef, $i);
|
5294
|
0
|
0
|
|
|
|
0
|
if ($i >= $size[$sid]()) {
|
5295
|
0
|
|
|
|
|
0
|
$set_size->();
|
5296
|
|
|
|
|
|
|
return
|
5297
|
0
|
|
|
|
|
0
|
}
|
5298
|
|
|
|
|
|
|
} else {
|
5299
|
0
|
|
|
|
|
0
|
$set_size->();
|
5300
|
|
|
|
|
|
|
return
|
5301
|
0
|
|
|
|
|
0
|
}
|
5302
|
|
|
|
|
|
|
} else {
|
5303
|
0
|
|
|
|
|
0
|
$cache[$sid] = \$fetch[$sid](undef, $i);
|
5304
|
|
|
|
|
|
|
}
|
5305
|
|
|
|
|
|
|
}
|
5306
|
|
|
|
|
|
|
}
|
5307
|
0
|
|
|
|
|
0
|
${$cache[$src]}
|
|
0
|
|
|
|
|
0
|
|
5308
|
|
|
|
|
|
|
},
|
5309
|
0
|
|
|
0
|
|
0
|
fsize => sub {$size},
|
5310
|
0
|
|
|
0
|
|
0
|
source => sub {\@src},
|
5311
|
0
|
|
|
0
|
|
0
|
mutable => sub {1},
|
5312
|
0
|
|
|
|
|
0
|
apply => $set_size,
|
5313
|
|
|
|
|
|
|
} => $class;
|
5314
|
|
|
|
|
|
|
} else {
|
5315
|
2
|
|
|
|
|
8
|
my $size = @src * min(map $_->() => @size);
|
5316
|
|
|
|
|
|
|
curse {
|
5317
|
|
|
|
|
|
|
FETCH => sub {
|
5318
|
12
|
|
|
12
|
|
36
|
$fetch[$_[1] % @src](undef, int ($_[1] / @src))
|
5319
|
|
|
|
|
|
|
},
|
5320
|
2
|
|
|
2
|
|
5
|
fsize => sub {$size},
|
5321
|
2
|
|
|
2
|
|
6
|
source => sub {\@src}
|
5322
|
2
|
|
|
|
|
26
|
} => $class
|
5323
|
|
|
|
|
|
|
}
|
5324
|
|
|
|
|
|
|
};
|
5325
|
|
|
|
|
|
|
|
5326
|
|
|
|
|
|
|
|
5327
|
|
|
|
|
|
|
=item unzip C< LIST >
|
5328
|
|
|
|
|
|
|
|
5329
|
|
|
|
|
|
|
C< unzip > is the opposite of C< zip src1, src2 >. unzip returns 2 generators,
|
5330
|
|
|
|
|
|
|
the first returning src1, the second, src2. if C< LIST > is a single element,
|
5331
|
|
|
|
|
|
|
and is a generator, that generator will be unzipped.
|
5332
|
|
|
|
|
|
|
|
5333
|
|
|
|
|
|
|
=cut
|
5334
|
|
|
|
|
|
|
|
5335
|
|
|
|
|
|
|
sub unzip;
|
5336
|
|
|
|
|
|
|
*unzip = &unzipn(2);
|
5337
|
|
|
|
|
|
|
|
5338
|
|
|
|
|
|
|
|
5339
|
|
|
|
|
|
|
=item unzipn C< NUMBER LIST >
|
5340
|
|
|
|
|
|
|
|
5341
|
|
|
|
|
|
|
C is the n-dimentional precursor of C< unzip >. assuming a zipped list
|
5342
|
|
|
|
|
|
|
produced by C< zip > with C< n > elements, C< unzip n list> returns C< n > lists
|
5343
|
|
|
|
|
|
|
corresponding to the lists originally passed to C< zip >. if C< LIST > is a
|
5344
|
|
|
|
|
|
|
single element, and is a generator, that generator will be unzipped. if only
|
5345
|
|
|
|
|
|
|
passed 1 argument, C< unzipn > will return a curried version of itself:
|
5346
|
|
|
|
|
|
|
|
5347
|
|
|
|
|
|
|
*unzip3 = unzipn 3;
|
5348
|
|
|
|
|
|
|
|
5349
|
|
|
|
|
|
|
my $zip3 = zip <1..>, <2..>, <3..>;
|
5350
|
|
|
|
|
|
|
|
5351
|
|
|
|
|
|
|
my ($x, $y, $z) = unzip3($zip3);
|
5352
|
|
|
|
|
|
|
|
5353
|
|
|
|
|
|
|
# $x == <1..>, $y == <2..>, $z == <3..>;
|
5354
|
|
|
|
|
|
|
|
5355
|
|
|
|
|
|
|
=cut
|
5356
|
|
|
|
|
|
|
|
5357
|
|
|
|
|
|
|
sub unzipn ($@) {
|
5358
|
10
|
50
|
|
10
|
1
|
51
|
return \&unzipn unless @_;
|
5359
|
10
|
|
|
|
|
32
|
my $n = shift;
|
5360
|
10
|
50
|
|
0
|
|
146
|
return sub {&unzipn($n, @_)} unless @_;
|
|
0
|
|
|
|
|
0
|
|
5361
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 and ref $_[0] and isagen $_[0]) {
|
|
|
|
0
|
|
|
|
|
5362
|
0
|
|
|
|
|
0
|
my $gen = $_[0];
|
5363
|
0
|
0
|
|
|
|
0
|
if ($gen->is_mutable) {
|
5364
|
0
|
|
|
|
|
0
|
my @lists;
|
5365
|
|
|
|
|
|
|
$gen->when_done(sub {
|
5366
|
0
|
|
|
0
|
|
0
|
my $size = int ($gen->size / $n);
|
5367
|
0
|
|
|
|
|
0
|
$_->set_size($size) for @lists;
|
5368
|
0
|
|
|
|
|
0
|
@lists = ()
|
5369
|
0
|
|
|
|
|
0
|
});
|
5370
|
0
|
|
|
|
|
0
|
@lists = map {
|
5371
|
0
|
|
|
|
|
0
|
my $i = $_;
|
5372
|
|
|
|
|
|
|
mutable gen {
|
5373
|
0
|
|
|
0
|
|
0
|
my $idx = $_ * $n + $i;
|
5374
|
0
|
|
|
|
|
0
|
my $ret;
|
5375
|
0
|
0
|
|
|
|
0
|
done if $gen->size <= $idx;
|
5376
|
0
|
0
|
|
|
|
0
|
done if not eval {$ret = \$gen->get($idx); 1};
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
5377
|
0
|
0
|
|
|
|
0
|
done if $gen->size <= $idx;
|
5378
|
0
|
|
|
|
|
0
|
$$ret
|
5379
|
|
|
|
|
|
|
}
|
5380
|
0
|
|
|
|
|
0
|
} 0 .. $n - 1
|
5381
|
|
|
|
|
|
|
}
|
5382
|
|
|
|
|
|
|
else {
|
5383
|
0
|
|
|
|
|
0
|
my $size = int($gen->size/$n);
|
5384
|
0
|
|
|
|
|
0
|
my $extra = $gen->size - $size*$n;
|
5385
|
0
|
|
|
|
|
0
|
map {
|
5386
|
0
|
|
|
|
|
0
|
my $i = $_;
|
5387
|
0
|
|
|
0
|
|
0
|
gen {$gen->get($i + $n * $_)} $size + ($extra --> 0)
|
|
0
|
|
|
|
|
0
|
|
5388
|
|
|
|
|
|
|
} 0 .. $n - 1
|
5389
|
|
|
|
|
|
|
}
|
5390
|
|
|
|
|
|
|
} else {
|
5391
|
0
|
|
|
|
|
0
|
my $cap = \@_;
|
5392
|
0
|
|
|
|
|
0
|
my $size = int(@_/$n);
|
5393
|
0
|
|
|
|
|
0
|
my $extra = @_ - $size*$n;
|
5394
|
0
|
|
|
|
|
0
|
map {
|
5395
|
0
|
|
|
|
|
0
|
my $i = $_;
|
5396
|
0
|
|
|
0
|
|
0
|
gen {$$cap[$i + $n * $_]} $size + ($extra --> 0)
|
|
0
|
|
|
|
|
0
|
|
5397
|
|
|
|
|
|
|
} 0 .. $n - 1;
|
5398
|
|
|
|
|
|
|
}
|
5399
|
|
|
|
|
|
|
}
|
5400
|
|
|
|
|
|
|
|
5401
|
|
|
|
|
|
|
|
5402
|
|
|
|
|
|
|
=item zipgenmax C< LIST >
|
5403
|
|
|
|
|
|
|
|
5404
|
|
|
|
|
|
|
C< zipgenmax > is a lazy version of C< zipmax >. it takes any combination of
|
5405
|
|
|
|
|
|
|
generators and array refs and returns a generator.
|
5406
|
|
|
|
|
|
|
|
5407
|
|
|
|
|
|
|
=cut
|
5408
|
|
|
|
|
|
|
|
5409
|
|
|
|
|
|
|
sub zipgenmax {
|
5410
|
0
|
0
|
|
0
|
1
|
0
|
my @src = map tied @{isagen or makegen @$_} => @_;
|
|
0
|
|
|
|
|
0
|
|
5411
|
0
|
|
|
|
|
0
|
my @fetch = map $_->can('FETCH') => @src;
|
5412
|
0
|
|
|
|
|
0
|
my @size = map $_->can('fsize') => @src;
|
5413
|
0
|
0
|
|
0
|
|
0
|
if (first {$_->mutable} @src) {
|
|
0
|
|
|
|
|
0
|
|
5414
|
|
|
|
|
|
|
mutable gen {
|
5415
|
0
|
|
|
0
|
|
0
|
my ($src, $i) = (($_ % @src), int ($_ / @src));
|
5416
|
0
|
0
|
|
|
|
0
|
my $ret = $i < $size[$src]() ? $fetch[$src](undef, $i) : undef;
|
5417
|
0
|
0
|
|
|
|
0
|
done if $i >= max(map $_->() => @size);
|
5418
|
0
|
|
|
|
|
0
|
$ret
|
5419
|
0
|
|
|
|
|
0
|
} 0 => @src * max(map $_->() => @size) - 1
|
5420
|
|
|
|
|
|
|
} else {
|
5421
|
0
|
|
|
|
|
0
|
@size = map $_->() => @size;
|
5422
|
|
|
|
|
|
|
gen {
|
5423
|
0
|
|
|
0
|
|
0
|
my ($src, $i) = (($_ % @src), int ($_ / @src));
|
5424
|
0
|
0
|
|
|
|
0
|
$i < $size[$src] ? $fetch[$src](undef, $i) : undef
|
5425
|
0
|
|
|
|
|
0
|
} 0 => @src * max(@size) - 1
|
5426
|
|
|
|
|
|
|
}
|
5427
|
|
|
|
|
|
|
}
|
5428
|
|
|
|
|
|
|
|
5429
|
|
|
|
|
|
|
|
5430
|
|
|
|
|
|
|
=item zipwith C< {CODE} LIST>
|
5431
|
|
|
|
|
|
|
|
5432
|
|
|
|
|
|
|
C takes a code block and a list. the C is zipped together and
|
5433
|
|
|
|
|
|
|
each sub-list is passed to C when requested. C produces a
|
5434
|
|
|
|
|
|
|
generator with the same length as its shortest source list.
|
5435
|
|
|
|
|
|
|
|
5436
|
|
|
|
|
|
|
my $triples = zipwith {\@_} <1..>, <20..>, <300..>;
|
5437
|
|
|
|
|
|
|
|
5438
|
|
|
|
|
|
|
say "@$_" for @$triples[0 .. 3];
|
5439
|
|
|
|
|
|
|
|
5440
|
|
|
|
|
|
|
1 20 300 # the first element of each list
|
5441
|
|
|
|
|
|
|
2 21 301 # the second
|
5442
|
|
|
|
|
|
|
3 22 302 # the third
|
5443
|
|
|
|
|
|
|
4 23 303 # the fourth
|
5444
|
|
|
|
|
|
|
|
5445
|
|
|
|
|
|
|
=cut
|
5446
|
|
|
|
|
|
|
|
5447
|
|
|
|
|
|
|
sub zipwith (&@) {
|
5448
|
4
|
|
|
4
|
1
|
7
|
my $code = shift;
|
5449
|
4
|
|
|
|
|
8
|
my $src = \@_;
|
5450
|
4
|
|
|
|
|
6
|
my $mutable;
|
5451
|
4
|
|
33
|
|
|
10
|
isagen or $_ = makegen @$_ for @$src;
|
5452
|
4
|
|
33
|
|
|
32
|
$mutable ||= (not defined or $_->is_mutable) for @$src;
|
|
|
|
33
|
|
|
|
|
5453
|
4
|
50
|
|
|
|
10
|
if ($mutable) {
|
5454
|
0
|
|
|
|
|
0
|
my @size;
|
5455
|
|
|
|
|
|
|
mutable gen {
|
5456
|
0
|
|
|
0
|
|
0
|
my $i = $_;
|
5457
|
0
|
|
|
|
|
0
|
my $last;
|
5458
|
0
|
0
|
|
|
|
0
|
unless (@size) {
|
5459
|
0
|
|
|
|
|
0
|
for (map {tied @$_} @$src) {
|
|
0
|
|
|
|
|
0
|
|
5460
|
0
|
|
|
|
|
0
|
push @size, $_->fsize;
|
5461
|
0
|
0
|
|
|
|
0
|
$_->tail_size($size[-1]) if $_->mutable;
|
5462
|
|
|
|
|
|
|
}
|
5463
|
|
|
|
|
|
|
}
|
5464
|
0
|
|
0
|
|
|
0
|
$_ <= $i and done for @size;
|
5465
|
0
|
|
|
|
|
0
|
my $arg = cap map $$src[$_]->get($i) => 0 .. $#$src;
|
5466
|
|
|
|
|
|
|
|
5467
|
0
|
|
|
|
|
0
|
for (@size) {
|
5468
|
0
|
0
|
|
|
|
0
|
done if $_ <= $i;
|
5469
|
0
|
0
|
|
|
|
0
|
$last++ if $_ == $i + 1;
|
5470
|
|
|
|
|
|
|
}
|
5471
|
0
|
|
|
|
|
0
|
my $ret = cap $code->(@$arg);
|
5472
|
0
|
0
|
|
|
|
0
|
done @$ret if $last;
|
5473
|
0
|
0
|
|
|
|
0
|
wantarray ? @$ret : pop @$ret
|
5474
|
|
|
|
|
|
|
}
|
5475
|
0
|
|
|
|
|
0
|
} else {
|
5476
|
4
|
|
|
|
|
29
|
my @fetch = map tied(@$_)->can('FETCH'), @$src;
|
5477
|
|
|
|
|
|
|
gen {
|
5478
|
15
|
|
|
15
|
|
19
|
my $i = $_;
|
5479
|
15
|
|
|
|
|
34
|
$code->(map $_->(undef, $i), @fetch)
|
5480
|
4
|
|
|
|
|
38
|
} min map $_->size, @$src;
|
5481
|
|
|
|
|
|
|
}
|
5482
|
|
|
|
|
|
|
}
|
5483
|
|
|
|
|
|
|
|
5484
|
|
|
|
|
|
|
|
5485
|
|
|
|
|
|
|
=item zipwithab C<<< {AB_CODE} $gen1, $gen2 >>>
|
5486
|
|
|
|
|
|
|
|
5487
|
|
|
|
|
|
|
The zipwithab function takes a function which uses C< $a > and C< $b >, as well
|
5488
|
|
|
|
|
|
|
as two lists and returns a list analogous to zipwith.
|
5489
|
|
|
|
|
|
|
|
5490
|
|
|
|
|
|
|
=cut
|
5491
|
|
|
|
|
|
|
|
5492
|
|
|
|
|
|
|
sub zipwithab (&@) {
|
5493
|
0
|
|
|
0
|
1
|
0
|
my $code = shift;
|
5494
|
0
|
|
|
|
|
0
|
my $src = \@_;
|
5495
|
0
|
|
|
|
|
0
|
my ($a, $b) = $code->$cv_ab_ref;
|
5496
|
0
|
|
|
|
|
0
|
my $mutable;
|
5497
|
0
|
|
0
|
|
|
0
|
$mutable ||= (not defined or $_->is_mutable) for @$src;
|
|
|
|
0
|
|
|
|
|
5498
|
0
|
0
|
|
|
|
0
|
if ($mutable) {
|
5499
|
0
|
|
|
|
|
0
|
my @size;
|
5500
|
|
|
|
|
|
|
mutable gen {
|
5501
|
0
|
0
|
|
0
|
|
0
|
unless (@size) {
|
5502
|
0
|
|
|
|
|
0
|
for (map {tied @$_} @$src) {
|
|
0
|
|
|
|
|
0
|
|
5503
|
0
|
|
|
|
|
0
|
push @size, $_->fsize;
|
5504
|
0
|
0
|
|
|
|
0
|
$_->tail_size($size[-1]) if $_->mutable
|
5505
|
|
|
|
|
|
|
}
|
5506
|
|
|
|
|
|
|
}
|
5507
|
0
|
|
|
|
|
0
|
my $i = $_;
|
5508
|
0
|
0
|
|
|
|
0
|
done if first {$_ <= $i} @size;
|
|
0
|
|
|
|
|
0
|
|
5509
|
0
|
|
|
|
|
0
|
local *$a = \$$src[0]->get($i);
|
5510
|
0
|
|
|
|
|
0
|
local *$b = \$$src[1]->get($i);
|
5511
|
0
|
0
|
|
|
|
0
|
done if first {$_ <= $i} @size;
|
|
0
|
|
|
|
|
0
|
|
5512
|
0
|
|
|
|
|
0
|
$code->()
|
5513
|
|
|
|
|
|
|
}
|
5514
|
0
|
|
|
|
|
0
|
} else {
|
5515
|
0
|
|
|
|
|
0
|
my ($fetch_a, $fetch_b) = map tied(@$_)->can('FETCH'), @$src;
|
5516
|
|
|
|
|
|
|
gen {
|
5517
|
0
|
|
|
0
|
|
0
|
local *$a = \$fetch_a->(undef, $_);
|
5518
|
0
|
|
|
|
|
0
|
local *$b = \$fetch_b->(undef, $_);
|
5519
|
0
|
|
|
|
|
0
|
$code->()
|
5520
|
0
|
|
|
|
|
0
|
} min map $_->size, @$src
|
5521
|
|
|
|
|
|
|
}
|
5522
|
|
|
|
|
|
|
}
|
5523
|
|
|
|
|
|
|
|
5524
|
|
|
|
|
|
|
|
5525
|
|
|
|
|
|
|
=item zipwithmax C< {CODE} LIST >
|
5526
|
|
|
|
|
|
|
|
5527
|
|
|
|
|
|
|
C< zipwithmax > is a version of C< zipwith > that has the ending conditions of
|
5528
|
|
|
|
|
|
|
C< zipgenmax >.
|
5529
|
|
|
|
|
|
|
|
5530
|
|
|
|
|
|
|
=cut
|
5531
|
|
|
|
|
|
|
|
5532
|
|
|
|
|
|
|
sub zipwithmax (&@) {
|
5533
|
0
|
|
|
0
|
1
|
0
|
my $code = shift;
|
5534
|
0
|
|
|
|
|
0
|
$code->$sv2cv;
|
5535
|
0
|
0
|
|
|
|
0
|
my @src = map tied @{isagen or makegen @$_} => @_;
|
|
0
|
|
|
|
|
0
|
|
5536
|
0
|
|
|
|
|
0
|
my @fetch = map $_->can('FETCH') => @src;
|
5537
|
0
|
|
|
|
|
0
|
my @size = map $_->can('fsize') => @src;
|
5538
|
0
|
0
|
|
0
|
|
0
|
if (first {$_->mutable} @src) {
|
|
0
|
|
|
|
|
0
|
|
5539
|
|
|
|
|
|
|
mutable gen {
|
5540
|
0
|
|
|
0
|
|
0
|
my $i = int ($_ / @src);
|
5541
|
0
|
0
|
|
|
|
0
|
my @ret = map {$i < $size[$_]() ? $fetch[$_](undef, $i) : undef} 0 .. $#src;
|
|
0
|
|
|
|
|
0
|
|
5542
|
0
|
0
|
|
|
|
0
|
done if $i >= max(map $_->() => @size);
|
5543
|
0
|
|
|
|
|
0
|
$code->(@ret)
|
5544
|
0
|
|
|
|
|
0
|
} 0 => max(map $_->() => @size) - 1
|
5545
|
|
|
|
|
|
|
} else {
|
5546
|
0
|
|
|
|
|
0
|
@size = map $_->() => @size;
|
5547
|
|
|
|
|
|
|
gen {
|
5548
|
0
|
|
|
0
|
|
0
|
my $i = int ($_ / @src);
|
5549
|
0
|
0
|
|
|
|
0
|
$code->(map {$i < $size[$_] ? $fetch[$_](undef, $i) : undef} 0 .. $#src)
|
|
0
|
|
|
|
|
0
|
|
5550
|
0
|
|
|
|
|
0
|
} 0 => max(@size) - 1
|
5551
|
|
|
|
|
|
|
}
|
5552
|
|
|
|
|
|
|
}
|
5553
|
|
|
|
|
|
|
|
5554
|
|
|
|
|
|
|
|
5555
|
|
|
|
|
|
|
=item transpose C< MULTI_DIMENSIONAL_ARRAY >
|
5556
|
|
|
|
|
|
|
|
5557
|
|
|
|
|
|
|
=item transpose C< LIST >
|
5558
|
|
|
|
|
|
|
|
5559
|
|
|
|
|
|
|
C< transpose > computes the 90 degree rotation of its arguments, which must be
|
5560
|
|
|
|
|
|
|
a single multidimensional array or generator, or a list of 1+ dimensional
|
5561
|
|
|
|
|
|
|
structures.
|
5562
|
|
|
|
|
|
|
|
5563
|
|
|
|
|
|
|
say transpose([[1, 2, 3]])->perl; # [[1], [2], [3]]
|
5564
|
|
|
|
|
|
|
|
5565
|
|
|
|
|
|
|
say transpose([[1, 1], [2, 2], [3, 3]])->perl; # [[1, 2, 3], [1, 2, 3]]
|
5566
|
|
|
|
|
|
|
|
5567
|
|
|
|
|
|
|
say transpose(<1..>, <2..>, <3..>)->take(5)->perl;
|
5568
|
|
|
|
|
|
|
# [[1, 2, 3], [2, 3, 4], [3, 4, 5], [4, 5, 6], [5, 6, 7]]
|
5569
|
|
|
|
|
|
|
|
5570
|
|
|
|
|
|
|
=cut
|
5571
|
|
|
|
|
|
|
|
5572
|
|
|
|
|
|
|
sub transpose {
|
5573
|
0
|
0
|
|
0
|
1
|
0
|
my $src = @_ == 1 ? shift : \@_;
|
5574
|
0
|
0
|
|
|
|
0
|
return empty unless @$src;
|
5575
|
0
|
0
|
0
|
|
|
0
|
if (isagen $$src[0] and $$src[0]->is_mutable) {
|
5576
|
|
|
|
|
|
|
iterate_multi {
|
5577
|
0
|
|
|
0
|
|
0
|
my $i = $_;
|
5578
|
0
|
|
0
|
|
|
0
|
$i < $_->size or done for @$src;
|
5579
|
0
|
|
|
|
|
0
|
$_->get($i) for @$src;
|
5580
|
0
|
|
0
|
|
|
0
|
$i < $_->size or done for @$src;
|
5581
|
|
|
|
|
|
|
$i + 1 < $_->size or do {
|
5582
|
0
|
0
|
|
|
|
0
|
done mutable gen {$i < @$_ ? $$_[$i] : done} $src
|
|
0
|
|
|
|
|
0
|
|
5583
|
0
|
|
0
|
|
|
0
|
} for @$src;
|
5584
|
0
|
0
|
|
|
|
0
|
mutable gen {$i < @$_ ? $$_[$i] : done} $src
|
|
0
|
|
|
|
|
0
|
|
5585
|
|
|
|
|
|
|
}
|
5586
|
0
|
|
|
|
|
0
|
} else {
|
5587
|
|
|
|
|
|
|
iterate {
|
5588
|
0
|
|
|
0
|
|
0
|
my $i = $_;
|
5589
|
0
|
|
|
|
|
0
|
gen {$$_[$i]} $src
|
|
0
|
|
|
|
|
0
|
|
5590
|
0
|
|
|
|
|
0
|
} 0+@{$$src[0]}
|
|
0
|
|
|
|
|
0
|
|
5591
|
|
|
|
|
|
|
}
|
5592
|
|
|
|
|
|
|
}
|
5593
|
|
|
|
|
|
|
|
5594
|
|
|
|
|
|
|
|
5595
|
|
|
|
|
|
|
=item cartesian C< {CODE} LIST >
|
5596
|
|
|
|
|
|
|
|
5597
|
|
|
|
|
|
|
C< cartesian > computes the cartesian product of any number of array refs or
|
5598
|
|
|
|
|
|
|
generators, each which can be any size. returns a generator
|
5599
|
|
|
|
|
|
|
|
5600
|
|
|
|
|
|
|
my $product = cartesian {$_[0] . $_[1]} [qw/a b/], [1, 2];
|
5601
|
|
|
|
|
|
|
|
5602
|
|
|
|
|
|
|
@$product == qw( a1 a2 b1 b2 );
|
5603
|
|
|
|
|
|
|
|
5604
|
|
|
|
|
|
|
=cut
|
5605
|
|
|
|
|
|
|
|
5606
|
|
|
|
|
|
|
sub cartesian (&@) {
|
5607
|
0
|
|
|
0
|
1
|
0
|
my $code = shift;
|
5608
|
0
|
|
|
|
|
0
|
my @src = @_;
|
5609
|
0
|
|
|
|
|
0
|
my @size = map {0+@$_} @src;
|
|
0
|
|
|
|
|
0
|
|
5610
|
0
|
|
|
|
|
0
|
my $size = 1;
|
5611
|
0
|
|
0
|
|
|
0
|
my @cycle = map {$size / $_}
|
|
0
|
|
|
|
|
0
|
|
5612
|
0
|
|
|
|
|
0
|
map {$size *= $size[$_] || 1} 0 .. $#src;
|
5613
|
|
|
|
|
|
|
gen {
|
5614
|
0
|
|
|
0
|
|
0
|
my $i = $_;
|
5615
|
0
|
0
|
|
|
|
0
|
$code->(map {
|
5616
|
0
|
|
|
|
|
0
|
$size[$_] ? $src[$_][ $i / $cycle[$_] % $size[$_] ] : ()
|
5617
|
|
|
|
|
|
|
} 0 .. $#src)
|
5618
|
0
|
|
|
|
|
0
|
} 0 => $size - 1
|
5619
|
|
|
|
|
|
|
}
|
5620
|
|
|
|
|
|
|
|
5621
|
|
|
|
|
|
|
|
5622
|
|
|
|
|
|
|
=back
|
5623
|
|
|
|
|
|
|
|
5624
|
|
|
|
|
|
|
=head2 misc functions
|
5625
|
|
|
|
|
|
|
|
5626
|
|
|
|
|
|
|
=over 4
|
5627
|
|
|
|
|
|
|
|
5628
|
|
|
|
|
|
|
=item mapkey C< {CODE} KEY LIST >
|
5629
|
|
|
|
|
|
|
|
5630
|
|
|
|
|
|
|
this function is syntactic sugar for the following idiom
|
5631
|
|
|
|
|
|
|
|
5632
|
|
|
|
|
|
|
my @cartesian_product =
|
5633
|
|
|
|
|
|
|
map {
|
5634
|
|
|
|
|
|
|
my $first = $_;
|
5635
|
|
|
|
|
|
|
map {
|
5636
|
|
|
|
|
|
|
my $second = $_;
|
5637
|
|
|
|
|
|
|
map {
|
5638
|
|
|
|
|
|
|
$first . $second . $_
|
5639
|
|
|
|
|
|
|
} 1 .. 3
|
5640
|
|
|
|
|
|
|
} qw/x y z/
|
5641
|
|
|
|
|
|
|
} qw/a b c/;
|
5642
|
|
|
|
|
|
|
|
5643
|
|
|
|
|
|
|
my @cartesian_product =
|
5644
|
|
|
|
|
|
|
mapkey {
|
5645
|
|
|
|
|
|
|
mapkey {
|
5646
|
|
|
|
|
|
|
mapkey {
|
5647
|
|
|
|
|
|
|
$_{first} . $_{second} . $_{third}
|
5648
|
|
|
|
|
|
|
} third => 1 .. 3
|
5649
|
|
|
|
|
|
|
} second => qw/x y z/
|
5650
|
|
|
|
|
|
|
} first => qw/a b c/;
|
5651
|
|
|
|
|
|
|
|
5652
|
|
|
|
|
|
|
=cut
|
5653
|
|
|
|
|
|
|
|
5654
|
|
|
|
|
|
|
sub mapkey (&$@) {
|
5655
|
0
|
|
|
0
|
1
|
0
|
my ($code, $key) = splice @_, 0, 2;
|
5656
|
0
|
|
|
|
|
0
|
local $_{$key};
|
5657
|
0
|
|
|
|
|
0
|
map {
|
5658
|
0
|
|
|
|
|
0
|
$_{$key} = $_;
|
5659
|
0
|
|
|
|
|
0
|
$code->()
|
5660
|
|
|
|
|
|
|
} @_
|
5661
|
|
|
|
|
|
|
}
|
5662
|
|
|
|
|
|
|
|
5663
|
|
|
|
|
|
|
|
5664
|
|
|
|
|
|
|
=item mapab C< {CODE} PAIRS >
|
5665
|
|
|
|
|
|
|
|
5666
|
|
|
|
|
|
|
this function works like the builtin C< map > but consumes a list in pairs,
|
5667
|
|
|
|
|
|
|
rather than one element at a time. inside the C< CODE > block, the variables
|
5668
|
|
|
|
|
|
|
C< $a > and C< $b > are aliased to the elements of the list. if C< mapab > is
|
5669
|
|
|
|
|
|
|
called in void context, the C< CODE > block will be executed in void context
|
5670
|
|
|
|
|
|
|
for efficiency. if C< mapab > is passed an uneven length list, in the final
|
5671
|
|
|
|
|
|
|
iteration, C< $b > will be C< undef >
|
5672
|
|
|
|
|
|
|
|
5673
|
|
|
|
|
|
|
my %hash = (a => 1, b => 2, c => 3);
|
5674
|
|
|
|
|
|
|
|
5675
|
|
|
|
|
|
|
my %reverse = mapab {$b, $a} %hash;
|
5676
|
|
|
|
|
|
|
|
5677
|
|
|
|
|
|
|
=cut
|
5678
|
|
|
|
|
|
|
|
5679
|
|
|
|
|
|
|
sub mapab (&%) {
|
5680
|
0
|
|
|
0
|
1
|
0
|
my ($code, @ret) = shift;
|
5681
|
0
|
|
|
|
|
0
|
my $want = defined wantarray;
|
5682
|
0
|
|
|
|
|
0
|
my ($a, $b) = $code->$cv_ab_ref;
|
5683
|
0
|
|
|
|
|
0
|
local (*$a, *$b);
|
5684
|
0
|
|
|
|
|
0
|
while (@_) {
|
5685
|
0
|
0
|
|
|
|
0
|
if (@_ == 1) {
|
5686
|
0
|
|
|
|
|
0
|
*$a = \shift;
|
5687
|
0
|
|
|
|
|
0
|
*$b = \undef;
|
5688
|
|
|
|
|
|
|
} else {
|
5689
|
0
|
|
|
|
|
0
|
(*$a, *$b) = \splice @_, 0, 2
|
5690
|
|
|
|
|
|
|
}
|
5691
|
0
|
0
|
|
|
|
0
|
if ($want) {push @ret => $code->()}
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
5692
|
|
|
|
|
|
|
else {$code->()}
|
5693
|
|
|
|
|
|
|
}
|
5694
|
|
|
|
|
|
|
@ret
|
5695
|
0
|
|
|
|
|
0
|
}
|
5696
|
|
|
|
|
|
|
|
5697
|
|
|
|
|
|
|
|
5698
|
|
|
|
|
|
|
=item slide C< {CODE} WINDOW LIST >
|
5699
|
|
|
|
|
|
|
|
5700
|
|
|
|
|
|
|
slides a C< WINDOW > sized slice over C< LIST >, calling C< CODE > for each
|
5701
|
|
|
|
|
|
|
slice and collecting the result
|
5702
|
|
|
|
|
|
|
|
5703
|
|
|
|
|
|
|
as the window reaches the end, the passed in slice will shrink
|
5704
|
|
|
|
|
|
|
|
5705
|
|
|
|
|
|
|
print slide {"@_\n"} 2 => 1 .. 4
|
5706
|
|
|
|
|
|
|
# 1 2
|
5707
|
|
|
|
|
|
|
# 2 3
|
5708
|
|
|
|
|
|
|
# 3 4
|
5709
|
|
|
|
|
|
|
# 4 # only one element here
|
5710
|
|
|
|
|
|
|
|
5711
|
|
|
|
|
|
|
=cut
|
5712
|
|
|
|
|
|
|
|
5713
|
|
|
|
|
|
|
sub slide (&$@) {
|
5714
|
0
|
|
|
0
|
1
|
0
|
my ($code, $window) = splice @_, 0, 2;
|
5715
|
0
|
|
|
|
|
0
|
$window--;
|
5716
|
0
|
|
|
|
|
0
|
map $code->(@_[$_ .. min $_+$window, $#_]) => 0 .. $#_
|
5717
|
|
|
|
|
|
|
}
|
5718
|
|
|
|
|
|
|
|
5719
|
|
|
|
|
|
|
|
5720
|
|
|
|
|
|
|
=item remove C< {CODE} ARRAY|HASH >
|
5721
|
|
|
|
|
|
|
|
5722
|
|
|
|
|
|
|
C< remove > removes and returns elements from its source when C< CODE >
|
5723
|
|
|
|
|
|
|
returns true. in the code block, if the source is an array, C< $_ > is aliased
|
5724
|
|
|
|
|
|
|
to its elements. if the source is a hash, C< $_ > is aliased to its keys (and
|
5725
|
|
|
|
|
|
|
a list of the removed C<< key => value >> pairs are returned).
|
5726
|
|
|
|
|
|
|
|
5727
|
|
|
|
|
|
|
my @array = (1, 7, 6, 3, 8, 4);
|
5728
|
|
|
|
|
|
|
my @removed = remove {$_ > 5} @array;
|
5729
|
|
|
|
|
|
|
|
5730
|
|
|
|
|
|
|
say "@array"; # 1 3 4
|
5731
|
|
|
|
|
|
|
say "@removed"; # 7 6 8
|
5732
|
|
|
|
|
|
|
|
5733
|
|
|
|
|
|
|
in list context, C< remove > returns the list of removed elements/pairs.
|
5734
|
|
|
|
|
|
|
in scalar context, it returns the number of removals. C< remove > will not
|
5735
|
|
|
|
|
|
|
build a return list in void context for efficiency.
|
5736
|
|
|
|
|
|
|
|
5737
|
|
|
|
|
|
|
=cut
|
5738
|
|
|
|
|
|
|
|
5739
|
|
|
|
|
|
|
sub remove (&\[@%]) {
|
5740
|
0
|
|
|
0
|
1
|
0
|
my ($code, $src) = @_;
|
5741
|
0
|
|
|
|
|
0
|
my ($want, @ret) = defined wantarray;
|
5742
|
0
|
|
|
|
|
0
|
local *_;
|
5743
|
0
|
0
|
|
|
|
0
|
if (reftype $src eq 'ARRAY') {
|
5744
|
0
|
|
|
|
|
0
|
my $i = 0;
|
5745
|
0
|
|
|
|
|
0
|
while ($i < @$src) {
|
5746
|
0
|
|
|
|
|
0
|
*_ = \$$src[$i];
|
5747
|
0
|
0
|
|
|
|
0
|
&$code ? $want ? push @ret, splice @$src, $i, 1
|
|
|
0
|
|
|
|
|
|
5748
|
|
|
|
|
|
|
: splice @$src, $i, 1
|
5749
|
|
|
|
|
|
|
: $i++
|
5750
|
|
|
|
|
|
|
}
|
5751
|
|
|
|
|
|
|
}
|
5752
|
|
|
|
|
|
|
else {
|
5753
|
0
|
|
|
|
|
0
|
for (keys %$src) {
|
5754
|
0
|
0
|
|
|
|
0
|
if (&$code) {
|
5755
|
0
|
0
|
|
|
|
0
|
$want ? push @ret, $_ => delete $$src{$_}
|
5756
|
|
|
|
|
|
|
: delete $$src{$_}
|
5757
|
|
|
|
|
|
|
}
|
5758
|
|
|
|
|
|
|
}
|
5759
|
|
|
|
|
|
|
}
|
5760
|
|
|
|
|
|
|
wantarray
|
5761
|
|
|
|
|
|
|
? @ret
|
5762
|
0
|
0
|
|
|
|
0
|
: reftype $src eq 'HASH'
|
|
|
0
|
|
|
|
|
|
5763
|
|
|
|
|
|
|
? @ret / 2
|
5764
|
|
|
|
|
|
|
: @ret
|
5765
|
|
|
|
|
|
|
}
|
5766
|
|
|
|
|
|
|
|
5767
|
|
|
|
|
|
|
|
5768
|
|
|
|
|
|
|
=item d C< [SCALAR] >
|
5769
|
|
|
|
|
|
|
|
5770
|
|
|
|
|
|
|
=item deref C< [SCALAR] >
|
5771
|
|
|
|
|
|
|
|
5772
|
|
|
|
|
|
|
dereference a C< SCALAR >, C< ARRAY >, or C< HASH > reference. any other value
|
5773
|
|
|
|
|
|
|
is returned unchanged
|
5774
|
|
|
|
|
|
|
|
5775
|
|
|
|
|
|
|
print join " " => map deref, 1, [2, 3, 4], \5, {6 => 7}, 8, 9, 10;
|
5776
|
|
|
|
|
|
|
# prints 1 2 3 4 5 6 7 8 9 10
|
5777
|
|
|
|
|
|
|
|
5778
|
|
|
|
|
|
|
=cut
|
5779
|
|
|
|
|
|
|
|
5780
|
|
|
|
|
|
|
sub d (;$) {
|
5781
|
280
|
50
|
|
280
|
1
|
780
|
local *_ = \$_[0] if @_;
|
5782
|
280
|
|
|
|
|
774
|
my $type = reftype $_;
|
5783
|
280
|
0
|
|
|
|
1015
|
$type ?
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
5784
|
|
|
|
|
|
|
$type eq 'ARRAY' ? @$_ :
|
5785
|
|
|
|
|
|
|
$type eq 'HASH' ? %$_ :
|
5786
|
|
|
|
|
|
|
$type eq 'SCALAR' ? $$_ : $_
|
5787
|
|
|
|
|
|
|
: $_
|
5788
|
|
|
|
|
|
|
}
|
5789
|
10
|
|
|
10
|
|
3022
|
BEGIN {*deref = \&d}
|
5790
|
|
|
|
|
|
|
|
5791
|
|
|
|
|
|
|
|
5792
|
|
|
|
|
|
|
=item curse C< HASHREF PACKAGE >
|
5793
|
|
|
|
|
|
|
|
5794
|
|
|
|
|
|
|
many of the functions in this package utilize closure objects to avoid the speed
|
5795
|
|
|
|
|
|
|
penalty of dereferencing fields in their object during each access. C< curse >
|
5796
|
|
|
|
|
|
|
is similar to C< bless > for these objects and while a blessing makes a
|
5797
|
|
|
|
|
|
|
reference into a member of an existing package, a curse conjures a new package
|
5798
|
|
|
|
|
|
|
to do the reference's bidding
|
5799
|
|
|
|
|
|
|
|
5800
|
|
|
|
|
|
|
package Closure::Object;
|
5801
|
|
|
|
|
|
|
sub new {
|
5802
|
|
|
|
|
|
|
my ($class, $name, $value) = @_;
|
5803
|
|
|
|
|
|
|
curse {
|
5804
|
|
|
|
|
|
|
get => sub {$value},
|
5805
|
|
|
|
|
|
|
set => sub {$value = $_[1]},
|
5806
|
|
|
|
|
|
|
name => sub {$name},
|
5807
|
|
|
|
|
|
|
} => $class
|
5808
|
|
|
|
|
|
|
}
|
5809
|
|
|
|
|
|
|
|
5810
|
|
|
|
|
|
|
C<< Closure::Object >> is functionally equivalent to the following normal perl
|
5811
|
|
|
|
|
|
|
object, but with faster method calls since there are no hash lookups or other
|
5812
|
|
|
|
|
|
|
dereferences (around 40-50% faster for short getter/setter type methods)
|
5813
|
|
|
|
|
|
|
|
5814
|
|
|
|
|
|
|
package Normal::Object;
|
5815
|
|
|
|
|
|
|
sub new {
|
5816
|
|
|
|
|
|
|
my ($class, $name, $value) = @_;
|
5817
|
|
|
|
|
|
|
bless {
|
5818
|
|
|
|
|
|
|
name => $name,
|
5819
|
|
|
|
|
|
|
value => $value,
|
5820
|
|
|
|
|
|
|
} => $class
|
5821
|
|
|
|
|
|
|
}
|
5822
|
|
|
|
|
|
|
sub get {$_[0]{value}}
|
5823
|
|
|
|
|
|
|
sub set {$_[0]{value} = $_[1]}
|
5824
|
|
|
|
|
|
|
sub name {$_[0]{name}}
|
5825
|
|
|
|
|
|
|
|
5826
|
|
|
|
|
|
|
the trade off is in creation time / memory, since any good curse requires
|
5827
|
|
|
|
|
|
|
drawing at least a few pentagrams in the blood of an innocent package.
|
5828
|
|
|
|
|
|
|
|
5829
|
|
|
|
|
|
|
the returned object is blessed into the conjured package, which inherits from
|
5830
|
|
|
|
|
|
|
the provided C< PACKAGE >. always use C<< $obj->isa(...) >> rather than
|
5831
|
|
|
|
|
|
|
C< ref $obj eq ... > due to this. the conjured package name matches
|
5832
|
|
|
|
|
|
|
C<< /${PACKAGE}::_\d+/ >>
|
5833
|
|
|
|
|
|
|
|
5834
|
|
|
|
|
|
|
special keys:
|
5835
|
|
|
|
|
|
|
|
5836
|
|
|
|
|
|
|
-bless => $reference # returned instead of HASHREF
|
5837
|
|
|
|
|
|
|
-overload => [fallback => 1, '""' => sub {...}]
|
5838
|
|
|
|
|
|
|
|
5839
|
|
|
|
|
|
|
when fast just isn't fast enough, since most cursed methods don't need to be
|
5840
|
|
|
|
|
|
|
passed their object, the fastest way to call the method is:
|
5841
|
|
|
|
|
|
|
|
5842
|
|
|
|
|
|
|
my $obj = Closure::Object->new('tim', 3);
|
5843
|
|
|
|
|
|
|
my $set = $obj->{set}; # fetch the closure
|
5844
|
|
|
|
|
|
|
# or $obj->can('set')
|
5845
|
|
|
|
|
|
|
|
5846
|
|
|
|
|
|
|
$set->(undef, $_) for 1 .. 1_000_000; # call without first arg
|
5847
|
|
|
|
|
|
|
|
5848
|
|
|
|
|
|
|
which is around 70% faster than pre-caching a method from a normal object for
|
5849
|
|
|
|
|
|
|
short getter/setter methods, and is the method used internally in this module.
|
5850
|
|
|
|
|
|
|
|
5851
|
|
|
|
|
|
|
=back
|
5852
|
|
|
|
|
|
|
|
5853
|
|
|
|
|
|
|
=head1 SEE ALSO
|
5854
|
|
|
|
|
|
|
|
5855
|
|
|
|
|
|
|
=over 4
|
5856
|
|
|
|
|
|
|
|
5857
|
|
|
|
|
|
|
=item * see L for usage tips.
|
5858
|
|
|
|
|
|
|
|
5859
|
|
|
|
|
|
|
=item * see L for performance tips.
|
5860
|
|
|
|
|
|
|
|
5861
|
|
|
|
|
|
|
=item * see L for an experimental implementation of
|
5862
|
|
|
|
|
|
|
haskell's lazy list behavior.
|
5863
|
|
|
|
|
|
|
|
5864
|
|
|
|
|
|
|
=item * see L for the tools used to create
|
5865
|
|
|
|
|
|
|
L.
|
5866
|
|
|
|
|
|
|
|
5867
|
|
|
|
|
|
|
=item * see L for some of perl's operators implemented
|
5868
|
|
|
|
|
|
|
as lazy haskell like functions.
|
5869
|
|
|
|
|
|
|
|
5870
|
|
|
|
|
|
|
=item * see L for most of perl's builtin functions
|
5871
|
|
|
|
|
|
|
implemented as lazy haskell like functions.
|
5872
|
|
|
|
|
|
|
|
5873
|
|
|
|
|
|
|
=item * see L for a source filter that adds perl6's meta
|
5874
|
|
|
|
|
|
|
operators to use with generators, rather than the default overloaded operators
|
5875
|
|
|
|
|
|
|
|
5876
|
|
|
|
|
|
|
=back
|
5877
|
|
|
|
|
|
|
|
5878
|
|
|
|
|
|
|
=head1 CAVEATS
|
5879
|
|
|
|
|
|
|
|
5880
|
|
|
|
|
|
|
version 0.90 added C< glob > to the default export list (which gives you
|
5881
|
|
|
|
|
|
|
syntactic ranges C<< <1 .. 10> >> and list comprehensions.). version 0.90 also
|
5882
|
|
|
|
|
|
|
adds many new features and bug-fixes, as usual, if anything is broken, please
|
5883
|
|
|
|
|
|
|
send in a bug report. the ending conditions of C< zip > and C< zipgen > have
|
5884
|
|
|
|
|
|
|
changed, see the documentation above. C< test > has been removed from the
|
5885
|
|
|
|
|
|
|
default export list. setting C< $List::Gen::LIST > true to enable list context
|
5886
|
|
|
|
|
|
|
generators is no longer supported and will now throw an error. C< list > has
|
5887
|
|
|
|
|
|
|
been added to the default export list. C< genzip > has been renamed C< zipgen >
|
5888
|
|
|
|
|
|
|
|
5889
|
|
|
|
|
|
|
version 0.70 comes with a bunch of new features, if anything is broken, please
|
5890
|
|
|
|
|
|
|
let me know. see C< filter > for a minor behavior change
|
5891
|
|
|
|
|
|
|
|
5892
|
|
|
|
|
|
|
versions 0.50 and 0.60 break some of the syntax from previous versions,
|
5893
|
|
|
|
|
|
|
for the better.
|
5894
|
|
|
|
|
|
|
|
5895
|
|
|
|
|
|
|
=over 4
|
5896
|
|
|
|
|
|
|
|
5897
|
|
|
|
|
|
|
=item code generation
|
5898
|
|
|
|
|
|
|
|
5899
|
|
|
|
|
|
|
a number of the syntactic shortcuts that List::Gen provides will construct and
|
5900
|
|
|
|
|
|
|
then evaluate code behind the scenes. Normally this is transparent, but if you
|
5901
|
|
|
|
|
|
|
are trying to debug a problem, hidden code is never a good thing. You can
|
5902
|
|
|
|
|
|
|
lexically enable the printing of evaled code with:
|
5903
|
|
|
|
|
|
|
|
5904
|
|
|
|
|
|
|
local $List::Gen::SAY_EVAL = 1;
|
5905
|
|
|
|
|
|
|
|
5906
|
|
|
|
|
|
|
my $fib = <0, 1, *+*...>;
|
5907
|
|
|
|
|
|
|
|
5908
|
|
|
|
|
|
|
# eval: ' @pre = (0, 1)' at (file.pl) line ##
|
5909
|
|
|
|
|
|
|
# eval: 'List::Gen::iterate { if (@pre) {shift @pre}
|
5910
|
|
|
|
|
|
|
# else { $fetch->(undef, $_ - 2) + $fetch->(undef, $_ - 1) }
|
5911
|
|
|
|
|
|
|
# } 9**9**9' at (file.pl) line ##
|
5912
|
|
|
|
|
|
|
|
5913
|
|
|
|
|
|
|
my $gen = <1..10>->map('$_*2 + 1')->grep('some_predicate');
|
5914
|
|
|
|
|
|
|
|
5915
|
|
|
|
|
|
|
# eval: 'sub ($) {$_*2 + 1}' at (file.pl) line ##
|
5916
|
|
|
|
|
|
|
# eval: 'sub ($) {some_predicate($_)}' at (file.pl) line ##
|
5917
|
|
|
|
|
|
|
|
5918
|
|
|
|
|
|
|
a given code string is only evaluated once and is then cached, so you will not
|
5919
|
|
|
|
|
|
|
see any additional output when using the same code strings in multiple places.
|
5920
|
|
|
|
|
|
|
in some cases (like the iterate example above) the code is closing over external
|
5921
|
|
|
|
|
|
|
variables (C< @pre > and C< $fetch >) so you will not be able to see everything,
|
5922
|
|
|
|
|
|
|
but C< $SAY_EVAL > should be a helpful debugging aid.
|
5923
|
|
|
|
|
|
|
|
5924
|
|
|
|
|
|
|
any time that code evaluation fails, an immediate fatal error is thrown. the
|
5925
|
|
|
|
|
|
|
value of C< $SAY_EVAL > does not matter in that case.
|
5926
|
|
|
|
|
|
|
|
5927
|
|
|
|
|
|
|
=item captures of compile time constructed lists
|
5928
|
|
|
|
|
|
|
|
5929
|
|
|
|
|
|
|
the C< cap > function and its twin operator C< &\ > are faster than the
|
5930
|
|
|
|
|
|
|
C< [...] > construct because they do not copy their arguments. this is why the
|
5931
|
|
|
|
|
|
|
elements of the captures remain aliased to their arguments. this is normally
|
5932
|
|
|
|
|
|
|
fine, but it has an interesting effect with compile time constructed constant
|
5933
|
|
|
|
|
|
|
lists:
|
5934
|
|
|
|
|
|
|
|
5935
|
|
|
|
|
|
|
my $max = 1000;
|
5936
|
|
|
|
|
|
|
my $range = & \(1 .. $max); # 57% faster than [1 .. $max]
|
5937
|
|
|
|
|
|
|
my $nums = & \(1 .. 1000); # 366% faster than [1 .. 1000], but cheating
|
5938
|
|
|
|
|
|
|
|
5939
|
|
|
|
|
|
|
the first example shows the expected speed increase due to not copying the
|
5940
|
|
|
|
|
|
|
values into a new empty array reference. the second example is much faster at
|
5941
|
|
|
|
|
|
|
runtime than the C< [...] > syntax, but this speed is deceptive. the reason is
|
5942
|
|
|
|
|
|
|
that the list being passed in as an argument is generated by the compiler before
|
5943
|
|
|
|
|
|
|
runtime begins. so all perl has to do is place the values on the stack, and
|
5944
|
|
|
|
|
|
|
call the function.
|
5945
|
|
|
|
|
|
|
|
5946
|
|
|
|
|
|
|
normally this is fine, but there is one catch to be aware of, and that is that
|
5947
|
|
|
|
|
|
|
a capture of a compile time constant list in a loop or subroutine (or any
|
5948
|
|
|
|
|
|
|
structure that can execute the same segment of code repeatedly) will always
|
5949
|
|
|
|
|
|
|
return a reference to an array of the same elements.
|
5950
|
|
|
|
|
|
|
|
5951
|
|
|
|
|
|
|
# two instances give two separate arrays
|
5952
|
|
|
|
|
|
|
my ($a, $b) = (&\(1 .. 3), &\(1 .. 3));
|
5953
|
|
|
|
|
|
|
$_ += 10 for @$a;
|
5954
|
|
|
|
|
|
|
say "@$a : @$b"; # 11 12 13 : 1 2 3
|
5955
|
|
|
|
|
|
|
|
5956
|
|
|
|
|
|
|
# here the one instance returns the same elements twice
|
5957
|
|
|
|
|
|
|
my ($x, $y) = map &\(1 .. 3), 1 .. 2;
|
5958
|
|
|
|
|
|
|
$_ += 10 for @$x;
|
5959
|
|
|
|
|
|
|
say "@$x : @$y"; # 11 12 13 : 11 12 13
|
5960
|
|
|
|
|
|
|
|
5961
|
|
|
|
|
|
|
this only applies to compile time constructed constant lists, anything
|
5962
|
|
|
|
|
|
|
containing a variable or non constant function call will give you separate
|
5963
|
|
|
|
|
|
|
array elements, as shown below:
|
5964
|
|
|
|
|
|
|
|
5965
|
|
|
|
|
|
|
my ($low, $high) = (1, 3);
|
5966
|
|
|
|
|
|
|
my ($x, $y) = map &\($low .. $high), 1 .. 2; # non constant list
|
5967
|
|
|
|
|
|
|
$_ += 10 for @$x;
|
5968
|
|
|
|
|
|
|
say "@$x : @$y"; # 11 12 13 : 1 2 3
|
5969
|
|
|
|
|
|
|
|
5970
|
|
|
|
|
|
|
=back
|
5971
|
|
|
|
|
|
|
|
5972
|
|
|
|
|
|
|
=head1 AUTHOR
|
5973
|
|
|
|
|
|
|
|
5974
|
|
|
|
|
|
|
Eric Strom, C<< >>
|
5975
|
|
|
|
|
|
|
|
5976
|
|
|
|
|
|
|
=head1 BUGS
|
5977
|
|
|
|
|
|
|
|
5978
|
|
|
|
|
|
|
overloading has gotten fairly complicated and is probably in need of a rewrite.
|
5979
|
|
|
|
|
|
|
if any edge cases do not work, please send in a bug report.
|
5980
|
|
|
|
|
|
|
|
5981
|
|
|
|
|
|
|
both threaded methods (C<< $gen->threads_slice(...) >>) and function composition
|
5982
|
|
|
|
|
|
|
with overloaded operators (made with C) do not work
|
5983
|
|
|
|
|
|
|
properly in versions of perl before 5.10. patches welcome
|
5984
|
|
|
|
|
|
|
|
5985
|
|
|
|
|
|
|
report any bugs / feature requests to C, or through
|
5986
|
|
|
|
|
|
|
the web interface at L.
|
5987
|
|
|
|
|
|
|
|
5988
|
|
|
|
|
|
|
comments / feedback / patches are also welcome.
|
5989
|
|
|
|
|
|
|
|
5990
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE
|
5991
|
|
|
|
|
|
|
|
5992
|
|
|
|
|
|
|
copyright 2009-2011 Eric Strom.
|
5993
|
|
|
|
|
|
|
|
5994
|
|
|
|
|
|
|
this program is free software; you can redistribute it and/or modify it under
|
5995
|
|
|
|
|
|
|
the terms of either: the GNU General Public License as published by the Free
|
5996
|
|
|
|
|
|
|
Software Foundation; or the Artistic License.
|
5997
|
|
|
|
|
|
|
|
5998
|
|
|
|
|
|
|
see http://dev.perl.org/licenses/ for more information.
|
5999
|
|
|
|
|
|
|
|
6000
|
|
|
|
|
|
|
=cut
|
6001
|
|
|
|
|
|
|
|
6002
|
|
|
|
|
|
|
__PACKAGE__ if 'first require';
|