sub find_best_partition {
  my @numbers = sort {abs($b) <=> abs($a) or $a <=> $b} @_;

  # First we're going to find a "pretty good" partition.  If we can,
  # we'll find a partition that finishes off this way. That will
  # usually let the full algorithm abort early.
  my @in_partition;
  my $current_remaining = 0;
  for my $n (@numbers) {
    if ($current_remaining < 0) {
      if ($n > 0) {
        push @in_partition, 1;
        $current_remaining += $n;
      }
      else {
        push @in_partition, 0;
        $current_remaining -= $n;
      }
    }
    else {
      if ($n > 0) {
        push @in_partition, 0;
        $current_remaining -= $n;
      }
      else {
        push @in_partition, 1;
        $current_remaining += $n;
      }
    }
  }

  my $known_solution = $current_remaining;

  # Cheat, we're going to find out the extremes.
  my @max_sum_of_previous = 0;
  my $sum = 0;
  for my $n (@numbers) {
    $sum += abs($n);
    push @max_sum_of_previous, $sum;
  }

  # We're going to try to find partitions that add up to each
  # possible number that can be added up to.
  my $old;
  my $new = [ [[], []] ];

  my $i = -1;
  my $answer;
  for my $n (@numbers) {
    $old = $new;
    $new = [];
    $i++;

    my $upper = $#$old;
    # Skip values too big to lead to an improvement.
    if (
      $upper
        > $sum - $max_sum_of_previous[$i] + abs($known_solution)
    ) {
      $upper
        = $sum - $max_sum_of_previous[$i] + abs($known_solution);
    }

    if ($current_remaining > 0) {
      if ($old->[$current_remaining]) {
        my ($p1, $p2) = @{ $old->[$current_remaining] };
        $answer = [$p2, $p1];
        last;
      }
    }
    elsif ($old->[-$current_remaining]) {
      $answer = $old->[-$current_remaining];
      last;
    }

    for my $key (0..$upper) {
      my $value = $old->[$key] or next;

      my ($p1, $p2) = @$value;
      if ($key + $n < 0) {
        $new->[-$key - $n] ||= [$p2, [$n, $p1]];
      }
      else {
        $new->[$key + $n] ||= [[$n, $p1], $p2];
      }
      if ($key - $n < 0) {
        $new->[$n - $key] ||= [[$n, $p2], $p1];
      }
      else {
        $new->[$key - $n] ||= [$p1, [$n, $p2]];
      }
    }

    # Adjust $current_remaining for the fact we're skipping
    # the $i'th element.
    if ($in_partition[$i]) {
      $current_remaining -= $n;
    }
    else {
      $current_remaining += $n;
    }
  }

  if (not $answer) {
    # Do not include any of the original partition.
    $i = @numbers;
    for my $j (0..$#$new) {
      if ($new->[$j]) {
        $answer = $new->[$j];
        last;
      }
    }
  }

  # We need to flatten nested arrays, and append the tail.
  my ($p1, $p2) = @$answer;

  my @part_1;
  while (@$p1) {
    push @part_1, $p1->[0];
    $p1 = $p1->[1];
  }
  push @part_1
    , map {
        $in_partition[$_] ? $numbers[$_] : ()
      } $i..$#numbers;

  my @part_2;
  while (@$p2) {
    push @part_2, $p2->[0];
    $p2 = $p2->[1];
  }
  push @part_2
    , map {
        $in_partition[$_] ? () : $numbers[$_]
      } $i..$#numbers;

  return (\@part_1, \@part_2);
}
[download]