BrowserUk has asked for the wisdom of the Perl Monks concerning the following question:
Given a number of postcards (say 5) and a number of pigeon holes (say 3); how many ways are there to distribute the cards into the holes such that each hole contains at least 1?
For the 5/3 case above, the following possibilities exist: 3 1 1
2 2 1
2 1 2
1 2 2
1 1 3
1 3 1 // added per GrandFather's post below
How to efficiently generate that sequence? The order of generation is immaterial.
Update: Need a better way
One way to do it, is to filter Algorithm::Combionatorics::variations_with_repetition() for the sum of values.
Ie. Generate the 27 variations: 1 1 1
1 1 2
1 1 3
1 2 1
1 2 2
1 2 3
1 3 1
1 3 2
1 3 3
2 1 1
2 1 2
2 1 3
2 2 1
2 2 2
2 2 3
2 3 1
2 3 2
2 3 3
3 1 1
3 1 2
3 1 3
3 2 1
3 2 2
3 2 3
3 3 1
3 3 2
3 3 3
And then filter on the sum() of the subsets to reduce it to the 6 I need: 1 1 3
1 2 2
1 3 1
2 1 2
2 2 1
3 1 1
Which doesn't seem too bad until you consider a realistic set, rather than my simple example.
For instance, with 12 postcards and 7 pigeon holes, there are 35,831,808 variations_with_repetition() each of which must be summed and compared in order to discard 99.9% to arrive at the 462 I need. That's horribly inefficient :(
With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
In the absence of evidence, opinion is indistinguishable from prejudice.
Re: Combinatorics problem.
by GrandFather (Saint) on Dec 11, 2015 at 08:31 UTC
|
Maybe not over efficient, at least on memory, but:
#!/usr/bin/perl
use strict;
use warnings;
my $cards = 5;
my $holes = 3;
my @arrangements = arrange(0, $cards, $holes);
print "@$_\n" for @arrangements;
sub arrange {
my ($usedHoles, $remainingCount, $totalHoles) = @_;
my @arrangements;
return [$remainingCount] if ++$usedHoles == $totalHoles;
for my $thisCount (1 .. $remainingCount - ($totalHoles - $usedHole
+s)) {
my @subArrangements =
arrange($usedHoles, $remainingCount - $thisCount, $totalHo
+les);
push @arrangements, map {[$thisCount, @$_]} @subArrangements;
}
return @arrangements;
}
Prints:
1 1 3
1 2 2
1 3 1
2 1 2
2 2 1
3 1 1
Update: avoiding most of the memory usage:
#!/usr/bin/perl
use strict;
use warnings;
my $cards = 5;
my $holes = 3;
arrange(0, $cards, $holes, '');
sub arrange {
my ($usedHoles, $remainingCount, $totalHoles, $prefix) = @_;
if (++$usedHoles == $totalHoles) {
print "$prefix $remainingCount\n";
return;
}
for my $thisCount (1 .. $remainingCount - ($totalHoles - $usedHole
+s)) {
arrange($usedHoles, $remainingCount - $thisCount, $totalHoles,
+ "$prefix $thisCount");
}
}
Premature optimization is the root of all job security
| [reply] [d/l] [select] |
|
C:\test>1149981-gf -cards=12 -holes=7 | wc -l
462
I'll probably try and turn it into an iterator once my brain's in gear; but the algorithm is spot on. Thanks again.
With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
In the absence of evidence, opinion is indistinguishable from prejudice.
| [reply] [d/l] |
Re: Combinatorics problem.
by GrandFather (Saint) on Dec 11, 2015 at 08:08 UTC
|
Should 1 3 1 be in the list of possibilities too?
Premature optimization is the root of all job security
| [reply] [d/l] |
|
| [reply] |
Re: Combinatorics problem. (NestedLoops)
by tye (Sage) on Dec 11, 2015 at 15:16 UTC
|
Just off the top of my head, this makes me think of $c-$p nested loops to pick slots for the surplus cards like:
my $p = 7; # Number of pigeon holes.
my $c = 12; # Number of cards
for my $s1 ( 1..$p ) {
for my $s2 ( $s1..$p ) {
for my $s3 ( $s2..$p ) {
... Need $c-$p loops
Which translates to simple code if I don't worry about being more efficient, but it also handles your 7,12 "instantly" for me.
#!/usr/bin/perl -w
use strict;
use Algorithm::Loops 'NestedLoops';
my( $p, $c ) = @ARGV;
my $iter = NestedLoops(
[ [ 1..$p ], ( sub { [ $_..$p ] } ) x ($c-$p-1) ],
);
my @s;
while( @s = $iter->() ) {
my @p = (1) x $p;
$p[$_-1]++ for @s;
print "@p\n";
}
| [reply] [d/l] [select] |
Re: Combinatorics problem.
by danaj (Friar) on Dec 11, 2015 at 09:25 UTC
|
use ntheory ":all";
my %seen;
forpart {
my @p=@_;
forperm {
my $s="@p[@_]";
say $s unless $seen{$s}++;
} scalar(@p);
} 5,{n=>3};
forpart iterates over partitions, including restrictions (in this case that n must be exactly equal to 3). forperm does permutations, and we use a hash to remove all the duplicates since some entries are identical. This generates:
3 1 1
1 3 1
1 1 3
2 2 1
2 1 2
1 2 2
It agrees with Grandfather's program for examples such as 28/6 and 18/8. However, while it's quite nice for smaller values, all the permutations with duplicates make it slower for the larger examples -- we go through a huge number of permutations for a small number of unique values.
Edit: it's much faster than the variations_with_repetitions method, but GF's programs are even better. A better unique-permutations solution would help. Or, since hdb pointed out this is compositions, perhaps add a new function or as an option for 'forpart'.
Update: ntheory 0.56 on CPAN now:
$ perl -Mntheory=:all -E 'forcomp { say "@_" } 5,{n=>3}'
1 1 3
1 2 2
1 3 1
2 1 2
2 2 1
3 1 1
Update 2: While the compositions iterator is the right solution, I looked into a better multiset permutations solution. The one I showed earlier (generate all permutations, collect unique ones) is simple and easy, but gets very slow. I implemented a simple multiset permutation iterator, so now we could do:
use ntheory ":all";
forpart {
formultiperm {
say "@_";
} [@_];
} 5,{n=>3};
For larger sets, this runs a little faster than oiskuu's solve code, about the same as my PP compositions iterator, but slower than GF's second solution or my XS compositions iterator. It's all in PP for now. | [reply] [d/l] [select] |
Re: Combinatorics problem. (Updated with more info.)
by oiskuu (Hermit) on Dec 11, 2015 at 19:45 UTC
|
I started with GrandFather's code, rewriting it slightly, then dumped the counts of a series with constant $holes, then looked it up on the OEIS. Hubris, I know.
Looks like the solution is a simple lookup in binomial coefficients (on a diagonal in the Pascal's triangle).
#! /usr/bin/perl -l
my $cards = 12;
my $holes = 7;
sub arrange {
my ($n, $k, $i, $prefix) = @_;
return "$prefix $n" if ++$i == $k;
map arrange($n - $_, $k, $i, "$prefix $_"), (1 .. $n - ($k - $i));
}
sub solve {
my ($n, $k) = (shift, shift);
return [@_, $n] unless (@_ - $k + 1);
map solve($n - $_, $k, @_, $_), 1 .. $n + (@_ - $k + 1);
}
# binomial coefficients ie combinations C(n,k)
# (this can be written far more efficiently, of course)
sub choose {
my ($n, $k) = (shift, shift);
return 0 if $k < 0 || $k > $n;
!$n || choose($n-1, $k) + choose($n-1, $k-1)
}
print "@$_" for solve($cards, $holes);
print "== ", int(()=solve($cards, $holes));
print "@{[map {int (()=solve($holes + $_, $holes))} 0..17]}";
print "@{[map {choose($holes -1 + $_, $_)} 0..17]}";
Update. Here's a solution with Algorithm::Combinatorics.
#! /usr/bin/perl -l
use Algorithm::Combinatorics ':all';
my $cards = 12;
my $holes = 7;
my $iter = combinations_with_repetition( [1 .. $holes], $cards - $hole
+s );
while (my $x = $iter->next) {
print "@{distrib($holes, $x)}";
}
sub distrib {
my @d = (1) x shift;
++$d[$_-1] for @{+shift};
return \@d;
}
| [reply] [d/l] [select] |
|
| [reply] [d/l] |
|
perl -Mntheory=:all -E 'say binomial(12-1,7-1)'
462
Basically the same with Math::Pari or Pari/GP.
Chinn and Heubach (2003) and Opdyke (2008) have interesting info relating restricted compositions to Pascal's triangle.
Edit: There's also some interesting but scattered info on OEISWiki, including the idea of encoding the compositions as RLE on binary. For generating the sequences, Kelleher's paper is a great reference. | [reply] [d/l] |
Re: Combinatorics problem.
by Laurent_R (Canon) on Dec 11, 2015 at 07:35 UTC
|
| [reply] |
|
You may want to try Algorithm::Combinatorics
I use Algorithm::Combinatorics all the time, but you have to work out which generator, or combination of generators to use for each particular problem, and this one is eluding me.
Also, I suspect that the sequence I need is a subset of one of the classical sequences (combs/perms/variations/partitions), and I would then need to filter the generated sequence, which can be grossly inefficient; so it may be better to program an algorithm that generates the sequence directly?
With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
In the absence of evidence, opinion is indistinguishable from prejudice.
| [reply] |
|
| [reply] |
Re: Combinatorics problem -- wrong solution
by Discipulus (Canon) on Dec 11, 2015 at 11:02 UTC
|
Argh, i'm damn slow.. i was sure the answer was in the Tartaglia's triangle, but no way.
here my, plain as usual, solution:
use strict;
use warnings;
my @posts = (1..$ARGV[0] || 5);
my @pigeons = (1..$ARGV[1] || 3);
print +('1 ' x @pigeons)."\n" if @posts == @pigeons;
die sprintf "%s is not enought for %s pigeons!",scalar @posts,scalar
+@pigeons
if @pigeons > @posts;
for (@pigeons) {
my $max = @posts - @pigeons + 1;
while ($max > 1){
my @distr = (0) x ($#pigeons+1);
$distr[0] = $max;
my $remain = @posts - $max;
my $i=0;
while ($remain > 0){
$i == $#distr ? $i=1 : $i++;
$distr[$i]++;
$remain--;
}
$max--;
print +(map{ "$distr[$_-1] "} @pigeons),"\n";
}
@pigeons = (pop @pigeons,@pigeons);
}
__DATA__
perl BUk-pigeons.pl 5 3
3 1 1
2 2 1
1 3 1
1 2 2
1 1 3
2 1 2
thanks for the amusement!
At the end of writing i was surpised i needed not an hash to get uniques results..
L*
UPDATE: sadly my solutions gives too few combinations.. perl BUk-pigeons.pl 12 7 | wc -l give me only 35 combinations..
There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
| [reply] [d/l] [select] |
Re: Combinatorics problem. (Updated with more info.)
by danaj (Friar) on Dec 12, 2015 at 07:15 UTC
|
I added a forcomp iterator to ntheory, and changed to Kelleher's RuleAsc algorithm from ZS1. The changes to support both compositions and partitions are minimal. This means lexicographic ordering for both (vs. anti-lexico), which I think fits in better with the same ordering for combinations and permutations. It has the same restriction options as partitions (min/max for both length and value). It's on github, not sure when it'll hit CPAN. (update: it's on CPAN now as version 0.56)
Some timings of various solutions on this thread, for larger values. Macbook Pro, Perl 5.22.0. Other sizes may give different results, each solution has different tradeoffs, etc. I thought it was interesting.
Method | 24,6 (33649) | 24,7 (100947) | 24,9 (490314) | Comments |
buk update | 83.1 | 18 min | --- | var with rep, test with List::Util::sum |
tye | 0.50 | 1.43 | 7.47 | Alg::Loops |
anon-hack2 | 0.24 | 1.04 | 4.18 | Alg::Comb combinations |
oiskuu2 | 0.35 | 1.01 | 4.30 | Alg::Comb var with rep |
GF1 | 0.31 | 1.06 | 7.04 | GrandFather's first code |
danaj1 | 0.18 | 0.97 | 59.8 | ntheory unique perms of partitions. Ouch on 24,9. |
danaj2-pp | 0.16 | 0.40 | 1.82 | New ntheory forcomp in Perl |
oiskuu1 | 0.13 | 0.35 | 2.61 | Recursive 'solve' code based on GF |
GF2 | 0.08 | 0.13 | 1.02 | GrandFather's second code |
danaj2 | 0.05 | 0.12 | 0.49 | New ntheory forcomp in XS |
| [reply] |
Re: Combinatorics problem.
by Anonymous Monk on Dec 11, 2015 at 08:36 UTC
|
I think its something like that:
$cards -= $holes; # one card per hole is required,
# so let's disregard those right away
my $r = $cards;
my $n = $cards + $holes - 1;
my $result =
factorial($n) / ( factorial($r) * factorial($n - $r) );
sub factorial {
use List::Util 'reduce';
return 1 if $_[0] <= 0;
return reduce { $a * $b } 1 .. $_[0];
}
If that's correct, i'll have more time for explanations later :) | [reply] [d/l] |
|
## usage example:
## program.pl -cards 5 -holes 3
use strict;
use warnings;
use feature 'say';
use Getopt::Long;
use Algorithm::Combinatorics 'combinations';
main();
exit 0;
sub main {
GetOptions(
'cards=i' => \my $cards,
'holes=i' => \my $holes
);
die unless $cards and $holes;
# TODO: more robust error checks
# for now let's just assume that the user is sane :)
$cards -= $holes;
my $tot = $cards + $holes - 1;
my $combos = combinations( [ 0 .. $tot - 1 ], $cards );
while ( my $combo = $combos->next() ) {
my $hack = '0' x $tot; # total hack! :)
for my $c (@$combo) {
substr( $hack, $c, 1, '1' );
}
say join ', ', map length() + 1, split /0/, $hack, -1;
}
}
example:
$ perl buk.pl -c 12 -h 7 | wc -l
462
| [reply] [d/l] [select] |
|
## usage example:
## program.pl -cards 5 -holes 3
use strict;
use warnings;
use feature 'say';
use Getopt::Long;
use Algorithm::Combinatorics 'combinations';
main();
exit 0;
sub main {
GetOptions(
'cards=i' => \my $cards,
'holes=i' => \my $holes
);
die "Usage: $0 -c CARDS -h HOLES\n"
if !defined($cards)
|| !defined($holes)
|| $cards <= 0
|| $holes <= 0
|| $cards < $holes;
$cards -= $holes;
my $tot = $cards + $holes - 1;
my $combos = combinations( [ 0 .. $tot - 1 ], $cards );
while ( my $combo = $combos->next() ) {
my @result = (1) x $holes;
for my $i ( 0 .. @$combo - 1 ) {
$result[ $combo->[$i] - $i ] += 1;
}
say join ', ', @result;
}
}
| [reply] [d/l] |
|
| [reply] [d/l] |
|
So we're trying to distribute 5 cards over 3 holes. Here're the holes:
|_|_|_|
Let's put the cards there. Well, they won't fit, because the '_' (underscore) occupies the whole cell, rather than just the bottom of it. Let's get rid of underscores. They're just for visials anyway.
| | | |
Now it fits. One way to do it:
1 1
|1|1|1|
or maybe like this:
1
1
|1|1|1|
First, the bottom row of ones is always the same. We don't actually need it to count combination. Lets just remove it (like in tetris). The number of ways to distribute 5 cards over 3 holes with BUK's constraint is the same as the number of ways to distribute 2 cards over 3 holes without this constraint.
1) |1|1| |
2) | |1|1|
1
3) | | |1|
4) and so on
That actually looks like a datastructure we can work with. The problem is it's two dimensional. Which is kind of a pain. But! we can flatten it. Like so:
1) | |1|1|
2) |1|1| |
3) |11| | |
4) | |11| |
5) and so on
Now there are two more things. The spaces in empty holes are not necessary. Also, the two '|' (pipes) at the left and right edges of our strings are not necessary either. That's also just visuals. Let's remove that stuff.
1) | | |11| => ||11 => 0 0 2
2) |1|1| | => 1|1| => 1 1 0
3) | |11| | => |11| => 0 2 0
4) etc
For no particular reason I used '0' instead of '|' in hacky solution :) (hm, I think that's because it reminded me of a recent thread). Like that:
1) 0011 => 0 0 2
2) 1010 => 1 1 0
3) 0110 => 0 2 0
Now we just want to count all combinations of such strings. The length of a string is $cards (which is the number of ones) + $holes - 1 (which is the number of zeros). That's our $n. And $r is obviously the number of cards. Think of it this way:
0000 - start with string of all zeros
.00. - take some zeroes that way
1001 - and replace with ones
0..0 - take some zeroes that way
0110 - and replaces with ones
00.. - then that way
0011 - you got the idea
Hopefully now its clear that the number of ways we can produce such strings is n! / (r!(n-r)!), just like in a textbook.
And my hacky solution literally builds these strings and counts the length of sequences of ones :) Which is a bit of a nonsense, and GrandFather's method is a lot better, but hey! it works ;) | [reply] [d/l] [select] |
|
Oops, didn't notice you wanted to generate the combinations themselves too. I'll do it a bit later.
| [reply] |
Re: Combinatorics problem. (Updated with more info.)
by hdb (Monsignor) on Dec 12, 2015 at 17:03 UTC
|
Here is a direct, iterative solution generating the possibilities in reverse lexicographical order (no modules, no waste).
use strict;
use warnings;
my $base = 1; # minimum of cards per hole
sub first {
my( $holes, $cards ) = @_;
my @c = ($base) x $holes;
$c[0] += $cards - $base * $holes;
$c[0] >= $base or die "Not enough cards!\n";
return \@c;
}
sub next_comp {
my $c = shift;
my $i = 0;
$i++ while $i < @$c and $c->[$i] == $base;
$i >= @$c-1 and return;
$c->[$i+1]++;
$c->[0] = $c->[$i] - 1;
$c->[$i] = $base if $i > 0;
return $c;
}
@ARGV == 2 or die print "Usage: $0 holes cards\n";
my $c = first( @ARGV );
my $i = 0;
print ++$i.": @$c\n";
print ++$i.": @$c\n" while $c = next_comp $c;
This also reminds me of Odometer pattern iterator (in C). (Updated.). | [reply] [d/l] |
|
|