In each case I preserve the order demonstrated in the OP, effectively working from left to right with no repeated elements. Using array indices gets around any problems with duplicates or sorting, as noted by AnomalousMonk and the results show that calculating all permutations then filtering out re-ordered duplicates is an enormous hit on performance. The code:-
use 5.026;
use warnings;
use Benchmark qw{ cmpthese };
use Test::More qw{ no_plan };
use List::Util qw{ sum };
use Algorithm::Permute;
use Algorithm::Combinatorics qw{ combinations };
my %methods = (
johngg => sub {
my $raValues = shift;
allSums( $raValues );
},
permutations => sub {
my $raValues = shift;
permuteSums( $raValues );
},
combinations => sub {
my $raValues = shift;
combineSums( $raValues );
},
);
my $raTest = [ 1, 2, 3, 4, 5 ];
my $raExpected = [
[],
[],
[
{
'1+2' => 3
},
{
'1+3' => 4
},
{
'1+4' => 5
},
{
'1+5' => 6
},
{
'2+3' => 5
},
{
'2+4' => 6
},
{
'2+5' => 7
},
{
'3+4' => 7
},
{
'3+5' => 8
},
{
'4+5' => 9
}
],
[
{
'1+2+3' => 6
},
{
'1+2+4' => 7
},
{
'1+2+5' => 8
},
{
'1+3+4' => 8
},
{
'1+3+5' => 9
},
{
'1+4+5' => 10
},
{
'2+3+4' => 9
},
{
'2+3+5' => 10
},
{
'2+4+5' => 11
},
{
'3+4+5' => 12
}
],
[
{
'1+2+3+4' => 10
},
{
'1+2+3+5' => 11
},
{
'1+2+4+5' => 12
},
{
'1+3+4+5' => 13
},
{
'2+3+4+5' => 14
}
]
];
foreach my $method ( sort keys %methods )
{
is_deeply(
$methods{ $method }->( $raTest ),
$raExpected,
$method
);
}
$raTest = [ map { int rand 500 } 1 .. 10 ];
cmpthese(
-30,
{
map
{
my $codeStr
= q|sub { my $raAllSums = $methods{ |
. $_
. q| }->( $raTest ); }|;
$_ => eval $codeStr;
}
keys %methods
}
);
sub combineSums
{
my $raNumbers = shift;
return 0 unless ref( $raNumbers ) eq q{ARRAY};
my $raSums = [ [], [], ];
my $nElems = scalar @{ $raNumbers };
if ( $nElems < 3 )
{
return $raSums;
}
foreach my $sumsOf ( 2 .. $nElems - 1 )
{
my $raIdx = [ 0 .. $nElems - 1 ];
my $comb = combinations( $raIdx, $sumsOf );
while ( my $raComb = $comb->next() )
{
push @{ $raSums->[ $sumsOf ] },
{
join( q{+}, $raNumbers->@[ @{ $raComb } ] ),
sum $raNumbers->@[ @{ $raComb } ]
};
}
}
return $raSums;
}
sub permuteSums
{
my $raNumbers = shift;
return 0 unless ref( $raNumbers ) eq q{ARRAY};
my $raSums = [ [], [], ];
my $nElems = scalar @{ $raNumbers };
if ( $nElems < 3 )
{
return $raSums;
}
foreach my $sumsOf ( 2 .. $nElems - 1 )
{
my $raIdx = [ 0 .. $nElems - 1 ];
my $perm = Algorithm::Permute->new(
$raIdx, $sumsOf );
my @allPerms;
while ( my @res = $perm->next() )
{
push @allPerms, [ sort { $a <=> $b } @res ];
}
my @uniqPerms = do {
my %seen;
map { [ unpack q{N*}, $_ ] }
sort
grep { ! $seen{ $_ } ++ }
map { pack q{N*}, @{ $_ } }
@allPerms
};
foreach my $raPerm ( @uniqPerms )
{
push @{ $raSums->[ $sumsOf ] },
{
join( q{+}, $raNumbers->@[ @{ $raPerm } ] ),
sum $raNumbers->@[ @{ $raPerm } ]
};
}
}
return $raSums;
}
sub allSums
{
my $raNumbers = shift;
return 0 unless ref( $raNumbers ) eq q{ARRAY};
my $raSums = [ [], [], ];
my $nElems = scalar @{ $raNumbers };
if ( $nElems < 3 )
{
return $raSums;
}
foreach my $sumsOf ( 2 .. $nElems - 1 )
{
my $nZeros = $nElems - $sumsOf;
my $rcNext = permutary( $nZeros, $sumsOf );
while ( my $str = $rcNext->() )
{
my @posns;
push @posns, pos $str while $str =~ m{(?=1)}g;
unshift @{ $raSums->[ $sumsOf ] },
{
join( q{+}, $raNumbers->@[ @posns ] ),
sum $raNumbers->@[ @posns ]
};
}
}
return $raSums;
}
sub permutary
{
no warnings qw{ portable };
my ( $numZeros, $numOnes ) = @_;
my $format = q{%0} . ( $numZeros + $numOnes ) . q{b};
my $start = oct( q{0b} . q{1} x $numOnes );
my $limit = oct( q{0b} . q{1} x $numOnes . q{0} x $numZeros );
return sub
{
return undef if $start > $limit;
my $binStr = sprintf $format, $start;
die qq{Error: $binStr not $numOnes ones\n}
unless $numOnes == $binStr =~ tr{1}{};
my $jump = 0;
if ( $binStr =~ m{(1+)$} )
{
$jump = 2 ** ( length($1) - 1 );
}
elsif ( $binStr =~ m{(1+)(0+)$} )
{
$jump = 2 ** ( length($1) - 1 ) + 1;
$jump += 2 ** $_ for 1 .. length( $2 ) - 1;
}
else
{
die qq{Error: $binStr seems malformed\n};
}
$start += $jump;
return $binStr;
};
}
I hope this is of interest.
