Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Combinatorics problem. (Updated with more info.)

by BrowserUk (Patriarch)
on Dec 11, 2015 at 06:47 UTC ( #1149981=perlquestion: print w/replies, xml ) Need Help??

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:

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.
"Science is about questioning the status quo. Questioning authority". I knew I was on the right track :)
In the absence of evidence, opinion is indistinguishable from prejudice.

Replies are listed 'Best First'.
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
      Update: avoiding most of the memory usage:

      That's perfect. Thankyou.

      It generates the 462 of my bastard testcase instantly:

      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.
      "Science is about questioning the status quo. Questioning authority". I knew I was on the right track :)
      In the absence of evidence, opinion is indistinguishable from prejudice.
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

      Indeed, yes. Thanks for spotting my illiterate error.


      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.
      "Science is about questioning the status quo. Questioning authority". I knew I was on the right track :)
      In the absence of evidence, opinion is indistinguishable from prejudice.
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"; }

    - tye        

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

      ++ oiskuu i suspected that the answer had to be in the triangle.. congrats!

      L*
      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.

        From DLMF or MathWorld we see the number of restricted compositions is binomial(n-1,m-1). So:

        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.

Re: Combinatorics problem.
by danaj (Friar) on Dec 11, 2015 at 09:25 UTC

    Related module surveys:: Partitions and combinations / permutations.

    It looks like you want all the unique permutations of the 3-entry partitions. Using ntheory this could be done as:

    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.

Re: Combinatorics problem.
by Laurent_R (Canon) on Dec 11, 2015 at 07:35 UTC
      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.
      "Science is about questioning the status quo. Questioning authority". I knew I was on the right track :)
      In the absence of evidence, opinion is indistinguishable from prejudice.

        You are looking for Composition_(combinatorics) and need to filter on the number of parts (after taking away 1 postcard for each pidgeon hole as suggested below). I have not found any code on CPAN for this. The bad news is that there are exponentially many compositions for a given number of postcards.

Re: Combinatorics problem -- wrong solution
by Discipulus (Abbot) 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.
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.

    Method24,6
    (33649)
    24,7
    (100947)
    24,9
    (490314)
    Comments
    buk update83.118 min---var with rep, test with List::Util::sum
    tye0.501.437.47Alg::Loops
    anon-hack20.241.044.18Alg::Comb combinations
    oiskuu20.351.014.30Alg::Comb var with rep
    GF10.311.067.04GrandFather's first code
    danaj10.180.9759.8ntheory unique perms of partitions. Ouch on 24,9.
    danaj2-pp0.160.401.82New ntheory forcomp in Perl
    oiskuu10.130.352.61Recursive 'solve' code based on GF
    GF20.080.131.02GrandFather's second code
    danaj20.050.120.49New ntheory forcomp in XS

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.).

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 :)
      hacky solution :)
      ## 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
        okay, less of a hack :)
        ## 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; } }
      i'll be glad to read your explanation of using binomial coefficients..

      was my first intuition but my math fu is so low. Thanks anyway for the clever solution.

      L*
      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.
        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 ;)

      Oops, didn't notice you wanted to generate the combinations themselves too. I'll do it a bit later.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://1149981]
Approved by Ratazong
Front-paged by Discipulus
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (3)
As of 2022-05-19 18:36 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (72 votes). Check out past polls.

    Notices?