Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

How to restrict partitions

by crunch_this! (Acolyte)
on Jan 18, 2014 at 02:53 UTC ( [id://1071050]=perlquestion: print w/replies, xml ) Need Help??

crunch_this! has asked for the wisdom of the Perl Monks concerning the following question:

Hi

It's easy enough to get Integer::Partition working but what if I'm only interested in partitions that have an exact number of summands, like 3? & what if they all have to be distinct?

For partitions of 6, using

my $i = Integer::Partition->new(6); while (my $p = $i->next) { print join( ' ', @$p ), $/; }

Perl gives me

6
5 1
4 2
4 1 1
3 3
3 2 1
3 1 1 1
2 2 2
2 2 1 1
2 1 1 1 1
1 1 1 1 1 1

But what if I were only interested in the ones with exactly 2 distinct summands, ie

5 1
4 2
... which of course cuts out a lot of possibilities.

Replies are listed 'Best First'.
Re: How to restrict partitions
by toolic (Bishop) on Jan 18, 2014 at 02:58 UTC
    use warnings; use strict; use Integer::Partition qw(); my $i = Integer::Partition->new(6); while (my $p = $i->next) { print join( ' ', @$p ), $/ if (@$p == 2) and ($p->[0] != $p->[1]); } __END__ 5 1 4 2
      if (@$p == 2) and ($p->[0] != $p->[1]);

      Thx for the quick reply, that definitely did the trick but is there a more general way to do this? I'm just thinking of all the 'ands' I'd have to include. What if I want exactly, say, 5 summands?

        UPDATE: This does not satisfy the clarified requirements in the response.

        use warnings; use strict; use Integer::Partition qw(); my $i = Integer::Partition->new(6); while (my $p = $i->next()) { print join( ' ', @$p ), $/ if (@$p == 5) and not all_same(@$p); } sub all_same { my $same = 1; for (@_[1 .. $#_]) { if ($_ != $_[0]) { $same = 0; last; } } return $same; } __END__ 2 1 1 1 1
Re: How to restrict partitions
by hdb (Monsignor) on Jan 19, 2014 at 09:50 UTC

    It seemed wasteful to me to first create all partitions and then filter out the wanted ones. And I wanted to say that it should be simple to draw a partition algorithm that directly does what you want. But it took me longer than I thought...

    use strict; use warnings; sub partition { my( $n, $level, $max, @part ) = @_; $max //= $n; $level //= $n; my @solutions = $n <= $max ? [ @part, $n ]: (); $max = $n-1 if $max > $n-1; push @solutions, map { partition( $n-$_, $level-1, $_-1, @part, $_) +} reverse 1..$max if $level > 1 and $n > 2; return @solutions; } my( $number, $depth ) = @ARGV; my @s = partition $number, $depth; print "@$_\n" for @s;

    Update: Changed 0..$max to 1..$max.

    Update 2: You are not doing this to solve Kakuro puzzles?

      Not kakuro, I'm trying to find polynomials with integer roots whose critical points are also integers. My first idea turned out to create too big a 'haystack' but then I remembered that one of the coefficients of a polynomial is the sum of the zeros. I'm hoping to use them to construct the polynomials I'm interested in. So I figure if I consider the sum of the zeros (the partitions here) it might cut the haystack down quite a bit. At least in the few trial runs I've done it seems to have helped a lot. It wouldn't automatically solve it, I guess you could say it's a "necessary but not sufficient" type of thing where I'd still have to sift through the partitions to find what I'm interested in. An important consideration is that the number of partitions of n increases very quickly, however I'm hopeful that with the restrictions I want to use it will cut down on the amount of stuff I'm not looking for.

      I tried that program but I keep getting 'uninitialized value' errors on $max, $n & $level but I'm not sure how to fix them. I tried tye's attempt below & it seems to work great. It cuts back on a lot of the stuff I'm not looking for but I definitely want to try to get yours working too.

      For example, here's part of what I've been using for a quartic, where is_approximately_an_integer is used to determine whether or not the derivative has roots "close enough" to integers, and poly_roots & poly_derivative are from the Math::Polynomial package:

      grep { is_approximately_an_integer( @$_ ) } [ poly_roots( poly_derivative( # expanded form of x*(x - $x)*(x - $y)*(x - $z) 1, -$x - $y - $z, $x*$y + $x*$z + $y*$z, -$x*$y*$z, 0 ) ) ];

        Sorry, this is my fault. I forgot to explain that you need to give the number you want to partition on the commandline and, optionally, also the maximum number of elements.

Re: How to restrict partitions (NestedLoops)
by tye (Sage) on Jan 19, 2014 at 21:08 UTC
    #!/usr/bin/perl -w use strict; use Algorithm::Loops qw( NestedLoops ); $| = 1; my @sum= shift || 20; my $terms = shift || 4; print "Ways to get a sum of $sum[0] from $terms unique addends:\n"; my $tries= 0; my $iter= NestedLoops( [ ( sub { my $n = @_ ? 1+$_[-1] : 1; my $t = $terms - @_; my $m = $sum[$#_]/$t-($t-1)/2; return [ $n .. int $m ]; } ) x $terms ], { OnlyWhen => sub { $tries++; 0 == ( $sum[@_]= $sum[$#_] - $_[-1] ) && $terms == @_; }, }, ); my @cnt; my $seq= 0; while( @cnt= $iter->() ) { printf "%d) %s\n", ++$seq, join ' + ', @cnt } print "($tries tries)\n";

    - tye        

      Instead of printing out the partitions, how could I plug them into (I guess) an array & then use them in a polynomial? What I've been using up to now (thx to hdb months ago) is

      while (my ($x, $y, $z) = @{ $iter->next // [] }) { push @wants, map { { join(', ', $x, $y, $z) => $_ } } grep { is_approximately_an_integer( @$_ ) } [ poly_roots( poly_derivative( # expanded form of x*(x - $x)*(x - $y)*(x - $z) 1, -$x - $y - $z, $x*$y + $x*$z + $y*$z, -$x*$y*$z, 0 ) ) ]; }

      The stuff in the while is from the Algorithm::Combinatorics module & the subroutine goes through the zeros of the polynomial's derivative to pick out the ones that have zeros that are all close enough to an integer. I guess it would be to get the elements of @cnt in the prog above but I'm not sure how to do that. Is it as simple as replacing the $x, $y, $z with $cnt[0], $cnt1, $cnt2 in the code above? Or maybe defining my $x = $cnt[0]?

      (a couple minutes later)

      my @cnt; my $seq= 0; my $x = $cnt[0]; my $y = $cnt[1]; my $z = $cnt[2]; while( @cnt = $iter->() ) { #printf "%d) %s\n", ++$seq, join ' + ', @cnt map { { join(', ', $x, $y, $z) => $_ } } grep { is_approximately_an_integer( @$_ ) } [ poly_roots( poly_derivative( # expanded form of x*(x - $x)*(x - $y)*(x - $z) 1, -$x - $y - $z, $x*$y + $x*$z + $y*$z, -$x*$y*$z, 0 ) ) ]; }

      Actually, now that I've tried that, I get errors in the line with the map & also the following one with the grep saying $x, $y, $z are uninitialized which I don't understand because I set them to be elements of @cnt.

        while( my( $x, $y, $z ) = $iter->() ) {

        - tye        

Re: How to restrict partitions
by Laurent_R (Canon) on Jan 18, 2014 at 19:57 UTC
    Hmm, for small numbers, you can certainly afford to use Integer::Partition and filter out combinations that do not fit your needs, but if your numbers grow only slightly larger, then your program is going to do really a lot of unnecessary work and very quickly become unusable. I do not know if any module is able to do that, but I strongly suspect that you might need to write your own algorithm if you want to process any number with more than 2 digits, perhaps even with smaller numbers.
Re: How to restrict partitions
by danaj (Friar) on Oct 04, 2014 at 06:47 UTC
    Rather late, but I believe this works:
    use warnings; use strict; use ntheory qw/forpart/; use List::MoreUtils qw/uniq/; my $sum = shift || 20; my $terms = shift || 4; forpart { print "@_\n" if @_ == uniq @_ } $sum,{n=>$terms};

    forpart is a partitions iterator similar to Pari/GP 2.6.1+, either unrestricted or with min/max/exact number of elements / size of elements. Pari/GP has some better optimizations, but even so, restricting the number of elements inside the XS code is a big win.

    For cases where the sum and number of desired partitions gets large it helps to be a little smarter. Since we want unique elements, we know sequences like ... 1 1 1 1 1 won't work. The minimum sequence ends with ... 5 4 3 2 1, so we can find out the largest allowed element:

    use warnings; use strict; use ntheory qw/forpart/; use List::MoreUtils qw/uniq/; my $sum = shift || 20; my $terms = shift || 4; my $amax = $sum; $amax -= $_ for 1 .. $terms-1; if ($amax > 0) { forpart { print "@_\n" if @_ == uniq @_ } $sum, {n=>$terms, amax=>$amax}; }
    I think this is pretty straightforward to use and quite fast for most cases. As the sum goes up much over 100 this can still get out of control (Pari has the same issue). tye's Algorithm::Loops solution is better at weeding out non-uniques early in this case.

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others pondering the Monastery: (1)
As of 2024-04-16 00:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found