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; } |
|
---|
Back to
Code Catacombs