Re: Challenge: Mystery Word Puzzle

There are some fairly dubious coding practices in there, and I don't yet guarentee it solves every puzzle, but it does solve the (now removed) example.

I'll try test it a bit more and clean it up a bit.

#! 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( $_ = <W>||''
+ );
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
[download]

Examine what is said, not who speaks.

Silence betokens consent.

Love the truth but pardon error.

Comment on Re: Challenge: Mystery Word Puzzle Download Code

Replies are listed 'Best First'.

Re^2: Challenge: Mystery Word Puzzle
by BrowserUk (Patriarch) on Jan 12, 2005 at 23:21 UTC

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;
[download]

Examine what is said, not who speaks.

Silence betokens consent.

Love the truth but pardon error.

[reply]
[d/l]


Don't ask to ask, just ask
	PerlMonks