Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

Ghost (wordgame)

by m_turner (Sexton)
on Oct 28, 2000 at 08:37 UTC ( #38906=sourcecode: print w/ replies, xml ) Need Help??

Category: Fun Stuff
Author/Contact Info m_turner
Description: A variant simple word game described on Everything2

The essence of the game is that players take turns adding letters to the begining or end of a group of letters. Winning is accomplished by either causing the other person to form part of a not-word, or create a complete word. It is a simple matter of programing to alter the heuristics to play the game as specified.

I do admit that the heurstics could probably be improved several times.

#!/usr/bin/perl -w

use strict;
my @words;
my $dict     = '/usr/dict/words';
my @letters  = ( 'a' .. 'z');
my $minlen   = 4;

#           0         1      2       3     4      5    6     7   8    
+ 9   10  11  12
my @h = ( 10000000, -90000, 10000, -9000, 1000, -900, 500, -400, 100, 
+-90, 10, -9, 1);

open(DICT,"< $dict") or die "Can't open /usr/dict/words: $!\n";
@words = map { chomp; tr/A-Z0-9.,' -/a-z/d; (length($_) >= $minlen)?$_
+:() } <DICT>;
close(DICT);

my $word = '';
my $wordtest = '^\w$';  # the RE of the vaild next words

while(<>)
{
    chomp;
    tr/A-Z/a-z/;

    if(not $_ =~ /$wordtest/)
    {
        print "Invalid character.  Target: '$word'\n";
        next;
    }

    $word = $_;
    @words = grep /$word/i, @words;
    if(scalar @words == 0)
    {
        print "'$word' is not part of any word.  You loose.\n";
        last;
    }

    if(is_exact($word))
    {
       print "'$word' is exactly matched.  You win.  Game over.\n";
        last;
    }

    print "Player:\t\t$word\n";

    $word = do_computer($word,\@words);

    print "Computer:\t$word\n";

    if(is_exact($word))
    {
        print "'$word' is exactly matched.  You loose. Game over\n";
        last;
    }

    $wordtest = "^\\w$word\$|^$word\\w\$";
}

exit;

sub is_exact
{
    my ($word) = @_;
    return scalar (grep /^$word$/, @words);
}

sub do_computer
{
    my ($word,$words) = @_;
    my @words = @$words;
    my %prechars;
    my %postchars;
    my $h;
    my @list;
    my @pres;
    my @posts;
    my $re;
    my $char;

# first off, see what characters are available
    foreach (@words)
    {
        m/(.)$word/;
        if(defined $1 and $1 ne '') { $prechars{$1} = 0; }
        m/$word(.)/;
        if(defined $a and $1 ne '') { $postchars{$1} = 0; }
        $postchars{$1} = 0;
    }
# now, we've got a list of all the good chars
# so we now need to find the best character to choose.
# what is best?
#   even number left to target word
    foreach $char (keys %prechars)
    {
        $h = 0;
        $re = qr/$char$word/;
        @list = grep s/$re//, @words;
        foreach (@list) { $h += length($_); }
        $prechars{$char} = $h;
    }
    foreach $char (keys %postchars)
    {
    {
        $h = 0;
        $re = qr/$word$char/;
        @list = grep s/$re//, @words;
        foreach (@list) { $h += length($_); }
        $postchars{$char} = $h;
    }
    @pres  = sort { $prechars{$b}  <=> $prechars{$a}  } keys %prechars
+;
    @posts = sort { $postchars{$b} <=> $postchars{$a} } keys %postchar
+s;
    if($prechars{$pres[0]} > $postchars{$posts[0]})
      { $word = $pres[0] . $word; }
    else
      { $word = $word . $posts[0]; }
    return $word;
}

Comment on Ghost (wordgame)
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (5)
As of 2015-07-05 18:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (67 votes), past polls