Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

Scrabbler

by dcpve (Sexton)
on Jul 12, 2002 at 17:14 UTC ( #181348=sourcecode: print w/ replies, xml ) Need Help??

Category: Fun Stuff
Author/Contact Info Collin Winter aka dcpve
d_cove@hotmail.com
Description: Finds suitable Scrabble words based on your current tiles, the tiles on the board that are available for word building, and how many of your current tiles you are willing to omit to form a word.
#!/usr/bin/perl -w
#scrabbler.pl - A program to find suitable words while playing Scrabbl
+e
#By Collin Winter d_cove@hotmail.com
#
#Options:
#    -f : Means that this is the first turn.
#         This will skip the request for base letters (see below),
#         since there will be none.

use strict;

#Replace /usr/share/dict/linux.words with the path to the words file o
+n your system.
open WORDLIST, "/usr/share/dict/linux.words" or die "Unable to open wo
+rd list: $!\n";
my @wordlist=<WORDLIST>;
close WORDLIST;

#Find out what letters the player has, and make a hash of their freque
+ncy
print "Your letters: ";
chomp(my $master_letters=<STDIN>);

#Removes any non-alphacharacters that may have been used to separate t
+he letters;
$master_letters=~s/[^A-Za-z]//g;

my $base_letters;
my %letter_freq;
#If this is the first turn of the game, then there be no base letters 
+to use, so we need to obtain one
if($ARGV[0] eq '-f'){
    $base_letters=substr($master_letters,0,1);
    $master_letters=substr($master_letters,1,length($master_letters)-1
+);
}

for (split(//,$master_letters)){
    $letter_freq{$_}++;
}

#"Base letters" are tiles that are already out on the board and availa
+ble for to build words on.
#One base letter will be added at a time to $letters, and valid words 
+looked up for that combination.
if(!$ARGV[0] || $ARGV[0] ne '-f'){
    print "Base letters: ";
    chomp($base_letters=<STDIN>);
    $base_letters=~s/[^A-Za-z]//g;
}

#"Initial omission level" is the number of characters from $letters th
+at maybe left out of a word.
#A value of 0 will return only words that contain all of the character
+s in $letters.
#Setting it to 1 will return all words that contain every letter and a
+ll words with all letters except one, etc
print "Initial omission level: ";
chomp(my $master_om_level=<STDIN>);

my @possible_words;
my @valid_words;

foreach my $base (split(//,$base_letters)){
    my $om_level=$master_om_level;

    #Add the current base letter to the string and to the letter frequ
+ency hash
    my $letters=$master_letters.$base;

    $letter_freq{$base}++;
    my $do_it_again=1;

    #Repeat the word-evaluation until a word is found.
    while($do_it_again==1){
        
        #This is done like it is so that $max_length and $min_length c
+an be modified later.
        my $max_length=length($letters)+1;
        my $min_length=length($letters)-$om_level+1;
        
        #Thanks to mt2k for suggesting this kind of for loop.
        for my $i ($min_length .. $max_length){
            push(@possible_words,grep(length($_)==$i,@wordlist));
        }
        
        foreach my $word (@possible_words){
            my %this_freq=%letter_freq;
            my $this_word=$word;
            my $key_count=0;
            my $remaining_oms=$om_level;
        
            #Repeat until either:
            # a) there are no more letters to check for,
            # b) all keys in %letter_freq have been used, or
            # c) the word has too many omissions to be used.
            while((length($this_word)>1) && ($key_count<=(scalar keys 
+%letter_freq)-1) && ($remaining_oms>=0)){
                my $key=(keys %letter_freq)[$key_count];
        
                #If the current letter isn't in the word, then
                #There is one less omission remaining for this word.
                if($this_word!~/$key/i){
                    $remaining_oms--;
                }
        
                if(($this_freq{$key} > 0) && ($this_word=~/$key/i)){
            
                    if($this_word!~/$key/i){
                        $this_freq{$key}--;
                    }
            
                    while($this_freq{$key}>0){    
                        $this_freq{$key}--;
                        $this_word=~s/$key//i;
                    }
                }
                $key_count++;
            }
            
            if(length($this_word)==1){
                push(@valid_words,$word);
            }
        }
        
        #If no words are found at your current omission level, the sea
+rch
        #will be automatically enlarged until at least one word is ret
+urned.
        print $#valid_words+1," results with $om_level allowed omissio
+ns for base \'$base\'";
        
        if(!$valid_words[0]){
            @possible_words=();
            print "; Expanding search...\n";
            $om_level++;
            $max_length=$min_length--;
        }
        if($valid_words[0]){
            print ":\n",@valid_words;
            @valid_words=();
            $do_it_again=0;
        }
    }

    #Remove the current base from the letter frequency hash
    $letter_freq{$base}--;
}
exit;

Comment on Scrabbler
Download Code
Re: Scrabbler
by sschneid (Deacon) on Jul 12, 2002 at 18:01 UTC
    nice! useful! dishonest! ++.
      how do I use this codes? it's in perl?
Re: Scrabbler
by jdavidboyd (Friar) on Jul 12, 2002 at 18:36 UTC
    I like it, but I think my family would disapprove of my having a computer next to me when we play!
      That's the downside; you can really only use this with online scrabble games, like Yahoo!s Literati.

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (9)
As of 2014-08-28 11:40 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (259 votes), past polls