use strict;
use warnings;

use Algorithm::Loops qw( NestedLoops );
use Benchmark        qw( cmpthese );


# Note: I improved the speed and the interface of ruzam's solution.

sub _ruzam {
    my ($source, $hash) = @_;

    return if $hash->{$source};

    my @parts = split(/:/, $source);
    return if @parts < 1;
    
    ++$hash->{$source};
    
    for my $i (0..$#parts) {
        my @parts_copy = @parts;
        splice(@parts_copy, $i, 1);
        _ruzam(join(':', @parts_copy), $hash);
    }
}

sub ruzam {
    my ($source) = @_;
    my %hash;
    _ruzam($source, \%hash);
    return keys %hash;
}


sub ikegami1 {
    my ($source) = @_;
    my @parts = split(/:/, $source);

    return NestedLoops(
        [
            [ 0..$#parts ],
            ( sub { [ $_+1..$#parts ] } ) x $#parts,
        ],
        { OnlyWhen => 1 },
        sub { join(':', map $parts[$_], @_) },
    );
}


sub ikegami2 {
    my ($source) = @_;
    my @parts = split(/:/, $source);

    my @rv;

    for my $comb (1..2**@parts-1) {
        push @rv, join ':',
                  map $parts[$_],
                  grep $comb & (1<<$_),
                  0..$#parts;
    }

    return @rv;
}


sub ikegami3 {
    local $_ = ":$_[0]:";

    my $parts = tr/:/:/ - 1;

    my $re = '(?{ "" })'
           . '(:[^:]*)(?=:)(?{ $^R . $^N })'
           . '(?:.*(:[^:]*)(?=:)(?{ $^R . $^N })' x ($parts-1)
           . ')?' x ($parts-1)
           . '(?{ push @rv, substr($^R, 1) })'
           . '(?!)';
    
    { use re 'eval'; $re = qr/$re/; }

    local our @rv;
    /$re/;
    return @rv;
}

sub rhesa {
    my ($source) = @_;
    my @parts = split /:/, $source;

    my @rv;
    
    for my $i( 1 .. 2**@parts - 1 ) {
        my @ar;
        my $t = 0;
        while( $i > 0 ) {
            push @ar, $parts[$t] if $i & 1;
            $i >>= 1; $t++;
        }
        push @rv, join ':', @ar;
    }

    return @rv;
}

{
   local our $source = 'horse:cow:dog:cat';
   
   my $expected = 'cat|cow|cow:cat|cow:dog|cow:dog:cat|dog|dog:cat|hor
+se|horse:cat|horse:cow|horse:cow:cat|horse:cow:dog|horse:cow:dog:cat|
+horse:dog|horse:dog:cat';
   
   foreach (qw( ruzam ikegami1 ikegami2 ikegami3 rhesa )) {
      printf("%-9s ", "$_:");
      
      my $rv = join '|',
               sort
               do { no strict 'refs'; \&{$_} }->($source);

      if ($rv eq $expected) {
         print("ok");
      } else {
         print("bad ($rv)");
      }
   
      print("\n");
   }

   print("\n");

   cmpthese(-3, {
      # ruzam    => q{ use strict; use warnings; my @rv = ruzam    our
+ $source; 1 },
      # ikegami1 => q{ use strict; use warnings; my @rv = ikegami1 our
+ $source; 1 },
      # ikegami2 => q{ use strict; use warnings; my @rv = ikegami2 our
+ $source; 1 },
      # ikegami3 => q{ use strict; use warnings; my @rv = ikegami3 our
+ $source; 1 },
      # rhesa    => q{ use strict; use warnings; my @rv = rhesa    our
+ $source; 1 },

      ruzam    => q{ my @rv = ruzam    $source; 1 },
      ikegami1 => q{ my @rv = ikegami1 $source; 1 },
      ikegami2 => q{ my @rv = ikegami2 $source; 1 },
      ikegami3 => q{ my @rv = ikegami3 $source; 1 },
      rhesa    => q{ my @rv = rhesa    $source; 1 },
   });
}
[download]