Updated: to comply with all the revised rules.
Here's cleaner version of the above that also deals with (all?) of the edge cases.
#! perl -slw
use strict;
sub uniq { my %x; @x{@_} = (); keys %x }
my $len = shift @ARGV;
my $re ;
my $re_ex;
my $cap = 1;
my $cap_ex = 1;
my $hints_uniq;
for my $i ( 0 .. $#ARGV ) {
my( $word, $common ) = split ':', $ARGV[ $i ];
my $uniq = join'', uniq( split '', $word );
$hints_uniq .= $uniq;
if( $common <= length $word ) {
$re_ex .= "\n\t(?= (?: .*? (?: [^$uniq] | (?: ([$uniq])(?=
+ .* \\"
. $cap_ex++
. ") ) ) ){"
. ( $len - $common )
. "} )"
}
if( $common >= 2 ) {
$re .= "\n\t(?=.*?([$word]).*?(?!\\$cap)";
if( $common > 2 ) {
my $base = $cap;
for my $n ( 1 .. $common-2 ) {
$re .= "([$word]).*?(?!"
. join('|', map{ '\\' . $_ } $base .. ++$cap )
. ")";
}
}
$cap++;
$re .= "[$word])";
}
elsif( $common == 1 ) {
$re .= "\n\t(?=.*[$word].*)"
}
}
$hints_uniq = join '', uniq split'', $hints_uniq;
my $re_covered = qr[^[$hints_uniq]+$];
$re = qr[^$re]x;
$re_ex = qr[$re_ex]x;
my %w;
open W, '<', 'words' or die $!;
m[^[a-z]+$] and push @{ $w{ length() } }, $_
while chomp( $_ = <W>||'' );
close W;
my @m = grep{ $_ =~ $re_covered and $_ =~ $re_ex and $_ =~ $re } @{ $
+w{ $len } };
print ~~@m;
print for @m;
Examine what is said, not who speaks.
Silence betokens consent.
Love the truth but pardon error.