Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Re: Sum of N elements in an M element array

by johngg (Canon)
on Feb 17, 2020 at 13:54 UTC ( [id://11113047]=note: print w/replies, xml ) Need Help??


in reply to Sum of N elements in an M element array

I put together a small benchmark comparing the Algorithm::Permute approach demonstrated by Marshall, a solution using combinations() from Algorithm::Combinatorics as mentioned by AnomalousMonk and my bit-shuffling permutary routine (which I now understand has been misnamed, I always confused permutations and combinations at school). I have not included tybalt's solution because it would take too much mangling to produce output in the form that would pass the tests. I have also omitted trying to produce a solution using glob because as far as I can see, whichever way you slice it, it breaks down as soon as array indexes go into double figures or array values do if acting on them directly.

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

The results:-

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

I hope this is of interest.

Cheers,

JohnGG

Replies are listed 'Best First'.
Re^2: Sum of N elements in an M element array
by AnomalousMonk (Archbishop) on Feb 17, 2020 at 19:53 UTC
    ... I always confused permutations and combinations at school ...

    Not to mention the many sub-species of each :)


    Give a man a fish:  <%-{-{-{-<

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11113047]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others avoiding work at the Monastery: (5)
As of 2024-03-28 19:42 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found