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 = { 0 => [[], []] };

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

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

    while (my ($key, $value) = each %$old) {
      if (
        $key > $sum - $max_sum_of_previous[$i] + abs($known_solution)
      ) {
        # This cannot be an improvement.
        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;
    my $best = abs($known_solution);
    while (defined(my $key = each %$new)) {
      if ($key < $best) {
        $best = $key;
      }
    }

    $answer = $new->{$best};
  }

  # 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]