Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:

Hello monks!
I have a numerical array of more than 50 numbers. My question is, is there a way of selecting for of them, check if their sum is equal to, say 15, and if 'yes' store them and remove them from the array?
The ultimate purpose is to find all sort of combinations, until there are no numbers left in the array.

Replies are listed 'Best First'.
Re: Randomly select values from array
by BrowserUk (Patriarch) on May 16, 2010 at 09:34 UTC
    selecting for of them ... no numbers left in the array

    Assuming that "for of them" means "four of them", then you have an immediate problem in that if your array contains 50 (or 51, or 53, or 54 or 55 etc. ) values, then you will eventually reach a point where there are less than four left to pick. What then?

    The ultimate purpose is to find all sort of combinations,

    Do you mean "all possible combinations"? If so, Do you mean "all possible sets of 4 that sum to 15" or "all possible sets of sets of 4 that sum to 15"?

    What if the array of numbers doesn't contain any set of four that sums to 15?

    Some code for you to play with. It generates an array of 50 small numbers (0..9) and then attempts to empty the array by picking and removing sets of 4. It will never terminate (use ^C), but might illustrate some ways of approaching whichever clarification of your problem is the correct one:) 

    #! perl -slw
use strict;
use List::Util qw[ shuffle sum ];

my @nums = map int rand 10, 1 .. 50;
my $n = 0;
{
    my @pick = (shuffle 0 .. $#nums )[ 0 .. 3 ];
    if( 15 == sum @nums[ @pick ] ) {
        print "\n@nums[ @pick ]";
        splice @nums, $_, 1 for sort{ $b <=> $a } @pick;
        $n = 0;
    }
    printf "\rtrying to find another from [@nums]: %d", ++$n;
    redo if @nums > 4;
}

__END__
c:\test>840204.pl
trying to find another from [5 3 5 0 1 8 3 6 1 5 7 5 3 1 6 4 5 9 5 0 1
+ 6 1 3 5 0 9 1 7 8 0 7 4 9 7 5 6 0 2 3 7 9 6 1 7 7 2 0 4 9]: 3
3 8 4 0
trying to find another from [5 3 5 0 1 8 3 6 1 5 7 5 1 6 5 9 5 0 1 6 1
+ 3 5 0 9 1 7 0 7 4 9 7 5 6 0 2 3 7 9 6 1 7 7 2 4 9]: 16
5 6 3 1
trying to find another from [5 3 0 1 8 3 6 1 5 7 5 1 5 9 5 0 1 6 1 3 5
+ 0 9 7 0 7 4 9 7 5 6 0 2 7 9 6 1 7 7 2 4 9]: 24
7 0 7 1
trying to find another from [5 3 0 8 3 6 1 5 5 1 5 9 5 0 1 6 1 3 5 0 9
+ 7 7 4 9 7 5 6 0 2 7 9 6 1 7 2 4 9]: 45
0 5 4 6
trying to find another from [3 0 8 3 6 1 5 5 1 5 9 5 0 1 6 1 3 5 0 9 7
+ 7 4 9 7 5 6 2 7 9 1 7 2 9]: 9
0 3 7 5
trying to find another from [3 0 8 3 6 1 5 1 5 9 5 1 6 1 5 0 9 7 7 4 9
+ 7 5 6 2 7 9 1 2 9]: 1
7 2 1 5
trying to find another from [3 0 8 3 6 1 5 1 9 5 1 6 5 0 9 7 7 4 9 7 5
+ 6 2 9 1 9]: 41
1 3 6 5
trying to find another from [3 0 8 6 1 9 5 1 5 0 9 7 7 4 9 7 5 6 2 9 1
+ 9]: 5
7 0 7 1
trying to find another from [3 8 6 1 9 5 5 0 9 4 9 7 5 6 2 9 1 9]: 3
8 0 6 1
trying to find another from [3 6 9 5 5 9 4 9 7 5 2 9 1 9]: 86
5 2 1 7
trying to find another from [3 6 9 5 9 4 9 5 9 9]: 85635
^C

c:\test>840204.pl
trying to find another from [3 9 9 7 4 8 5 7 0 1 4 7 8 0 8 7 5 2 3 4 1
+ 6 6 3 2 5 7 5 8 5 4 4 3 5 4 6 6 6 5 3 5 3 4 0 3 4 5 1 7 4]: 10
4 0 3 8
trying to find another from [3 9 9 7 4 8 5 7 0 1 4 7 8 0 8 7 5 2 3 4 1
+ 6 6 3 2 5 7 5 5 4 3 5 4 6 6 6 5 5 3 4 3 4 5 1 7 4]: 1
4 4 1 6
trying to find another from [3 9 9 7 4 8 5 7 0 1 4 7 8 0 8 7 5 2 3 1 6
+ 6 3 2 5 7 5 5 4 3 5 4 6 6 5 5 3 4 3 5 7 4]: 7
5 5 5 0
trying to find another from [3 9 9 7 4 8 7 1 4 7 8 0 8 7 2 3 1 6 6 3 2
+ 5 7 5 5 4 3 5 4 6 6 5 3 4 3 5 7 4]: 2
3 5 3 4
trying to find another from [9 9 7 4 8 7 1 7 8 0 8 7 2 1 6 6 3 2 5 7 5
+ 5 4 3 4 6 6 5 3 4 3 5 7 4]: 10
1 2 4 8
trying to find another from [9 9 7 4 8 7 1 7 8 0 7 6 6 3 2 5 7 5 5 4 3
+ 6 6 5 3 4 3 5 7 4]: 6
3 5 4 3
trying to find another from [9 9 7 4 8 7 1 7 8 0 7 6 6 2 7 5 5 4 3 6 6
+ 5 3 5 7 4]: 22
5 0 6 4
trying to find another from [9 9 7 4 8 7 1 7 8 7 6 2 7 5 5 4 3 6 6 5 3
+ 7]: 31
7 4 3 1
trying to find another from [9 9 7 4 8 7 8 7 6 2 7 5 5 6 6 5 3 7]: 138
5 2 3 5
trying to find another from [9 9 7 4 8 7 8 7 6 7 6 6 5 7]: 74781
^C

    [download]
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
Re: Randomly select values from array
by JavaFan (Canon) on May 16, 2010 at 10:41 UTC
    Consider the array (5, 5, 5, 10, 10, 10, 0, 0, 0, 0, 0, 0). Now, you can reduce this array to empty by repeatedly selecting (5, 10, 0, 0). However, if ones first pick is (5, 5, 5, 0), no further selections can be made.

    Now what?

[reply]
[d/l]
[select]
Re: Randomly select values from array
by Xilman (Hermit) on May 16, 2010 at 09:26 UTC

    I'm guessing that "selecting for of them" is a typo for "selecting four of them". If not, please post a correction. Note that there may not be a way to remove all the numbers from the array. What if all the elements are negative, or greater than 15 say?

    Here is a sketch of just one way; there are many others, some of them more efficient by various metrics. First, sort the array randomly. Then see whether the first four elements sum to 15. If so, remove them. Keep going until you have an array with four or fewer elements or until you get bored. This code fragment performs the selection, testing and removal. Wrapping it in code to loop and, optionally, terminating the procedure is left as an exercise because I don't want to do all your work for you.

    @data = sort {rand < rand} @data;
$data[0]+$data[1]+$data[2]+$data[3] == 15 and push @stored, [splice @d
+ata, 0, 4];

    [download]
    Paul
[reply]
[d/l]

      To emphasis how bad that sort-based "shuffle" is, consider that over a million shuffles of four values, 1/3rd of the possibilities are never chosen. And the rest are chosen so disproportionately that 'fairness' doesn't enter the equation: 

      ++$h{ join'',sort{ rand() < rand() } 'a'..'d' } for 1 .. 1e6;;

 printf "$_ : %.2f%%\n", $h{$_} / 1e4 for sort keys %h;;
abcd : 12.48%
abdc : 12.47%
bacd : 12.48%
badc : 12.49%
cabd : 3.15%
cadb : 3.12%
cbad : 3.14%
cbda : 3.13%
cdab : 6.26%
cdba : 6.26%
dabc : 3.13%
dacb : 3.15%
dbac : 3.13%
dbca : 3.11%
dcab : 6.26%
dcba : 6.25%

      [download]

      Contrast that with 

      use List::Util qw[ shuffle ];;
++$q{ join'',shuffle 'a'..'d' } for 1 .. 1e6;;

printf "$_ : %.2f%%\n", $q{$_} / 1e4 for sort keys %q;;
abcd : 4.18%
abdc : 4.12%
acbd : 4.14%
acdb : 4.20%
adbc : 4.17%
adcb : 4.18%
bacd : 4.15%
badc : 4.19%
bcad : 4.17%
bcda : 4.16%
bdac : 4.17%
bdca : 4.15%
cabd : 4.14%
cadb : 4.17%
cbad : 4.19%
cbda : 4.18%
cdab : 4.19%
cdba : 4.20%
dabc : 4.17%
dacb : 4.15%
dbac : 4.16%
dbca : 4.22%
dcab : 4.14%
dcba : 4.13%

      [download]

      And the latter is more efficient to boot.

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.
[reply]
[d/l]
[select]
        heh, use an older Perl (or use sort '_quicksort';), and you get abcd : 100%! Talk about not random.
[reply]
[d/l]
[select]
        A touch slow, but it works now: 
        use Algorithm::Permute qw(permute);

@a     = 'a' .. 'd';
$afact = 1;
$afact *= $_ for 2 .. @a;
permute {
    $h{ join '', sort { rand() < rand() } @a } += 1 / $afact;
} @a for 1 .. 1e5;   # a million takes a couple minutes

printf "$_ : %.2f%%\n", $h{ $_ } / 1e3 for sort keys %h;

        [download]
[reply]
[d/l]

        "To emphasis how bad that sort-based "shuffle" is, consider that over a million shuffles of four values, 1/3rd of the possibilities are never chosen. And the rest are chosen so disproportionately that 'fairness' doesn't enter the equation:"

        I must try to remember that some people have difficulty recognizing meiosis (not that I'm including BrowserUk in that list). My original post included the words: "some of them more efficient by various metrics".

        Oh well.

        Paul

[reply]
      @data = sort {rand < rand} @data;

      [download]
      is not guaranteed to work, much less return something random. Use List::Util's shuffle instead.
[reply]
[d/l]
[select]
Re: Randomly select values from array
by ikegami (Patriarch) on May 16, 2010 at 19:14 UTC
    Assuming the inputs can only be positive integers, 
    use strict;
use warnings;

use Algorithm::Loops qw( NestedLoops );
use List::Util       qw( sum );

my $M = 15;
my $N = 4;

my @groups;

sub init_groups {
   my $iter = NestedLoops(
      [  [ 1..$M-($N-1) ],
         ( sub {
            my $s = sum(@_);
            my $n = @_;
            [ $_..$M-$s-(($N-1)-$n) ]
         } ) x ($N-2),
         sub {
            my $rest = $M-sum(@_);
            $rest >= $_ ? [$rest] : []
         },
      ],
   );

   while (my @group = $iter->()) {
      push @groups, \@group;
   }
}

sub find_groups {
   local our %left; ++$left{$_} for grep $_ <= ($M-$N+1), @_;

   my @solutions;

   local *helper = sub {
      my $leaf = 1;
      my $first_idx = $_[-1] || 0;
      GROUP: for my $group_idx ($first_idx..$#groups) {
         local %left = %left;
         for my $x (@{$groups[$group_idx]}) {
            next GROUP if --$left{$x} < 0;
         }
         $leaf = 0;
         local $_[@_] = $group_idx;
         &helper;
      }

      push @solutions, [ @_ ] if $leaf;
   };

   helper();
   return \@solutions;
}

{
   init_groups();

   my @input = @ARGV ? @ARGV : ( sort { $a <=> $b } map int(rand(15))+
+1, 1..50 );
   print(join(' ', @input), "\n");

   my $solutions = find_groups(@input);
   for my $solution (@$solutions) {
      my $sep = '';
      for my $group_idx (@$solution) {
         print($sep, join(',', @{ $groups[$group_idx] }));
         $sep = ' | ';
      }
      print("\n");
   }
}

    [download]

    I'm not completely happy with it because it can find solutions that are subsets of previous solutions (although the $leaf code removes a lot of those). 

    1 1 1 1 1 3 4 4 4 4 4 4 4 4 5 5 5 5 6 6 6 6 7 7 7 7 8 8 8 9 9 9 9 10 1
+1 11 12 12 12 12 13 13 13 14 14 14 14 15 15 15
1,1,1,12 | 1,1,3,10
1,1,1,12 | 1,1,4,9 | 3,4,4,4
1,1,1,12 | 1,1,5,8 | 3,4,4,4
1,1,1,12 | 1,1,6,7 | 3,4,4,4
1,1,1,12 | 1,3,4,7 | 1,4,4,6
1,1,1,12 | 1,3,4,7 | 1,4,5,5
1,1,1,12 | 1,3,5,6 | 1,4,4,6
1,1,1,12 | 1,3,5,6 | 1,4,5,5
1,1,1,12 | 1,4,4,6 | 1,4,4,6 | 3,4,4,4
1,1,1,12 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,1,1,12 | 1,4,4,6 | 3,4,4,4
1,1,1,12 | 1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,1,1,12 | 1,4,5,5 | 3,4,4,4
1,1,1,12 | 3,4,4,4
1,1,3,10 | 1,1,4,9 | 1,4,4,6
1,1,3,10 | 1,1,4,9 | 1,4,5,5
1,1,3,10 | 1,1,5,8 | 1,4,4,6
1,1,3,10 | 1,1,5,8 | 1,4,5,5
1,1,3,10 | 1,1,6,7 | 1,4,4,6
1,1,3,10 | 1,1,6,7 | 1,4,5,5
1,1,3,10 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6
1,1,3,10 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5
1,1,3,10 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5
1,1,3,10 | 1,4,5,5 | 1,4,5,5
1,1,4,9 | 1,1,4,9 | 1,3,4,7
1,1,4,9 | 1,1,4,9 | 1,3,5,6
1,1,4,9 | 1,1,4,9 | 1,4,4,6 | 3,4,4,4
1,1,4,9 | 1,1,4,9 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 1,1,4,9 | 3,4,4,4
1,1,4,9 | 1,1,5,8 | 1,3,4,7
1,1,4,9 | 1,1,5,8 | 1,3,5,6
1,1,4,9 | 1,1,5,8 | 1,4,4,6 | 3,4,4,4
1,1,4,9 | 1,1,5,8 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 1,1,5,8 | 3,4,4,4
1,1,4,9 | 1,1,6,7 | 1,3,4,7
1,1,4,9 | 1,1,6,7 | 1,3,5,6
1,1,4,9 | 1,1,6,7 | 1,4,4,6 | 3,4,4,4
1,1,4,9 | 1,1,6,7 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 1,1,6,7 | 3,4,4,4
1,1,4,9 | 1,3,4,7 | 1,4,4,6 | 1,4,4,6
1,1,4,9 | 1,3,4,7 | 1,4,4,6 | 1,4,5,5
1,1,4,9 | 1,3,4,7 | 1,4,5,5 | 1,4,5,5
1,1,4,9 | 1,3,5,6 | 1,4,4,6 | 1,4,4,6
1,1,4,9 | 1,3,5,6 | 1,4,4,6 | 1,4,5,5
1,1,4,9 | 1,3,5,6 | 1,4,5,5
1,1,4,9 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6
1,1,4,9 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5
1,1,4,9 | 1,4,4,6 | 1,4,4,6 | 3,4,4,4
1,1,4,9 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 1,4,4,6 | 3,4,4,4
1,1,4,9 | 1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 1,4,5,5 | 3,4,4,4
1,1,4,9 | 3,4,4,4
1,1,5,8 | 1,1,5,8 | 1,3,4,7
1,1,5,8 | 1,1,5,8 | 1,3,5,6
1,1,5,8 | 1,1,5,8 | 1,4,4,6 | 3,4,4,4
1,1,5,8 | 1,1,5,8 | 1,4,5,5 | 3,4,4,4
1,1,5,8 | 1,1,5,8 | 3,4,4,4
1,1,5,8 | 1,1,6,7 | 1,3,4,7
1,1,5,8 | 1,1,6,7 | 1,3,5,6
1,1,5,8 | 1,1,6,7 | 1,4,4,6 | 3,4,4,4
1,1,5,8 | 1,1,6,7 | 1,4,5,5 | 3,4,4,4
1,1,5,8 | 1,1,6,7 | 3,4,4,4
1,1,5,8 | 1,3,4,7 | 1,4,4,6 | 1,4,4,6
1,1,5,8 | 1,3,4,7 | 1,4,4,6 | 1,4,5,5
1,1,5,8 | 1,3,4,7 | 1,4,5,5
1,1,5,8 | 1,3,5,6 | 1,4,4,6 | 1,4,4,6
1,1,5,8 | 1,3,5,6 | 1,4,4,6 | 1,4,5,5
1,1,5,8 | 1,3,5,6 | 1,4,5,5
1,1,5,8 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6
1,1,5,8 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,1,5,8 | 1,4,4,6 | 1,4,4,6 | 3,4,4,4
1,1,5,8 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,1,5,8 | 1,4,4,6 | 3,4,4,4
1,1,5,8 | 1,4,5,5 | 3,4,4,4
1,1,5,8 | 3,4,4,4
1,1,6,7 | 1,1,6,7 | 1,3,4,7
1,1,6,7 | 1,1,6,7 | 1,3,5,6
1,1,6,7 | 1,1,6,7 | 1,4,4,6 | 3,4,4,4
1,1,6,7 | 1,1,6,7 | 1,4,5,5 | 3,4,4,4
1,1,6,7 | 1,1,6,7 | 3,4,4,4
1,1,6,7 | 1,3,4,7 | 1,4,4,6 | 1,4,4,6
1,1,6,7 | 1,3,4,7 | 1,4,4,6 | 1,4,5,5
1,1,6,7 | 1,3,4,7 | 1,4,5,5 | 1,4,5,5
1,1,6,7 | 1,3,5,6 | 1,4,4,6 | 1,4,4,6
1,1,6,7 | 1,3,5,6 | 1,4,4,6 | 1,4,5,5
1,1,6,7 | 1,3,5,6 | 1,4,5,5
1,1,6,7 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6
1,1,6,7 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,1,6,7 | 1,4,4,6 | 1,4,4,6 | 3,4,4,4
1,1,6,7 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,1,6,7 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,1,6,7 | 1,4,4,6 | 3,4,4,4
1,1,6,7 | 1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,1,6,7 | 1,4,5,5 | 3,4,4,4
1,1,6,7 | 3,4,4,4
1,3,4,7 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5
1,3,4,7 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5
1,3,4,7 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5
1,3,4,7 | 1,4,5,5 | 1,4,5,5
1,3,5,6 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5
1,3,5,6 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5
1,3,5,6 | 1,4,4,6 | 1,4,5,5
1,3,5,6 | 1,4,5,5
1,4,4,6 | 1,4,4,6 | 1,4,4,6 | 1,4,4,6
1,4,4,6 | 1,4,4,6 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5
1,4,4,6 | 1,4,4,6 | 1,4,5,5 | 1,4,5,5
1,4,4,6 | 1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,4,4,6 | 1,4,4,6 | 3,4,4,4
1,4,4,6 | 1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,4,4,6 | 1,4,5,5 | 3,4,4,4
1,4,4,6 | 3,4,4,4
1,4,5,5 | 1,4,5,5 | 3,4,4,4
1,4,5,5 | 3,4,4,4
3,4,4,4

    [download]
[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom