my $MIN_BEST = 2; my @words; my %letters_cache; while () { my ($i, $word) = split; push @{$words[$i-1]}, $word; $letters_cache{$word}{$_} = () = $word =~ /($_)/g for 'a'..'z'; } my %best; my %skip; for my $i (0 .. $#words) { for my $l ('a'..'z') { my $best = 0; $best{$l}[$i] = []; for my $word (@{$words[$i]}) { my $c = $letters_cache{$word}{$l}; if ( $c > $best ) { $best{$l}[$i] = [ $word ]; $best = $c; } elsif ( $c == $best ) { push @{$best{$l}[$i]}, $word; } } $skip{$l}++ if $best < $MIN_BEST; } } my @best_words; my $best_score = 0; foreach my $l ( 'a' .. 'z' ) { next if $skip{$l}; my $iter = NestedLoops($best{$l}); while ( my @w = $iter->() ) { @w = map { ref$_ ? @$_ : $_ } @w; my $score = calculate_score( @w ); if ( $score > $best_score ) { $best_score = $score; @best_words = @w; } } } sub calculate_score { my %letters; foreach my $w (@_) { my $v = $letters_cache{$w}; while (my ($l,$n) = each %$v) { $letters{$l} += $n; } } # add them up. our ($a,$b); # get rid of warning? reduce { $a + calculate_letter_value($b) } 0, values %letters; } sub calculate_letter_value { my $n = shift; ($n * ($n + 1)) / 2; }