Algorithm::Combinatorics - Efficient generation of combinatorial sequences

 use Algorithm::Combinatorics qw(permutations);

 my @data = qw(a b c);

 # scalar context gives an iterator
 my $iter = permutations(\@data);
 while (my $p = $iter->next) {
     # ...
 }

 # list context slurps
 my @all_permutations = permutations(\@data);

    permutations(\@data)
    circular_permutations(\@data)
    derangements(\@data)
    complete_permutations(\@data)
    variations(\@data, $k)
    variations_with_repetition(\@data, $k)
    tuples(\@data, $k)
    tuples_with_repetition(\@data, $k)
    combinations(\@data, $k)
    combinations_with_repetition(\@data, $k)
    partitions(\@data[, $k])
    subsets(\@data[, $k])

    (1, 2, 3)
    (1, 3, 2)
    (2, 1, 3)
    (2, 3, 1)
    (3, 1, 2)
    (3, 2, 1)

    n! = 1,                  if n = 0
    n! = n*(n-1)*...*1,      if n > 0

    (1, 2, 3, 4)
    (1, 2, 4, 3)
    (1, 3, 2, 4)
    (1, 3, 4, 2)
    (1, 4, 2, 3)
    (1, 4, 3, 2)

        n! = 1,                      if 0 <= n <= 1
    (n-1)! = (n-1)*(n-2)*...*1,      if n > 1

    (2, 3, 1)
    (3, 1, 2)

    d(n) = 1,                       if n = 0
    d(n) = n*d(n-1) + (-1)**n,      if n > 0

    (1, 2)
    (1, 3)
    (2, 1)
    (2, 3)
    (3, 1)
    (3, 2)

    permutations(\@data);

    variations(\@data, scalar @data);

    v(n, k) = 1,                        if k = 0
    v(n, k) = n*(n-1)*...*(n-k+1),      if 0 < k <= n

    (1, 1)
    (1, 2)
    (1, 3)
    (2, 1)
    (2, 2)
    (2, 3)
    (3, 1)
    (3, 2)
    (3, 3)

    (1, 1, 1)
    (1, 1, 2)
    (1, 2, 1)
    (1, 2, 2)
    (2, 1, 1)
    (2, 1, 2)
    (2, 2, 1)
    (2, 2, 2)

    vr(n, k) = n**k

    (1, 2, 3)
    (1, 2, 4)
    (1, 3, 4)
    (2, 3, 4)

    n choose k = n!/(k!*(n-k)!)

    (1, 1)
    (1, 2)
    (1, 3)
    (2, 2)
    (2, 3)
    (3, 3)

    (1, 1, 1, 1)
    (1, 1, 1, 2)
    (1, 1, 1, 3)
    (1, 1, 2, 2)
    (1, 1, 2, 3)
    (1, 1, 3, 3)
    (1, 2, 2, 2)
    (1, 2, 2, 3)
    (1, 2, 3, 3)
    (1, 3, 3, 3)
    (2, 2, 2, 2)
    (2, 2, 2, 3)
    (2, 2, 3, 3)
    (2, 3, 3, 3)
    (3, 3, 3, 3)

    n+k-1 over k = (n+k-1)!/(k!*(n-1)!)

    ((1, 2, 3))
    ((1, 2), (3))
    ((1, 3), (2))
    ((1), (2, 3))
    ((1), (2), (3))

    B(0) = 1
    B(n+1) = (n over 0)B(0) + (n over 1)B(1) + ... + (n over n)B(n)

    S(0, 0) = 1
    S(n, 0) = 0 if n > 0
    S(n, 1) = S(n, n) = 1
    S(n, k) = S(n-1, k-1) + kS(n-1, k)

  2**n

    use Algorithm::Combinatorics qw(combinations);

    use Algorithm::Combinatorics qw(:all);

package Algorithm::Combinatorics;

use 5.006002;
use strict;

our $VERSION = '0.26';

use XSLoader;
XSLoader::load('Algorithm::Combinatorics', $VERSION);

use Carp;
use Scalar::Util qw(reftype);
use Exporter;
use base 'Exporter';
our @EXPORT_OK = qw(
    combinations
    combinations_with_repetition
    variations
    variations_with_repetition
    tuples
    tuples_with_repetition
    permutations
    circular_permutations
    derangements
    complete_permutations
    partitions
    subsets
);

our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);


