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 },
});
}