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; }; } #### ok 1 - combinations ok 2 - johngg ok 3 - permutations (warning: too few iterations for a reliable count) Rate permutations johngg combinations permutations 4.76e-02/s -- -100% -100% johngg 70.0/s 146784% -- -69% combinations 229/s 480720% 227% -- 1..3