#! perl -slw
use strict;

my @words = sort{
    length($a) <=> length($b)
} do{ local @ARGV = 'words.txt'; <> };
chomp @words;

my $start = time;

my $all = join ' ', @words;
study $all;

my @offsets;
for my $l ( 1 .. 20 ) {
    push @offsets,
        $all =~ m[ ([^ ]{$l}) ] ? $-[0] : $offsets[-1];
}

for my $i ( @words ) {
    while( 
        substr( $all, $offsets[ length( $i ) +1 ] ) 
            =~ m[ ([^ ]*$i[^ ]*) ]g 
    ) {
        my $j = $1;
        next
            if $j eq $i
            or $j eq "${i}s"
            or $j eq "${i}'s";
        print $i;
        last;    
    }
}

printf STDERR "Took %d seconds for %d words\n",
    time() - $start, scalar @words;