Re^7: Challenge: 8 Letters, Most Words

[choroba]

Something like the following? It slows the algorithm terribly, though...

#!/usr/bin/perl
use warnings;
use strict;
use feature qw(say);

my %lc_words;
my $dict = shift;
my $FH;
open $FH, '<', $dict or $FH = *DATA;

while (<$FH>) {
    chomp;
    next if length > 8;
    my $lc = lc;
    $lc_words{$lc} = 1;
}
say scalar keys %lc_words;

my %sorted_count;

for (keys %lc_words) {
    my @letters = sort split //;
    my $sorted  = join q(), @letters;
    $sorted_count{$sorted}++;
}
say "$_: $sorted_count{$_}"
    for sort { $sorted_count{$a} <=> $sorted_count{$b} }
        keys %sorted_count;

print '-' x 78, "\n";

my %summed = %sorted_count;
for my $length (1 .. 7) {
    warn $length;
    for my $sorted (grep $length == length, keys %sorted_count) {
        my $regex = join '.*', split //, $sorted;
        for my $longer (grep $length < length, keys %sorted_count) {
            $summed{$longer} += $sorted_count{$sorted} if $longer =~ $
+regex;
        }
    }
}

sub merge {
    my ($str1, $str2) = @_;
    my $merged = q();
    while(length $str1 . $str2) {
        my $char1 = substr $str1, 0, 1;
        my $char2 = substr $str2, 0, 1;
        if ($char1 eq $char2) {
            $merged .= substr $str1, 0, 1, q();
            substr $str2, 0, 1, q();
        } elsif ($char1 ne q() and $char1 lt $char2 or $char2 eq q()) 
+{
            $merged .= substr $str1, 0, 1, q();
        } else {
            $merged .= substr $str2, 0, 1, q();
        }
        return if length $merged > 8;
    }
    return $merged;
}

warn "Merging...\n";
my $added;
while (1) {
    $added = 0;
    my @shorter = grep 8 > length, keys %summed;
    for my $str1 (@shorter) {
        for my $str2 (@shorter) {
            next if $str1 le $str2;
            my $merged = merge($str1, $str2);
            if (defined $merged
                and $str1 ne $merged
                and $str2 ne $merged) {
                next if exists $summed{$merged};
                $summed{$merged} = $summed{$str1} + $summed{$str2};
                $added++;
            }
        }
    }
    last unless $added;
    warn "Added $added\n";
}

say "$_: $summed{$_}"
    for sort { $summed{$a} <=> $summed{$b} }
        keys %summed;

__DATA__
abcd
acdb
adbc
dabc
bcad
efgh
fgeh
hegf
egfh
fegh
abcdxy
efghlm

[choroba]

Another idea: preprocess the input, adding all the combinations of the shorter words. Then run the original code without postprocessing. I will try to test it later, not much time at the moment...