Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options
 
PerlMonks  

Re^3: Sum of N elements in an M element array

by Marshall (Canon)
on Feb 13, 2020 at 07:36 UTC ( [id://11112915]=note: print w/replies, xml ) Need Help??


in reply to Re^2: Sum of N elements in an M element array
in thread Sum of N elements in an M element array

Ok, I wanted to show the glob combination gizmo and the spec wasn't perfect.
For permutations 3 of a set of 5, consider the following.
No element is repeated, meaning no element of the input array appears more than once per "sum"
I just sorted the output in my program editor rather than adding that feature to the Perl code.
#!/usr/bin/perl use strict; use warnings; use Algorithm::Permute; my $p = Algorithm::Permute->new(['a','b','c','d','e'], 3); while (my @res = $p->next) { print join("+", @res), "\n"; } __END__ # I just used my editor to sort the output # adapt the above code as you wish a+b+c a+b+d a+b+e a+c+b a+c+d a+c+e a+d+b a+d+c a+d+e a+e+b a+e+c a+e+d b+a+c b+a+d b+a+e b+c+a b+c+d b+c+e b+d+a b+d+c b+d+e b+e+a b+e+c b+e+d c+a+b c+a+d c+a+e c+b+a c+b+d c+b+e c+d+a c+d+b c+d+e c+e+a c+e+b c+e+d d+a+b d+a+c d+a+e d+b+a d+b+c d+b+e d+c+a d+c+b d+c+e d+e+a d+e+b d+e+c e+a+b e+a+c e+a+d e+b+a e+b+c e+b+d e+c+a e+c+b e+c+d e+d+a e+d+b e+d+c

Replies are listed 'Best First'.
Re^4: Sum of N elements in an M element array
by johngg (Canon) on Feb 13, 2020 at 10:38 UTC

    Whilst it is true that no element is repeated, for the purposes of the OP, this solution will produce multiple results for the same three elements being summed in a different order. Some form of filtering, perhaps involving a numerical sort of element numbers, a pack to a string and a grep with a %seen hash, would be required to remove duplicates.

    Update: Here's some code to show what I mean. All the faff with pack q{N*}, @{ $_ } is because we may be dealing with larger arrays where subscripts go into multiple digits. This code:-

    use 5.026; use warnings; use Algorithm::Permute; my @arr = ( 1, 2, 3, 4, 5 ); my $perm = Algorithm::Permute->new( [ 0 .. $#arr ], 3 ); my @allPerms; while ( my @res = $perm->next() ) { push @allPerms, [ sort { $a <=> $b } @res ]; } my @uniqPerms = do { my %seen; map { [ unpack q{N*}, $_ ] } grep { ! $seen{ $_ } ++ } sort map { pack q{N*}, @{ $_ } } @allPerms }; say join q{+}, @{ $_ } for @uniqPerms;

    Produces:-

    0+1+2 0+1+3 0+1+4 0+2+3 0+2+4 0+3+4 1+2+3 1+2+4 1+3+4 2+3+4

    Cheers,

    JohnGG

      Seems perhaps at bit overly complex to me. Here is modified version of my code:
      #!/usr/bin/perl use strict; use warnings; use Algorithm::Permute; my $p = Algorithm::Permute->new(['a','b','c','d','e'], 3); my @results; while (my @res = $p->next) { push @results, [@res = sort @res]; # use a different sort for numbe +rs } my %seen; @results = map {!$seen{"@$_"}++? $_:() }@results; # remove duplicates! print join ("+",@$_)."\n" for @results; __END__ Prints: Again I sorted results in program editor because actual program probably doesn't need that feature. a+b+c a+b+d a+b+e a+c+d a+c+e a+d+e b+c+d b+c+e b+d+e c+d+e The unsorted output for reference:: a+b+c b+c+d a+c+d a+b+d b+c+e a+c+e b+d+e c+d+e a+d+e a+b+e
      Now of course the code could be modified so that a duplicate is not inserted into the @results array to begin with. However, I would recommend this 2 step process because it is easier to debug.

      Update: Improved Code, re suggestions from AnomalousMonk.

      #!/usr/bin/perl use strict; use warnings; use Algorithm::Permute; my $p = Algorithm::Permute->new(['a','b','c','d','e'], 3); my @results; while (my @res = $p->next) { push @results, [sort @res]; # use a different sort for numbers } my %seen; @results = grep{!$seen{"@$_"}++ }@results; # remove duplicates! print join ("+",@$_)."\n" for @results;

        The code can be further (slightly) simplified:

        • [@res = sort @res] to  [ sort @res ]
        • map {!$seen{"@$_"}++? $_:() }@results to  grep { !$seen{"@$_"}++ } @results;

        Be that as it may, johngg's approach of permuting indices is IMHO better because it is more general: it can be applied to an array of any mix of any type of elements with no worries about sorting:

        c:\@Work\Perl\monks>perl use strict; use warnings; use Test::More 'no_plan'; use Test::NoWarnings; use Algorithm::Permute; use List::MoreUtils qw(uniq); use Data::Dump qw(dd); my $ar_expected = [ qw(0+1+2 0+1+3 0+1+4 0+2+3 0+2+4 0+3+4 1+2+3 1+2+4 1+3+4 2+3+4) ]; my @arr = (1, 'two', -33, [ qw(f o u r) ], { V => 5 }); my $perm = Algorithm::Permute->new([ 0 .. $#arr ], 3); my @allIndicePermsSorted; while (my @res = $perm->next()) { push @allIndicePermsSorted, [ sort { $a <=> $b } @res ]; } my @uniqIndicePermsSorted = map [ unpack 'N*', $_ ], uniq sort map pack('N*', @$_), @allIndicePermsSorted ; my $ar_got = [ map join('+', @$_), @uniqIndicePermsSorted ]; is_deeply $ar_got, $ar_expected, 'unique sorted indices'; done_testing; dd [ @arr[ @$_ ] ] for @uniqIndicePermsSorted; exit; __END__ ok 1 - unique sorted indices 1..1 [1, "two", -33] [1, "two", ["f", "o", "u", "r"]] [1, "two", { V => 5 }] [1, -33, ["f", "o", "u", "r"]] [1, -33, { V => 5 }] [1, ["f", "o", "u", "r"], { V => 5 }] ["two", -33, ["f", "o", "u", "r"]] ["two", -33, { V => 5 }] ["two", ["f", "o", "u", "r"], { V => 5 }] [-33, ["f", "o", "u", "r"], { V => 5 }] ok 2 - no warnings 1..2
        (Actually, I think there are permutation algorithms that give unique sets in their original order to begin with! (Update: See e.g. Algorithm::Combinatorics::combinations(); I'm sure there are others!))

        Update: It might be advantageous to get rid of duplicates before sorting: gives sort less to do. For that, the somewhat syntactically awkward

        my @uniqIndicePermsSorted = map [ unpack 'N*', $_ ], sort +( uniq map pack('N*', @$_), @allIndicePermsSorted ) ;


        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://11112915]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others rifling through the Monastery: (3)
As of 2024-04-25 07:24 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found