FunctionalPerl
view release on metacpan or search on metacpan
lib/FP/List.pm view on Meta::CPAN
pair improper_list improper_map improper_filtermap improper_last
first_set first_update
is_pair_noforce is_null_noforce
unsafe_cons unsafe_car unsafe_cdr
string_to_list list_length list_reverse list_reverse_with_tail
list_to_string list_to_array rlist_to_array
list_to_values rlist_to_values
write_sexpr
array_to_list array_to_list_reverse mixed_flatten
list_strings_join list_strings_join_reverse
list_filter list_map list_filtermap list_mapn list_map_with_islast
list_map_with_index_ list_map_with_index
list_fold list_fold_right list_to_perlstring
unfold unfold_right
list_pair_fold_right
list_butlast list_drop_while list_rtake_while list_take_while
list_rtake_while_and_rest list_take_while_and_rest
list_append
list_zip2
list_alist
list_last
list_every list_all list_any list_none
list_perhaps_find_tail list_perhaps_find
list_find_tail list_find
list_insertion_variants
list_merge
cartesian_product_2
cartesian_product
is_charlist ldie
cddr
cdddr
cddddr
cadr
caddr
cadddr
caddddr
c_r
list_ref
list_perhaps_one
list_sort
list_drop
list_take
list_slice
list_group
circularlist
weaklycircularlist
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use 5.008; # for Internals::SvREADONLY
use FP::Lazy;
use FP::Lazy qw(force_noeval);
use Chj::xperlfunc qw(xprint xprintln);
use FP::Combinators qw(flip flip2of3 rot3right rot3left);
use FP::Optional qw(perhaps_to_maybe);
use Chj::TEST;
use FP::Predicates qw(is_natural0 either is_natural complement is_even is_zero);
use FP::Div qw(inc dec);
use FP::Show;
use Scalar::Util qw(weaken blessed);
use FP::Weak qw(Weakened);
use FP::Interfaces;
use Carp;
use FP::Carp;
use FP::Docstring;
our $immutable = 1; # whether pairs are to be made immutable
#use FP::Array 'array_fold_right'; can't, recursive dependency XX (see copy below)
#(Chj::xIOUtil triggers it)
package FP::List::List {
use FP::Lazy;
use FP::Carp;
use Chj::NamespaceCleanAbove;
*null = \&FP::List::null;
sub pair_namespace {"FP::List::Pair"}
sub cons {
my $s = shift;
@_ == 1 or fp_croak_arity 1;
my @p = ($_[0], $s);
# Now it gets ~ugly: for lazy code, $s can (now, since
# AUTOLOAD on them doesn't necessarily force them anymore) now
# be a promise with field 2 set.
# my $immediate_class = ref($s);
# bless \@p,
# UNIVERSAL::isa($immediate_class, "FP::Lazy::AnyPromise")
# ? $$s[2]
# : $immediate_class;
# /ugly.
# OR, simply (since the above would void any chance of simply
# using `lazyT` in stream libraries since one couldn't know
# the type of cons cells statically)!:
bless \@p, $s->pair_namespace;
if ($immutable) {
Internals::SvREADONLY $p[0], 1;
Internals::SvREADONLY $p[1], 1;
}
Internals::SvREADONLY @p, 1;
\@p
}
# return this sequence as a list, i.e. identity
sub list {
@_ == 1 or fp_croak_arity 1;
$_[0]
}
sub stream {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
lazy {$l}
lib/FP/List.pm view on Meta::CPAN
} else {
$v->perhaps_first_and_rest
}
}
TEST { [cons(1, 2)->perhaps_first_and_rest] } [1, 2];
TEST { [null->perhaps_first_and_rest] } [];
TEST { [perhaps_first_and_rest cons(1, 2)] } [1, 2];
TEST { [perhaps_first_and_rest null] } [];
TEST_EXCEPTION { [perhaps_first_and_rest "FP::List::Null"] }
"not a pair: 'FP::List::Null'"; # and XX actually not a null either.
sub list_perhaps_one {
@_ == 1 or fp_croak_arity 1;
my ($s) = @_;
FORCE $s; # make work for stre
if (is_pair($s)) {
my ($a, $r) = first_and_rest $s;
if (is_null $r) { ($a) }
else { () }
} else {
()
}
}
*FP::List::List::perhaps_one = \&list_perhaps_one;
TEST { [list(8)->perhaps_one] } [8];
TEST { [list(8, 9)->perhaps_one] } [];
TEST { [list()->perhaps_one] } [];
sub list_xone {
@_ == 1 or fp_croak_arity 1;
my ($s) = @_;
FORCE $s; # make work for streams
if (is_pair($s)) {
my ($a, $r) = first_and_rest $s;
if (is_null $r) {
$a
} else {
die "expected 1 value, got more"
}
} else {
die "expected 1 value, got none"
}
}
*FP::List::List::xone = \&list_xone;
TEST { [list(8)->xone] } [8];
TEST_EXCEPTION { [list(8, 9)->xone] } "expected 1 value, got more";
TEST_EXCEPTION { [list()->xone] } "expected 1 value, got none";
sub make_ref {
my ($is_stream) = @_;
my $liststream = $is_stream ? "stream" : "list";
sub {
@_ == 2 or fp_croak_arity 2;
my ($s, $i) = @_;
weaken $_[0] if $is_stream;
is_natural0 $i or fp_croak "invalid index: " . show($i);
my $orig_i = $i;
LP: {
$s = force $s;
if (is_pair $s) {
if ($i <= 0) {
$s->car
} else {
$s = $s->cdr;
$i--;
redo LP;
}
} elsif (is_null $s) {
die "requested element $orig_i of $liststream of length "
. ($orig_i - $i)
} elsif (defined blessed($s) and my $m = $s->can("FP_Sequence_ref"))
{
@_ = ($s, $i);
goto $m
} else {
die "improper $liststream"
}
}
}
}
sub list_ref;
*list_ref = make_ref(0);
*FP::List::List::ref = \&list_ref;
sub list {
my $res = null;
for (my $i = $#_; $i >= 0; $i--) {
$res = cons($_[$i], $res);
}
$res
}
# Like 'list' but terminates the chain with the last argument instead
# of a 'null'. This shouldn't be used in normal circumstances. It's
# mainly here to make the output of FP_Show_show valid code.
sub improper_list {
my $res = pop;
for (my $i = $#_; $i >= 0; $i--) {
$res = cons($_[$i], $res);
}
$res
}
# These violate the principle of a purely functional data
# structure. Are they ok since they are constructors (the outside
# world will never see mutation)? (Note that streams can be cyclic
# already without mutating the cons cells, by way of using a recursive
# binding (mutating the variable that holds it, "my $s; $s = cons 1,
# lazy { $s };").)
# WARNING: results of this function won't be deallocated
# automatically. You have to break the reference cycle explicitely!
sub circularlist {
my $l = list(@_);
my $last = $l->drop($#_);
if ($immutable) {
Internals::SvREADONLY $$last[1], 0;
$$last[1] = $l;
Internals::SvREADONLY $$last[1], 1;
} else {
$$last[1] = $l;
}
$l
}
# And the result of this function will open up (interrupt the cycle)
# as soon as you let go of the front element.
sub weaklycircularlist {
my $l = list(@_);
my $last = $l->drop($#_);
if ($immutable) {
Internals::SvREADONLY $$last[1], 0;
$$last[1] = $l;
weaken($$last[1]);
Internals::SvREADONLY $$last[1], 1;
} else {
$$last[1] = $l;
weaken($$last[1]);
}
$l
}
use Chj::Destructor;
TEST {
my $z = 0;
my $v = do {
my $l = circularlist "a", "b", Destructor { $z++ }, "d";
$l->ref(5)
};
[$z, $v]
}
[0, "b"]; # leaking the test list!
TEST {
my $z = 0;
my $v = do {
my $l = weaklycircularlist "a", "b", Destructor { $z++ }, "d";
$l->ref(5)
};
[$z, $v]
}
[1, "b"]; # no leak.
TEST_EXCEPTION {
my $z = 0;
my $v = do {
my $l = weaklycircularlist "a", "b", Destructor { $z++ }, "d";
$l = $l->rest;
$l->ref(4)
};
[$z, $v]
}
'improper list'; # nice message at least, thanks to undef != null
sub delayed (&) {
@_ == 1 or fp_croak_arity 1;
my ($thunk) = @_;
sub {
# evaluate thunk, expecting a function and pass our arguments
# to that function
my $cont = &$thunk();
goto &$cont
}
}
sub list_of {
@_ == 1 or fp_croak_arity 1;
my ($p) = @_;
either \&is_null, is_pair_of($p, delayed { list_of($p) })
}
TEST { list_of(\&is_natural)->(list 1, 2, 3) } 1;
TEST { list_of(\&is_natural)->(list -1, 2, 3) } 0;
TEST { list_of(\&is_natural)->(list 1, 2, " 3") } 0;
TEST { list_of(\&is_natural)->(1) } 0;
TEST { list_of(\&is_natural)->(list()) } 1;
sub nonempty_list_of {
@_ == 1 or fp_croak_arity 1;
my ($p) = @_;
is_pair_of($p, delayed { list_of($p) })
}
TEST { nonempty_list_of(\&is_natural)->(list 1, 2, 3) } 1;
TEST { nonempty_list_of(\&is_natural)->(list -1, 2, 3) } 0;
TEST { nonempty_list_of(\&is_natural)->(list 1, 2, " 3") } 0;
TEST { nonempty_list_of(\&is_natural)->(1) } undef; # XX vs. above
TEST { nonempty_list_of(\&is_natural)->(list()) } ''; # vs. 0 ?
sub make_length {
my ($is_stream) = @_;
my $liststream = $is_stream ? "stream" : "list";
sub {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
weaken $_[0] if $is_stream;
my $len = 0;
$l = force $l;
while (!is_null $l) {
if (is_pair $l) {
$len++;
$l = force $l->cdr;
} elsif (defined blessed($l)
and my $m = $l->can("FP_Sequence_length"))
{
@_ = ($l, $len);
goto $m
} else {
die "improper $liststream"
}
}
$len
}
}
sub list_length;
*list_length = make_length(0);
*FP::List::Pair::length = \&list_length;
# method on Pair not List, since we defined a length method for Null
# explicitely
TEST { list(4, 5, 6)->caddr } 6;
TEST { list()->length } 0;
TEST { list(4, 5)->length } 2;
sub list_to_string {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
my $len = list_length $l;
# preallocation for the case where $l consists only of single
# characters (otherwise will extend dynamically):
my $res = " " x $len;
my $i = 0;
while (!is_null $l) {
my $c = car $l;
substr($res, $i, 1) = $c;
$l = cdr $l;
$i += length $c;
}
$res
}
*FP::List::List::string = \&list_to_string;
TEST { null->string } "";
TEST { cons("a", null)->string } "a";
TEST { list("Ha", "ll", "o")->string } "Hallo";
TEST { list("", "", "o")->string } 'o';
TEST { list("a", "", "o")->string } 'ao';
sub list_to_array {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
lib/FP/List.pm view on Meta::CPAN
[3, 4, 5, 8];
TEST { ref(list(5, 3, 8, 4)->sort (\&FP::Ops::real_cmp)) }
'FP::_::PureArray'; # XX ok? Need to `->list` if a list is needed
TEST { list(5, 3, 8, 4)->sort (\&FP::Ops::real_cmp)->list->car }
3; # but then PureArray has `first`, too, if that's all you need.
TEST { list(5, 3, 8, 4)->sort (\&FP::Ops::real_cmp)->first }
3;
#(just for completeness)
TEST { list(5, 3, 8, 4)->sort (\&FP::Ops::real_cmp)->stream->car }
3;
sub rlist_to_array {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
my $res = [];
my $len = list_length $l;
my $i = $len;
while (!is_null $l) {
$i--;
$$res[$i] = car $l;
$l = cdr $l;
}
$res
}
*FP::List::List::reverse_array = \&rlist_to_array;
sub list_to_values {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
@{ list_to_array($l) }
}
*FP::List::List::values = \&list_to_values;
# XX naming inconsistency versus docs/design.md ? Same with
# rlist_to_array.
sub rlist_to_values {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
@{ rlist_to_array($l) }
}
*FP::List::List::reverse_values = \&rlist_to_values;
TEST { [list(3, 4, 5)->reverse_values] }
[5, 4, 3];
sub make_for_each {
@_ == 2 or fp_croak_arity 2;
my ($is_stream, $with_islast) = @_;
my $liststream = $is_stream ? "stream" : "list";
sub {
@_ == 2 or fp_croak_arity 2;
my ($proc, $s) = @_;
weaken $_[1] if $is_stream;
LP: {
$s = force $s;
if (is_pair $s) {
my $s2 = cdr $s;
&$proc(scalar car($s), $with_islast ? scalar is_null($s2) : ());
$s = $s2;
redo LP;
} elsif (is_null $s) {
# drop out
} elsif (defined blessed($s) and my $m = $s->can("for_each")) {
@_ = ($s, $proc);
goto $m
} else {
die "improper $liststream"
}
}
}
}
sub list_for_each;
*list_for_each = make_for_each(1, 0);
*FP::List::List::for_each = flip \&list_for_each;
sub list_for_each_with_islast;
*list_for_each_with_islast = make_for_each(1, 1);
*FP::List::List::for_each_with_islast = flip \&list_for_each_with_islast;
TEST_STDOUT {
list(1, 3)->for_each(\&xprintln)
}
"1\n3\n";
# tons of slightly adapted COPIES from FP::Stream. XX finally find a
# solution for this
sub list_drop {
@_ == 2 or fp_croak_arity 2;
my ($s, $n) = @_;
while ($n > 0) {
$s = force $s;
die "list too short" if is_null $s;
$s = cdr $s;
$n--
}
$s
}
*FP::List::List::drop = \&list_drop;
sub list_take {
@_ == 2 or fp_croak_arity 2;
my ($s, $n) = @_;
if ($n > 0) {
$s = force $s;
is_null($s) ? $s : cons(car($s), list_take(cdr($s), $n - 1));
} else {
null
}
}
lib/FP/List.pm view on Meta::CPAN
if (is_null($l)) {
$maybe_tail // $l
} elsif (is_pair($l)) {
my @v = $fn->(car $l);
my $r = improper_filtermap($fn, cdr($l), $maybe_tail);
if (@v == 1) {
cons($v[0], $r)
} elsif (!@v) {
$r
} else {
die "not supporting multiple value returns from \$fn";
}
} else {
die "improper list"
}
}
sub FP::List::List::filtermap {
@_ == 2 or @_ == 3 or fp_croak_arity "2-3";
my ($l, $fn, $maybe_tail) = @_;
@_ = ($fn, $l, $maybe_tail);
goto \&list_filtermap
}
sub list_zip2 {
@_ == 2 or fp_croak_arity 2;
my ($l, $m) = @_;
( is_null($l) ? $l
: is_null($m) ? $m
: cons([car($l), car($m)], list_zip2(cdr($l), cdr($m))))
}
TEST { list_to_array list_zip2 list(qw(a b c)), list(2, 3) }
[[a => 2], [b => 3]];
TEST { list_to_array list_zip2 list(qw(a b)), list(2, 3, 4) }
[[a => 2], [b => 3]];
*FP::List::List::zip = \&list_zip2; # XX make n-ary
sub list_to_alist {
@_ == 1 or fp_croak_arity 1;
my ($l) = @_;
is_null($l) ? $l : do {
my ($k, $l2) = $l->first_and_rest;
my ($v, $l3) = $l2->first_and_rest;
cons(cons($k, $v), list_to_alist($l3))
}
}
*FP::List::List::alist = \&list_to_alist;
TEST_STDOUT { list(a => 10, b => 20)->alist->write_sexpr }
'(("a" . "10") ("b" . "20"))';
sub make_filter {
my ($is_stream) = @_;
my $filter;
$filter = sub {
@_ == 2 or fp_croak_arity 2;
my ($fn, $l) = @_;
weaken $_[1] if $is_stream;
lazy_if {
no warnings 'recursion'; # XXX this should be tail calling???
$l = force $l;
is_null($l) ? $l : do {
my ($a, $r) = $l->first_and_rest;
no warnings 'recursion';
my $r2 = &$filter($fn, $r);
&$fn($a) ? cons($a, $r2) : $r2
}
}
$is_stream;
};
Weakened($filter)
}
sub list_filter;
*list_filter = make_filter(0);
*FP::List::List::filter = flip \&list_filter;
# almost-COPY of filter
sub make_filter_with_tail {
my ($is_stream) = @_;
my $filter_with_tail;
$filter_with_tail = sub {
@_ == 3 or fp_croak_arity 3;
my ($fn, $l, $tail) = @_;
weaken $_[1] if $is_stream;
lazy_if {
$l = force $l;
is_null($l) ? $tail : do {
my $a = car $l;
my $r = &$filter_with_tail($fn, cdr($l), $tail);
&$fn($a) ? cons($a, $r) : $r
}
}
$is_stream;
};
Weakened($filter_with_tail)
}
sub list_filter_with_tail;
*list_filter_with_tail = make_filter_with_tail(0);
*FP::List::List::filter_with_tail = flip2of3 \&list_filter_with_tail;
sub list_map {
@_ == 2 or fp_croak_arity 2;
my ($fn, $l) = @_;
is_null($l) ? $l : cons(
scalar &$fn(car $l),
do {
no warnings 'recursion';
list_map($fn, cdr $l)
}
)
}
TEST {
list_to_array list_map sub { $_[0] * $_[0] }, list 1, 2, -3
}
[1, 4, 9];
# n-ary map
sub list_mapn {
my $fn = shift;
for (@_) {
return $_ if is_null $_
}
cons(&$fn(map { car $_} @_), list_mapn($fn, map { cdr $_} @_))
}
TEST {
list_to_array list_mapn(sub { [@_] }, array_to_list([1, 2, 3]),
string_to_list(""))
}
[];
TEST {
list_to_array list_mapn(sub { [@_] }, array_to_list([1, 2, 3]),
string_to_list("ab"))
}
[[1, 'a'], [2, 'b']];
sub FP::List::List::map {
@_ >= 2 or fp_croak_arity ">= 2";
my $l = shift;
my $fn = shift;
@_ ? list_mapn($fn, $l, @_) : list_map($fn, $l)
}
lib/FP/List.pm view on Meta::CPAN
my ($v, $l1) = $l->first_and_rest;
if (&$fn($v)) {
$l
} else {
$l = $l1;
redo LP
}
}
}
}
*FP::List::List::perhaps_find_tail = flip \&list_perhaps_find_tail;
TEST {
list(3, 1, 37, -8, -5, 0, 0)->perhaps_find_tail(\&is_even)->array
}
[-8, -5, 0, 0];
TEST { [list(3, 1, 37, -5)->perhaps_find_tail(\&is_even)] }
[];
sub list_perhaps_find {
@_ == 2 or fp_croak_arity 2;
my ($fn, $l) = @_;
if (my ($l) = list_perhaps_find_tail($fn, $l)) {
$l->car
} else {
()
}
}
*FP::List::List::perhaps_find = flip \&list_perhaps_find;
TEST { list(3, 1, 4, 1, 5, 9)->perhaps_find(\&is_even) }
4;
# And then still also add the SRFI-1 counterparts, without `maybe` in
# the names as they should have according to our guidelines, XX hmm.
sub list_find_tail;
*list_find_tail = perhaps_to_maybe(\&list_perhaps_find_tail);
*FP::List::List::find_tail = flip \&list_find_tail;
sub list_find;
*list_find = perhaps_to_maybe(\&list_perhaps_find);
*FP::List::List::find = flip \&list_find;
TEST { list(3, 1, 4, 1, 5, 9)->find(\&is_even) }
4;
TEST { list(3, 1, 37, -8, -5, 0, 0)->find_tail(\&is_even)->array }
[-8, -5, 0, 0];
TEST { [list(3, 1, 37, -5)->find_tail(\&is_even)] }
[undef];
# Grouping
sub make_group {
my ($is_stream) = @_;
sub {
@_ >= 2 and @_ <= 3 or fp_croak_arity "2-3";
my ($equal, $s, $maybe_tail) = @_;
weaken $_[1] if $is_stream;
lazy_if {
FORCE $s;
if (is_null $s) {
$maybe_tail // null
} else {
my ($a, $r) = $s->first_and_rest;
my $rec;
$rec = sub {
my ($prev, $s) = @_;
lazy_if {
my $s = $s;
my $group = cons $prev, null;
LP: {
FORCE $s;
if (is_null $s) {
cons $group, ($maybe_tail // null)
} else {
my ($a, $r) = $s->first_and_rest;
if (&$equal($prev, $a)) {
$s = $r;
$group = cons $a, $group;
redo LP;
} else {
cons $group, &$rec($a, $r)
}
}
}
}
$is_stream;
};
# TCO?
##XXX disable for v5.20.2 (Debian), wtf Weakened
($rec)->($a, $r)
}
}
$is_stream
}
}
sub list_group;
*list_group = make_group(0);
sub FP::List::List::group {
__
'group($self, $equal, $maybe_tail): build groups of subsequent items that are $equal.';
@_ >= 2 and @_ <= 3 or fp_croak_arity "2-3";
my ($self, $equal, $maybe_tail) = @_;
list_group($equal, $self, $maybe_tail)
}
TEST {
list(3, 4, 4, 5, 6, 8, 5, 5)->group(\&FP::Ops::number_eq)
}
list(list(3), list(4, 4), list(5), list(6), list(8), list(5, 5));
# Split on items for which the predicate returns true:
sub make_split {
my ($is_stream) = @_;
sub {
__
'split($self, $pred, $retain_item, $maybe_tail): split on items for which $pred returns true. If $retain_item is true, the item that matched will be included in the previous group.';
@_ >= 2 and @_ <= 4 or fp_croak_arity "2-4";
require FP::PureArray;
my ($s, $pred, $retain_item, $maybe_tail) = @_;
weaken $_[1] if $is_stream;
lazy_if {
FORCE $s;
if (is_null $s) {
$maybe_tail // null
} else {
my $rec;
$rec = sub {
my ($s) = @_;
lazy_if {
my $s = $s;
my @group;
LP: {
FORCE $s;
if (is_null $s) {
if (@group) {
cons(
FP::PureArray::array_to_purearray(
\@group),
($maybe_tail // null)
)
} else {
($maybe_tail // null)
}
} else {
my ($a, $r) = $s->first_and_rest;
if ($pred->($a)) {
if ($retain_item) {
push @group, $a;
}
cons(
FP::PureArray::array_to_purearray(
\@group),
$rec->($r)
)
} else {
$s = $r;
push @group, $a;
redo LP;
}
}
}
}
$is_stream;
};
$rec->($s)
}
}
$is_stream
}
}
sub list_split;
*list_split = make_split(0);
*FP::List::List::split = \&list_split;
# For split tests see FP::List::t.
# Turn a mix of (nested) arrays and lists into a flat list.
( run in 0.705 second using v1.01-cache-2.11-cpan-99c4e6809bf )