Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

Crossword solver - 2 words

by fireartist (Chaplain)
on Jul 19, 2002 at 12:41 UTC ( #183206=sourcecode: print w/ replies, xml ) Need Help??

Category: Fun Stuff
Author/Contact Info fireartist
Description: Warning:- some may find this offensive ;)

If you have 2 incomplete, interesecting words in a crossword, this will list all possible combinations.
For example, with the 2 words below (marked by '?')
_ _ _ _ _ _ _ _ |_|_|_|_|_|_|_|_| |_|_|_|_|O|F|T|_| |_|C|_|_|_|?|_|_| |_|A|?|T|?|?|?|_| |_|T|_|O|_|?|_|_| |_|_|_|K|_|I|N|_| |_|_|F|E|E|D|_|_| |_|_|_|_|_|_|_|_|
The program will ask you these questions, to which you should give the marked answers.
How any letters does word 1 have? answer:6 What position does it meet word 2 at? answer:5 What is the 1st letter? Hit <RETURN> if you don't know. answer:a What is the 2nd letter? answer: What is the 3rd letter? answer:t What is the 4th letter? answer: What is the 6th letter? answer: How any letters does word 2 have? answer:6 What position does it meet word 1 at? answer:3 What is the 1st letter? Hit <RETURN> if you don't know. answer:f What is the 2nd letter? answer: What is the 3rd letter? answer: What is the 4th letter? answer: What is the 5th letter? answer:i What is the 6th letter? answer:d
You would then be returned the following list.
action florid actors forbid Altair frigid altars forbid alters forbid artery forbid Arturo forbid asters forbid attain frigid attire forbid author florid

update: added the following line
What is the 3rd letter? answer:
where it was missing above.
#!/usr/bin/perl -wT
use strict;

my $dictfile = '/usr/share/dict/linux.words';

use vars qw/$regex1 $regex2 @list1 @list2 $word1 $word2 @array $match 
+$expr/;
my $cols  = 2;
my $max   = -1;

$regex1 = &build_regex( '1' );
$regex2 = &build_regex( '2' );

open ( FILE1, "< $dictfile")
  or die("Could not open FILE1, $dictfile\n");

while (<FILE1>) {
  chomp;
  push @list1, $_;
}
close FILE1;

@list2 = @list1;

$expr = &build_expr( $regex1, $regex2 );
print "\nPlease wait a moment...\n";
eval $expr;

unless ($array[0]) {
    print "\n\nNo matches!\n";
    exit;
}

print "\n\nThe results are,\n\n";
$_ > $max && ($max = $_) for map {length} @array;
while (@array) {
    print join " " => map {sprintf "%-${max}s" => $_}
                           splice @array => 0, $cols;
    print "\n";
}
exit;

### SUBS

sub build_regex {
    my $this = shift;
    my ($regex, $total, $other, $position);
    my $count = 1;
    if ($this == 1) {
        $other = 2;
    }
    else {
        $other = 1;
    }
    
    print "\nHow any letters does word $this have?\n";
    $total = <STDIN>;
    chomp $total;
    unless ($total =~ /^([0-9]+)$/) {
        die("Incorrect input! - $total\n");
    }
    $total = $1;
    
    print "What position does it meet word $other at?\n";
    $position = <STDIN>;
    chomp $position;
    unless ($position =~ /^([0-9]+)$/) {
        die("Incorrect Input! - $position\n");
    }
    $position = $1;
    print "\n";
    
    while ($count <= $total) {
        if (($this == 1) && ($position == $count)) {
            $regex .= '(\w)';
        }
        elsif (($this == 2) && ($position == $count)) {
            $regex .= '${match}';
        }
        else {
            my $suffix = &build_suffix( $count );
            
            print "What is the ${count}${suffix} letter?\n";
            if ($count == 1) {
                print "Hit <RETURN> if you don't know.\n";
            }
            my $input = <STDIN>;
            chomp $input;
            unless (($input =~ /^([a-zA-Z])$/) | ($input =~ /^()$/)) {
                die("Incorrect input! - $input\n");
            }
            $input = $1;
            
            if ($input eq '') {
                $regex .= '\w';
            }
            else {
                $regex .= $input;
            }
        }
        
        $count ++;
    }
    
    return $regex;
}

sub build_suffix {
    my $number = shift;
    if ($number =~ /([0-9])$/) {
        $number = $1;
    }
    else {
        die("Could not build number suffix!\n");
    }
    
    if ($number == 1) {
        return 'st';
    }
    elsif ($number == 2) {
        return 'nd';
    }
    elsif ($number == 3) {
        return 'rd';
    }
    else {
        return 'th';
    }
}

sub build_expr {
    my $string1 = shift;
    my $string2 = shift;
    
    my $build = "
foreach \$word1 (\@list1) {
  if (\$word1 =~ /^$string1\$/i) {
      \$match = \$1;
    foreach \$word2 (\@list2) {
        if (\$word2 =~ /^$string2\$/i) {
            push \@array, \$word1;
            push \@array, \$word2;
        }
    }
  }
}";

    return $build;
}

Comment on Crossword solver - 2 words
Download Code
Re: Crossword solver - 2 words
by grantm (Parson) on Jul 19, 2002 at 13:30 UTC

    How's this for an alternative 'user interface':

    ./scriptname a?t?(?)? f?(?)?id
      Or just   ./scriptname 'a t () ' 'f () id'

        p

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://183206]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (5)
As of 2014-09-20 03:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (152 votes), past polls