Re: Randomly select values from array

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]

Comment on Re: Randomly select values from array Select or Download Code


Problems? Is your data what you think it is?
	PerlMonks