#! perl -slw use strict; sub uniq { my %x; @x{@_} = (); keys %x } my $len = shift @ARGV; my $re = '^'; my $c = 0; for my $i ( 0 .. $#ARGV ) { my( $word, $common ) = split ':', $ARGV[ $i ]; die "Bad arg '$ARGV[ $i ]'" unless $common >= 2 and $common <= length( $word ); my $uniq = join'', uniq( split '', $word ); $re .= "(?=(?:.*?[^$uniq]){${ \ ($len - $common) }})"; $c++; $re .= "(?=.*?([$word]).*?(?!\\$c)"; $re .= "([$word]).*?(?!" . join( '|', map{ "\\${ \ $c++ }" } 0 .. $common-2 ) . ')' and --$c if $common > 2; $re .= "[$word])"; } $re .= '.' x $len . '$'; $re = qr[$re]; my %w; open W, '<', 'words' or die $!; m[^[a-z]+$] and push @{ $w{ length() } }, $_ while chomp( $_ = ||'' ); close W; my @m = grep{ $_ =~ $re } @{ $w{ $len } }; print ~~@m; print for @m; __END__ P:\test>421692-1 5 bumps:2 seams:2 domes:3 shake:3 pokes:3 dukes:3 1 house