sub combinations {
    my ($data, $k) = @_;
    __check_params($data, $k);

    return __contextualize(__null_iter()) if $k < 0;
    return __contextualize(__once_iter()) if $k == 0;
    if ($k > @$data) {
        carp("Parameter k is greater than the size of data");
        return __contextualize(__null_iter());
    }

    my @indices = 0..($k-1);
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_combination(\@indices, @$data-1) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}


sub combinations_with_repetition {
    my ($data, $k) = @_;
    __check_params($data, $k);

    return __contextualize(__null_iter()) if $k < 0;
    return __contextualize(__once_iter()) if $k == 0;

    my @indices = (0) x $k;
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_combination_with_repetition(\@indices, @$data-1) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}

sub subsets {
    my ($data, $k) = @_;
    __check_params($data, $k, 1);

    return combinations($data, $k) if defined $k;

    my $finished = 0;
    my @odometer = (1) x @$data;
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        return if $finished;
        my $subset = __next_subset($data, \@odometer);
        $finished = 1 if @$subset == 0;
        $subset;
    });

    return __contextualize($iter);
}

sub variations {
    my ($data, $k) = @_;
    __check_params($data, $k);

    return __contextualize(__null_iter()) if $k < 0;
    return __contextualize(__once_iter()) if $k == 0;
    if ($k > @$data) {
        carp("Parameter k is greater than the size of data");
        return __contextualize(__null_iter());
    }

    # permutations() is more efficient because it knows
    # all indices are always used
    return permutations($data) if @$data == $k;

    my @indices = 0..($k-1);
    my @used = ((1) x $k, (0) x (@$data-$k));
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_variation(\@indices, \@used, @$data-1) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}
*tuples = \&variations;


sub variations_with_repetition {
    my ($data, $k) = @_;
    __check_params($data, $k);

    return __contextualize(__null_iter()) if $k < 0;
    return __contextualize(__once_iter()) if $k == 0;

    my @indices = (0) x $k;
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_variation_with_repetition(\@indices, @$data-1) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}
*tuples_with_repetition = \&variations_with_repetition;


sub __variations_with_repetition_gray_code {
    my ($data, $k) = @_;
    __check_params($data, $k);

    return __contextualize(__null_iter()) if $k < 0;
    return __contextualize(__once_iter()) if $k == 0;

    my @indices        = (0) x $k;
    my @focus_pointers = 0..$k; # yeah, length $k+1
    my @directions     = (1) x $k;
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_variation_with_repetition_gray_code(
            \@indices,
            \@focus_pointers,
            \@directions,
            @$data-1,
        ) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}


sub permutations {
    my ($data) = @_;
    __check_params($data, 0);

    return __contextualize(__once_iter()) if @$data == 0;

    my @indices = 0..(@$data-1);
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_permutation(\@indices) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}


sub circular_permutations {
    my ($data) = @_;
    __check_params($data, 0);

    return __contextualize(__once_iter())         if @$data == 0;
    return __contextualize(__once_iter([@$data])) if @$data == 1 || @$data == 2;

    my @indices = 1..(@$data-1);
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_permutation(\@indices) == -1 ? undef : [ @{$data}[0, @indices] ];
    }, [ @{$data}[0, @indices] ]);

    return __contextualize($iter);
}

sub __permutations_heap {
    my ($data) = @_;
    __check_params($data, 0);

    return __contextualize(__once_iter()) if @$data == 0;

    my @a = 0..(@$data-1);
    my @c = (0) x (@$data+1); # yeah, there's an spurious $c[0] to make the notation coincide
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_permutation_heap(\@a, \@c) == -1 ? undef : [ @{$data}[@a] ];
    }, [ @{$data}[@a] ]);

    return __contextualize($iter);
}


sub derangements {
    my ($data) = @_;
    __check_params($data, 0);

    return __contextualize(__once_iter()) if @$data == 0;
    return __contextualize(__null_iter()) if @$data == 1;

    my @indices = 0..(@$data-1);
    @indices[$_, $_+1] = @indices[$_+1, $_] for map { 2*$_ } 0..((@$data-2)/2);
    @indices[-1, -2] = @indices[-2, -1] if @$data % 2;
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
        __next_derangement(\@indices) == -1 ? undef : [ @{$data}[@indices] ];
    }, [ @{$data}[@indices] ]);

    return __contextualize($iter);
}

*complete_permutations = \&derangements;


sub partitions {
    my ($data, $k) = @_;
    if (defined $k) {
        __partitions_of_size_p($data, $k);
    } else {
        __partitions_of_all_sizes($data);
    }
}

