http://www.perlmonks.org?node_id=180675

in reply to Puzzle: need a more general algorithm

Ok, this is that straight forward recursive method. By keeping track of the subsets we've already looked at, it's not too bad with the 50, 1-150 set.

Update: Pass data by reference as suggested. A couple other small changes. Added another indice for array totals.

```#!/usr/bin/perl
use strict;
use warnings;

use constant DEBUG => 0;
#  my \$columns = 6;
#  my @data = qw( 10 13 25 30 10 15 1 4 25);
my \$columns = 50;
my @data = (1..150);
die "Not enough catagories for columns\n"
if \$columns > @data;
our \$mega_height = sum(\@data);
my \$best_r = get_best(\$columns, \%add_h, \%key_h, \@data);
printit(\$best_r);
exit;

sub get_best {
my (\$columns, \$add_r, \$key_r, \$data_r) = @_;

my \$max_stack = @\$data_r - \$columns + 1;
my \$max_height = \$mega_height;
my \$fed_key = join("-", @\$data_r, \$columns);
print "[", join(",", @\$data_r),"]-",\$columns,"\n" if DEBUG;
my \$best_r;
foreach my \$stack ( 1 .. \$max_stack ) {
my @arr;
\$arr[0] = [ @\$data_r[0..\$stack-1] ];
my \$tmp_r;
if (\$columns == 2) {
# We only have one more column to fill
push(@arr, [ @\$data_r[\$stack..@\$data_r-1] ]);
}
elsif (@\$data_r - \$stack == \$columns - 1 ) {
# One cat per column left
map push(@arr, [ \$_ ]), @\$data_r[\$stack..@\$data_r-1];
}
else {
my \$key = join("-", @\$data_r[\$stack..@\$data_r-1],
\$columns - 1);
# See if we've done this before
if ( defined( \$key_r->{\$key} )) {
\$tmp_r = \$key_r->{\$key};
}
else {
\$tmp_r = get_best( \$columns - 1, \$add_r, \$key_r,
[@\$data_r[\$stack..@\$data_r-1]] );
}
push ( @arr, @\$tmp_r );
}
my \$cur_height = 0;
foreach my \$col_r (@arr ) {
my \$height;
my \$ckey = join(",",@\$col_r);
if ( defined( \$add_r->{\$ckey} )) {
}
else {
\$height = sum(\$col_r);
}
\$cur_height = \$height if \$cur_height < \$height;
}
printit(\@arr) if DEBUG;
if ( \$cur_height < \$max_height or !defined(\$best_r)) {
\$best_r = \@arr;
\$max_height = \$cur_height;
}
}
\$key_r->{\$fed_key} = \$best_r;
return \$best_r;
}

sub sum {
my (\$col_r) = @_;

my \$height = 0;
foreach my \$bit ( @\$col_r ) {
\$height += \$bit;
}
return \$height;
}

sub printit {
my (\$arr_r) = @_;
my \$start = 1;
my \$max = 0;
foreach my \$col_r (@\$arr_r) {
print ", " unless \$start;
\$start = 0 if ( \$start );

my \$height = sum(\$col_r);
print "[ ", join(", ", @\$col_r), " ]";
\$max = \$height if \$height > \$max;
}
print " => \$max\n";
}