/me joins in the fun
open my $DICT, "<", "players" or die $!;
my (%words, %suffix, %prefix);
while (defined(my $word = <$DICT>)) {
chomp $word;
$word = lc $word;
next unless $word =~ m/^[a-z]{2,}$/;
next if $words{$word}++;
push @{$suffix{substr $word, $_}}, $word
for (1 .. length($word) - 1);
push @{$prefix{substr $word, 0, $_}}, $word
for (1 .. length($word) - 1);
}
#find_words("wozniacki"); find_words("zhou");
find_words($_)
for sort keys %words;
sub find_words {
my $word = shift;
die "not a \"word\"" unless exists $words{$word};
for my $idx (1 .. length($word) - 1) {
my $prefix = substr $word, 0, $idx;
my $suffix = substr $word, $idx;
next unless exists $prefix{$prefix} && exists $suffix{$suffix}
+;
my @pref_words = grep {$_ ne $word} @{$prefix{$prefix}};
my @suff_words = grep {$_ ne $word} @{$suffix{$suffix}};
next unless @pref_words && @suff_words;
say $prefix, ".", $suffix;
say " PREFIX $prefix: @pref_words";
say " SUFFIX $suffix: @suff_words";
}
}
Sample output:
woznia.cki
PREFIX woznia: wozniak
SUFFIX cki: lisicki
zh.ou
PREFIX zh: zhang zhao zharkova zheng zhong
SUFFIX ou: daniilidou fafaliou georgatou gerasimou
zho.u
PREFIX zho: zhong
SUFFIX u: anghelescu begu buzarnescu cadantu daniilidou dulgheru faf
+aliou georgatou gerasimou hincu hisamatsu hsu liu lu mitu nedelcu nic
+ulescu olaru perianu qiu radu senoglu shimizu stancu tigu vaideanu xu
+ yu
and the full output eek. There's an awfull lot of it (>200K) for the full list of players
Timings (full run):
real 0m0.266s
user 0m0.256s
sys 0m0.012s