sub __partitions_of_all_sizes {
    my ($data) = @_;
    __check_params($data, 0);

    return __contextualize(__once_iter()) if @$data == 0;

    my @k = (0) x @$data;
    my @M = (0) x @$data;
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
       __next_partition(\@k, \@M) == -1 ? undef : __slice_partition(\@k, \@M, $data);
    }, __slice_partition(\@k, \@M, $data));

    return __contextualize($iter);
}

# We use @k and $p here and sacrifice the uniform usage of $k
# to follow the notation in [3].
sub __partitions_of_size_p {
    my ($data, $p) = @_;
    __check_params($data, $p);

    return __contextualize(__null_iter()) if $p < 0;
    return __contextualize(__once_iter()) if @$data == 0 && $p == 0;
    return __contextualize(__null_iter()) if $p == 0;

    if ($p > @$data) {
        carp("Parameter k is greater than the size of data");
        return __contextualize(__null_iter());
    }

    my $q = @$data - $p + 1;
    my @k = (0) x $q;
    my @M = (0) x $q;
    push @k, $_ - $q + 1 for $q..(@$data-1);
    push @M, $_ - $q + 1 for $q..(@$data-1);
    my $iter = Algorithm::Combinatorics::Iterator->new(sub {
       __next_partition_of_size_p(\@k, \@M, $p) == -1 ? undef : __slice_partition_of_size_p(\@k, $p, $data);
    }, __slice_partition_of_size_p(\@k, $p, $data));

    return __contextualize($iter);
}


sub __slice_partition {
    my ($k, $M, $data) = @_;
    my @partition = ();
    my $size = $M->[-1] + 1; # $M->[0] is always 0 in our code
    push @partition, [] for 1..$size;
    my $i = 0;
    foreach my $x (@$data) {
        push @{$partition[$k->[$i]]}, $x;
        ++$i;
    }
    return \@partition;
}

# We use @k and $p here and sacrifice the uniform usage of $k
# to follow the notation in [3].
sub __slice_partition_of_size_p {
    my ($k, $p, $data) = @_;
    my @partition = ();
    push @partition, [] for 1..$p;
    my $i = 0;
    foreach my $x (@$data) {
        push @{$partition[$k->[$i]]}, $x;
        ++$i;
    }
    return \@partition;
}


sub __check_params {
    my ($data, $k, $k_is_not_required) = @_;
    if (not defined $data) {
        croak("Missing parameter data");
    }
    unless ($k_is_not_required || defined $k) {
        croak("Missing parameter k");
    }

    my $type = reftype $data;
    if (!defined($type) || $type ne "ARRAY") {
        croak("Parameter data is not an arrayref");
    }

    carp("Parameter k is negative") if !$k_is_not_required && $k < 0;
}


# Given an iterator that responds to the next() method this
# subrutine returns the iterator in scalar context, loops
# over the iterator to build and return an array of results
# in list context, and does nothing but issue a warning in
# void context.
sub __contextualize {
    my $iter = shift;
    my $w = wantarray;
    if (defined $w) {
        if ($w) {
            my @result = ();
            while (my $c = $iter->next) {
                push @result, $c;
            }
            return @result;
        } else {
            return $iter;
        }
    } else {
        my $sub = (caller(1))[3];
        carp("Useless use of $sub in void context");
    }
}

sub __null_iter {
    return Algorithm::Combinatorics::Iterator->new(sub { return });
}


sub __once_iter {
    my $tuple = shift;
    $tuple ? Algorithm::Combinatorics::Iterator->new(sub { return }, $tuple) :
             Algorithm::Combinatorics::Iterator->new(sub { return }, []);
}



# This is a bit dirty by now, the objective is to be able to
# pass an initial sequence to the iterator and avoid a test
# in each iteration saying whether the sequence was already
# returned or not, since that might potentially be done a lot
# of times.
#
# The solution is to return an iterator that has a first sequence
# associated. The first time you call it that sequence is returned
# and the iterator rebless itself to become just a wrapped coderef.
#
# Note that the public contract is that responds to next(), no
# iterator class name is documented.
package Algorithm::Combinatorics::Iterator;

sub new {
    my ($class, $coderef, $first_seq) = @_;
    if (defined $first_seq) {
        return bless [$coderef, $first_seq], $class;
    } else {
        return bless $coderef, 'Algorithm::Combinatorics::JustCoderef';
    }
}

sub next {
    my ($self) = @_;
    $_[0] = $self->[0];
    bless $_[0], 'Algorithm::Combinatorics::JustCoderef';
    return $self->[1];
}

package Algorithm::Combinatorics::JustCoderef;

sub next {
    my ($self) = @_;
    return $self->();
}


1;

__END__