[SPOILER] Much less crappy acrostic program

This is a major improvement on my last try.  For a short quotation (40
letters) it finds a solution in about half a second.

The big change is that it now tries the possible words in order by how
much they resemble the pool of letters that remain to be allocated.
If the quotation has a lot of G's left that have not been assigned to
answer words, the program will tend to try answer words with lots of
G's.

There is a small fudge factor ($BONUS) in favor of words with fewer
vowels.  If the quotations has lots of I's left, the program will
still prefer words with lots of I's, but not quite as much as it would
if they were G's.  This keeps the program from running out of vowels
prematurely.  The fudge factor needs manual adjustments; decrease it
for shorter quotations.  

----------------------------------------------------------------


my $BONUS = .03;  # Hand-tune this

$Q = q{
         Paul Gray ... has always edited and improved my writings ... 
        In return, I never mention his name unless
        somebody points out an error ... in
        which case I always say, "Paul Gray told me that."
};

$A = q{robert e. machol - lerner's law};


for ($Q, $A) { tr/a-z/A-Z/; tr/A-Z//cd; }
my $pat = qr/^[\L$Q]{4,}$/;
print "pat: $pat\n";

# open D, "<", "minidict" or die;
#open D, "<", "/usr/share/dict/words" or die;
open D, "<", "words" or die;
my $dictcount;
while (<D>) {
        chomp;
        next unless /$pat/;
#        next if /[^a-z]/ || length($_) < 4;

        my ($init, $trim) = /(.)(.*)/;
        my $anagram = anagram($trim);
        $d{$init}[length $_]{$trim} = 1;
        $a{$init}{$anagram} = 1;
        $dictcount++;
}
#warn "Read $dictcount words from the dictionary.\n";

my @clueletter = split //, $A;

{my %count;
 my $length = 0;
 for my $l (split //, $Q) {
   $count{$l}++;
   $length++;
 }
 for my $l (split //, $A) {
   die "Impossible (not enough $l\'s).\n" if --$count{$l} < 0;
 }

 search(0, $#clueletter, {}, undef, \%count, $length);
}

sub search {
  my ($N, $maxN, $cluedict, $cluelist, $count, $length, $last) = @_;
  my $I = " |" x $N;
  my $FIRST = $clueletter[$N];
  my $dicts = $d{lc $FIRST};
  my $ana_key = count_to_anagram($count);

  return unless $count->{$FIRST} >= 0;

  # Last clue
  if ($N eq $maxN) {
    return unless $a{lc $FIRST}{$ana_key};

    for my $word (keys %{$dicts->[$length]}) {
      next unless anagram($word) eq $ana_key;
      next if $cluedict->{$word};
      win(["\u$FIRST $word", $cluelist]);
    }
    die "How did I get here?";
  }

  my $avg_len = $length / ($maxN-$N+1) + 1;
  return if $avg_len > 10;

  my @N = sort {abs($a-$avg_len) <=> abs($b-$avg_len)} (0.. $#$dicts);
#  warn "$I-@N\n";
  for my $wordlen (@N) {
    next unless $dicts->[$wordlen];
    next if $wordlen > $length;
    $COUNT = $count;
    $LENGTH = $length;
    my @words = map {$_->[1]} sort {$a->[0] <=> $b->[0]} map {[score(uc $_), $_]} 
      keys %{$dicts->[$wordlen]};
#    warn "$I best $wordlen-words for $ana_key are: @words[0..3] ... $words[-1]\n";
#    warn("$I    none of these will work\n"), return if score(uc $words[0])> 100;
    for my $word (@words) {
      my $new_count;
      next if length($word) >= $length;
      next if $cluedict->{$word};
      next unless $new_count = subtract($count, $word);
      my $vcount = $word =~ tr/aeiou//;
      $vcount++ if $FIRST =~ /[AEIOU]/;
      search($N+1, $maxN, {%$cluedict, "\l$FIRST$word" => 1}, ["$FIRST $word", $cluelist], $new_count, $length-length($word)-1, "$FIRST $word");
    }
  }
  return;
}


sub score {
  my $word = shift;
  my $len = length($word)+1;
  my %count;
  for (split //, $word) {
    $count{$_}++;
  }
  my $score = 0;
  for ('A' .. 'Z') {
    my $m = $BONUS if /[AEIOU]/; # Bonus for having fewer vowels
    my $lscore = $count{$_}/$len - $COUNT->{$_}/$LENGTH + $m;
    return 1000 if $count{$_} && ! $COUNT->{$_};
    $score += $lscore * $lscore;
  }
  $score;
}

sub win {
  my $cluelist = shift;
  my @clues;
  while ($cluelist) {
    unshift @clues, $cluelist->[0];
    $cluelist = $cluelist->[1];
  }
  print join "\n", @clues, "";
  exit 0;
}

sub anagram {
  join "", sort split //, $_[0];
}

sub count_to_anagram {
  my $c = shift;
  my $r = "";
  for ('A' .. 'Z') {
    $r .= lc() x $c->{$_};
  }
  $r;
}

sub subtract {
  my ($count, $word) = @_;
  my %ncount = %$count;
  for my $l (split //, uc $word) {
    return unless $ncount{$l}--;
  }
  return \%ncount;
}