Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Re: partition of an array

by rir (Vicar)
on Mar 17, 2009 at 02:20 UTC ( #751087=note: print w/ replies, xml ) Need Help??


in reply to partition of an array

When I realized that this wasn't going to be quick and easy, I decided that having a brute force implementation upon which to compare was necessary. Now, I think there is nothing better than to take a drink and a long walk.

It doesn't seem that anyone has provided a correct solution. I believe this is one.

Be well,
rir

!/usr/bin/perl use warnings; use strict; use List::Util qw/ sum /; local $, = ' '; my @ar = ( [qw{ 2 } ], [qw{ -1 2 } ], [qw{ -1 2 -4 }], [qw{ 90 -120 -10 -1 1 5 25 80 }], [qw{ 9 2 -4 }], [qw{ 9 1 6 3 }], [qw{ 1 2 3 4 5 6 }], [qw{ 1 1 2 3 4 5 6 }], [qw{ 1 2 3 4 5 9 10 }], [qw{ 1 1 1 2 2 2 2 4 }], [qw{ 9 1 1 1 1 1 1 1 1 1 }], [qw{ 7 7 7 1 0 0 0 -42 0 0 6 6 6 }], [qw{ 7 7 7 1 0 0 0 -42 0 0 6 6 6 -28 }], ); for my $in (@ar) { my ( $score, $hd, $tl ) = halves_w_closest_totals($in); no warnings 'uninitialized'; print "brute: $score [ @$in[@$hd]] [ @$in[@$tl]] $/"; } exit; # return score, half_input_aref, other_half_input_aref sub halves_w_closest_totals { my $ar = shift; return ( 0, [], [] ) unless @$ar; return ( 0, [], [ $ar[0] ] ) if 1 == @$ar; return ( 0, [ $$ar[0] ], [ $$ar[1] ] ) if 2 == @$ar; my $best_yet; my $diff; my @perm; my $iter = halves(@$ar); while ( @perm = $iter->() ) { my ( $h, $t ) = @perm; my @tot = sort { $a <=> $b } ( sum( @$ar[@$h] ), sum( @$ar[@$t +] ) ); $diff = abs( $tot[0] - $tot[1] ); if ( not defined $best_yet->[0] or $best_yet->[0] > $diff ) { $best_yet->[0] = $diff; @$best_yet[ 1, 2 ] = ( $h, $t ); last if 1 >= $best_yet->[0]; # if 1 then 0 not possible } } return ( $best_yet->[0], $best_yet->[1], $best_yet->[2] ); } # Return an Iter to yield all the unique halves of an array. # Mirror image results are not generated. # The Iter deals in/manipulates indices into the array input. sub halves { my @in = @_; my @return; # stack of answers my $done = 0; my $lsize = int @in / 2; # left half size my @lv = ( 0 .. $lsize - 1 ); # left current value my @lul; # left upper limits # set upper bounds for answer for even-sized or odd-sized input @lul = (0 == @in % 2) ? ( 0, $lsize+1 .. $#in) : ( $lsize+1 .. $#i +n); my $curs = @lv - 1; return sub { return shift @return, shift @return if @return; return if $done; return unless @in; if ( 1 == @in ) { ++$done; return [], [ $in[0] ]; } # larger inputs local $_; while (1) { #die "cursor s/b on lsd" unless $curs == $#lul; # Use the list of head indices to make a list of # tail indices and return two arefs my @ret_tail_idx = ( 0 .. $#in ); splice @ret_tail_idx, $_, 1 for reverse @lv; push @return, [@lv], [ @ret_tail_idx ]; # turn the counting gears if ( $lv[$curs] == $lul[$curs] ) { while ( $lv[$curs] >= $lul[$curs] && $curs > -1 ) { # Move to left while elem's are at max --$curs; } if ( $curs == -1 ) { # All elements are at upper limit. ++$done; last; } else { # Found an elem that can be increased. # Increase it, and set elem's to the # right by counting up, x, x+1, x+2, ... x+n. ++$lv[$curs]; while ( $curs < $lsize - 1 ) { ++$curs; $lv[$curs] = $lv[ $curs - 1 ] + 1; } --$lv[$curs]; # crank backward one } } ++$lv[$curs]; # turn crank forward return shift @return, shift @return if @return; } return shift @return, shift @return if @return; }; }


Comment on Re: partition of an array
Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://751087]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (19)
As of 2015-07-28 14:54 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (256 votes), past polls