sub genFixedSubsets
{
    my( $size, @set )= @_;
    my @idx= reverse 0..$size-1;
    return sub {
        return   if  $size < @idx;
        my @ret= @set[@idx];
        my $i= 0;
        $i++  until  ++$idx[$i] < @set-$i  ||  $size < $i;
        $idx[$i]= 1+$idx[1+$i]   while  0 <= --$i;
        return @ret;
    };
}

my $gen= genFixedSubsets( $ARGV[0] || 3, 1..($ARGV[1]||5) );
my @subset;
while(  @subset= $gen->()  ) {
    print "@subset\n";
}
[download]

For example:

$ subsets 3 5
3 2 1
4 2 1
5 2 1
4 3 1
5 3 1
5 4 1
4 3 2
5 3 2
5 4 2
5 4 3
[download]

#!/usr/bin/perl -w
use strict;
use Data::Dumper;

sub unshift_many {
    my $scalar = shift;
    unshift @$_, $scalar for @_;
    @_;
}

sub combinations {
    my ( $array, $len, $start ) = @_;
    $start ||= 0;

    return unless $len > 0;

    return $len == 1
        ? map [ $_ ], @{ $array }[ $start .. $#$array ]
        : map unshift_many( $array->[$_], combinations( $array, $len-1
+, $_+1 ) ),
            $start .. $#$array;
}

$Data::Dumper::Indent=0;
print Dumper( [ combinations [ qw( 1 2 3 4 5 ) ], 3 ] ), "\n";
[download]

Makeshifts last the longest.

use Data::Dumper;

my @a = (1..4);
my $len = 4;

print Dumper(combinations($len, @a));

sub combinations
{
        my ($size, @elements) = @_;
        return [] if $size < 1;

        my @result = ();

        foreach my $elem (@elements)
        {
               push @result,
                    map { [$elem, @$_] }
                    combinations($size-1,
                          grep { $_ != $elem }
                          @elements)
        }

        return @result;
}
[download]

Update: for greater generality, replace foreach loop with

my @seen = ();
while (@elements)
{
     my $elem = shift @elements;
     push @result,
         map { [$elem, @$_] }
         combinations($size-1, @seen, @elements);
     push @seen, $elem;
}
[download]

This looks great! except that it gives permutations rather than combinations. For example, it produces both (1, 2, 3) and (1, 3, 2) whereas, for my purposes, these are the same thing i.e., order is not important. It gives me a starting point though - thanks!

use Data::Dumper;
my $set_group_size = 2;
my @list = 1..5;
print Dumper ([ sumList($set_group_size,@list) ]);

sub sumList {
    my @sumlist;
    my $size = shift;    
    while ( @_ ) {
        my @current = splice @_, 0, $size-1;
        foreach my $item (@_) {
            push ( @sumlist, [@current,$item] );
        }
        unshift (@_, @current[1..$#current]);
    }
    return @sumlist;
}
[download]

#! /usr/bin/perl -w
use strict ;
use Data::Dumper ;
$|++ ;

my @my_array = (0, 1, 2, 3) ;
my $my_sub_array_length = 2 ;
my @subsets = () ;

for ( 3 .. 2 ** @my_array ) {
    my @digits = reverse split // => sprintf "%b", $_ ;
    if ( ( grep { $_ } @digits ) == $my_sub_array_length ) {
        my @sub_arr = grep { $digits[$_] } @my_array ;
        push @subsets, \@sub_arr ;
    }
}

print Dumper( \@subsets ) ;

exit ;

__END__
[download]

Those who know that they are profound strive for clarity. Those who
would like to seem profound to the crowd strive for obscurity.
            --Friedrich Nietzsche

Ah, a twist. The common question is about permutations.

Nevertheless, I'd still use recursion. Say you need $n elements. Is the first element included? If yes, combine it with all combinations of $n-1 elements from the list of all of the following elements. If no, get all combinations of $n elements of the same sublist. Of course, you need to include every possible solution, which means walking every possible path.

Code!

sub combinations {
    my $n = shift;
    return [@_] if $n == @_;
    return () if $n > @_ or $n < 0;
    my $first = shift;
    my @r = ((map [ $first, @$_ ], combinations($n-1, @_)),
             combinations($n, @_));
    return @r;
}

use Data::Dumper;
print Dumper [ combinations(2, (0, 1, 2, 3)) ];
[download]

It appears to be working well.

Update: I'm pretty sure inserting

    return [] if $n == 0;
[download]

Yes, it will. In fact you can cut down on the amount of useless processing further by replacing all those returns with return map [$_], @_ if $n == 1; and then you have the equivalent to the code I wrote, except passing around full lists rather than just an arrayref.

Makeshifts last the longest.

Update:Having heard back from the author of the original C-source of this algorithm, he asked me to change the email address to his new one.

Not as concise as most of the others, but it seems fairly efficient for both memory and speed.

It probably could be golfed some more, but it defeated my attempts so far.

If your application calls for sub-setting different sets, but with the same size of both subset and set, you can generate the subsets of indices to the sets, rather that the subsets themselves and reuse the indices.

#! perl -w
use strict;
=pod
     Bit-twiddling transpositional combination generator in Perl,
     © 2002,BrowserUK / perlmonks.com
     Based upon a C implementation by Doug Moore (unkadoug@yahoo.com).
     Source:http://www.caam.rice.edu/~dougm/twiddle/yargbitcomb.c
=cut
sub Lshift1
{
    use integer;
    my $i = shift;
    my $ii = $i>>1;
    return 1 << $ii << ($i - $ii);
}

sub yargFirstComb
# Returns the inverse gray code (yarg) of the first combination of k i
+tems (i.e. {0,1,..,k-1})
{
    use integer;
    my $kk = Lshift1($_[0])-1;
    return $kk ^ $kk/3;
};

sub leastItem
# Returns the least item in a combination (i. e. leastItem({2,4,5}) ==
+ {2}
{     use integer; return $_[0] & -$_[0]; };

sub yargLastComb
# Returns the yarg of the last combination of k items from n (i.e. {n-
+k,..,n-1})
{
    use integer;
    my ($nn, $kk) = ( Lshift1($_[0])-1, Lshift1($_[1])-1);
    return ($_[1]) ?   $nn ^ ($kk/3) : 0;
};

# Returns the yarg of the next combination after yarg input
sub yargNextComb {
    use integer;
    my $comb = shift;
    my $grey = ($comb << 1) ^ $comb;
    my $i = 2;
    my $candidateBits;

    do {
        my $y = ($comb & ~($i - 1)) + $i;
        my $j = leastItem( $y ) << 1;
        my $h = !!($y & $j);
        $candidateBits = (($j - $h) ^ $grey) & ( $j - $i );
        $i = $j;
    } while (!$candidateBits);

    return $comb + leastItem($candidateBits);
}

sub factorial { no integer; my ($f,$n) = (1,shift); $f *= $n-- while( 
+$n ); return $f; }

sub subsets {
    use integer;
    my @AoAoCombs;
    my ($k, $n, $combs) = (shift, shift, 0);
    {
        no integer;
        $combs = factorial($n)/(factorial($k)*factorial($n-$k));
        print "Generating $combs subsets of $k from a set of $n\n";
         $#AoAoCombs = $combs-1;                         #pre-extend t
+he array of array refs to its final size
    }
    die "Usage: subsets k, n\nGenerate subsets of k-elements from a se
+t of n-elements where k < n.\n"
         unless $n and $k and $k < $n;

    my $comb = yargFirstComb($k);
    my $lastcomb = yargLastComb( $n, $k);

    while(1)  {
        my $member = 0; #!!
        my $c = $comb ^ ($comb >> 1);

        # 'push' anon array ref & pre-extend anon. array space
        $AoAoCombs[--$combs] = [];
        $#{$AoAoCombs[$combs]} = $k-1;

        ($c & Lshift1($_)) and @{$AoAoCombs[$combs]}[$member++] = $_ f
+or 0 .. $n-1; # 'unshift'

        last if $comb == $lastcomb;
        $comb = yargNextComb($comb);
    }
    return \@AoAoCombs;
}

my $AoAoCombs = subsets 2, 4; # Generate combinations of indices

my @data1 = qw( just another perl hacker );
local $,=' ';
print "Applying combined indices to @data1\n\n";
print @data1[ @{$AoAoCombs->[$_]} ], $/ for (0 .. $#$AoAoCombs);

my @data2= (1,2,3,4);
print "\nApplying combined indices to @data2\n\n";
print @data2[ @{$AoAoCombs->[$_]} ], $/ for (0 .. $#$AoAoCombs); # App
+ly the indices to as many sets as you like
print $/;

no integer;
my @data3 = (1..31);
my @times = (times);
my $start = $times[0] + $times[1];

$AoAoCombs = subsets 26,  ~~@data3;

 @times = times;
my $end = $times[0]+$times[1];

print "Generating " . @{$AoAoCombs} . " combinations of 26 from 31 too
+k ", $end-$start, " seconds of cpu P-II\@233MHz\n",
    "including generating 169911 x 26 element anonymous arrays to stor
+e the results.\n";

#print "\nApplying combined indices to @data1\n\n";
#print @data1[@{$^AoAoCombs[$_]}], $/ for (0..$#{$AoAoCombs});        
+ # Apply the indices

__END__
# Output
C:\test>191902
Generating 6 subsets of 2 from a set of 4
Applying combined indices to just another perl hacker

just hacker
another hacker
perl hacker
just perl
another perl
just another

Applying combined indices to 1 2 3 4

1 4
2 4
3 4
1 3
2 3
1 2

Generating 169911 subsets of 26 from a set of 31
Generating 169911 combinations of 26 from 31 took  251.51  seconds of 
+cpu P-II@233MHz
 including generating 169911 x 26 element anonymous arrays to store th
+e results.

C:\test>
[download]

#!/usr/bin/perl -wT
use strict;

my @a    = 1..5;
my $l    = 3;
local $" = ',';

my @combos = grep!$;{"@$_"}++,map[sortsplit','],
             grep!/([^,]+).*,\1,/,glob"{@a},"x$l;

print "@$_\n" for @combos;

__END__
1,2,3
1,2,4
1,2,5
1,3,4
1,3,5
1,4,5
2,3,4
2,3,5
2,4,5
3,4,5
[download]

-Blake

use Data::Dumper;
my @my_array = (1..7);
my $my_sub_array_length = 4;
print Dumper(combinations($my_sub_array_length, @my_array));
sub combinations {
    my($len,@a)=@_;
    return
        map{ my $c=$_<<1; [grep{($c>>=1)&1}@a]}
        &{sub{
            my @ret = ();
            my $x;
            for($_=(1<<shift)-1;
                ($x=$_)<1<<$_[0];
                $x&=~$x>>1,$x&=-$x,$_+=$x--,($x&=$_)?($_-=$x,$_+=$x/($
+x&-$x)):0
            ){ push @ret,$_ }
            @ret;
        }}($len,0+@a);
}
[download]

#!perl -w
use strict;
# kenhirsch at myself.com  2002-08-23

my $r = shift or die "usage: combinations r a b c d e ...\n";
my @out = combinations($r, \@ARGV);

for (@out) {
  print join(" ", @{$_}), "\n";
}

# From Algorith L in Knuth Vol. 4  Sec 7.2.1.3 (not yet published)
sub combinations {
  my ($t, $arrayref) = @_;
  my @c = 0 .. $t-1;
  my @range = reverse @c;
  my $j;
  my @result;
  $c[$t] = scalar(@{$arrayref});
  $c[$t + 1] = 0;
  do {
    push @result, [@{$arrayref}[@c[@range]]];
    for ($j=0; $c[$j] + 1 == $c[$j+1]; $j++) {
      $c[$j] = $j;
    }
    $c[$j]++;
  } while ($j < $t);
  return @result;
}
[download]

http://probstat.sourceforge.net Is my combination/permutation/cartesian back-of-the-envelope algos written in C with python bindings. I'm currently in the process of upgrading the algos and adding more python functionality (slices).

I've been meaning to add PerlXS bindings, but haven't had the time to learn anything complicated in XS. If someone can write an XS interface for one of the objects, I can fake it for the rest.

The license is GPL, oddly enough I'm working on it at this moment (pulling from http://sources.redhat.com/gsl/ the Gnu Scientific library for better C algos where I can). If you want to see what this perl code I wrote Name Me! MixMatch? looks like translated from C to perl, check it out.

If someone can write an XS interface for one of the objects, I can fake it for the rest.

Don't. Take a look at Inline::C or Inline::C++. You'll find that it's a lot easier than you think.

Greetings, Christian