I'm sure there's a better Perl scrabble cheater already in existence, but I enjoyed the exercise. The "requirement" I sought to satisfy is that given a word already on the scrabble board and a tray of letters one can use to augment the word, return a list of all words from a standard dictionary that can be formed from the given word using only one or more letters from the tray added to the beginning and/or end of the given word.
This code is minimally tested, but looks good to me. It also seems a good candidate for encapsulation in a module with a thorough test file. There are also a few enhancements one can imagine, e.g., listing the candidate words found along with their scrabble scores and in order sorted by score/alpha. I think this code will work under Perl version 5.8.9, but I haven't tested it with this version. The dictionary I used for testing is not an "official"
scrabble dictionary, but a general dictionary I had on hand.
use strict;
use warnings;
use autodie;
use List::Util qw(max);
use Getopt::Std qw(getopts);
# use Data::Dump qw(dd); # for debug
# word-per-line dictionary.
use constant DICTIONARY => 'C:/@Work/moby/mwords/354984si.ngl';
MAIN: {
# process command line switches.
my %option = (qw(g led t ooidgkle), 'd', DICTIONARY); # switches, d
+efaults
getopts('g:t:', \%option) or die 'failed processing switches';
my $given = # given (lowercase) letters to be augmented from tray
lc $option{'g'} # -g given letters ('led' default)
;
my $tray = # tray of (lowercase) letters to use to augment given lett
+ers
lc $option{'t'} # -t tray letters ('ooidgkle' default)
;
# validate given and tray strings.
m{ ([[:^alpha:]]+) }xms and die "non-alpha '$1' in '$_'" for $given, $
+tray;
# count frequency of each letter in the tray.
my %tray_count;
$tray_count{$_}++ for split //, $tray;
# critical min/max word lengths.
my $min_len = length($given) + 1; # must add something to given lette
+rs
my $max_len = length($given) + length($tray);
# read word-per-line dictionary, return as reference to single string.
my $sr_dict = slurp_dictionary($option{'d'});
# process dictionary words for possible words to play.
my @hits;
WORD:
while ($$sr_dict =~ m{ ^ ([\Q$tray\E]*) \Q$given\E ([\Q$tray\E]*) $ }x
+msg) {
my ($word_len, $pre_given, $post_given) = ($+[2]-$-[1], $1, $2);
# print "$word_len '$pre_given' '$post_given' \n"; next WORD; # fo
+r debug
# skip word if too short or long.
next WORD if $word_len < $min_len || $word_len > $max_len;
# skip word unless pre- and post-given letters are only from tray.
next WORD unless in_tray($pre_given, $post_given, %tray_count);
# save pieces of acceptable word.
push @hits, [ $pre_given, $given, $post_given ];
}
# pretty-print acceptable words from dictionary.
print "given: '$given' \n";
print "tray: '$tray' \n";
my $pre_dent = max map length($_->[0]), @hits; # pretty indentation
printf "%*s%s%s \n", $pre_dent, $_->[0], uc $_->[1], $_->[2] for @hits
+;
exit; # expected exit from MAIN and application
} # end MAIN block
die "unexpected exit from application";
# subroutines ######################################################
# return true only if pre- and post-given letters are all from tray.
sub in_tray {
my ($before_given, # letters before given text
$after_given, # letters after given text
%tray_count, # count of characters in tray (shallow copy ok
+)
) = @_;
# seems to work
# fail if any letter in tray is used up.
for my $s ($before_given, $after_given) {
--$tray_count{ substr $s, $_, 1 } < 0 && return for 0 .. lengt
+h($s)-1;
}
# # seems to work
# # fail if any letter in tray is used up.
# for my $char (map split(//), $before_given, $after_given) {
# return if --$tray_count{$char} < 0;
# }
# # seems to work
# # fail if any letter in tray is used up.
# for my $char (map unpack('(a)*', $_), $before_given, $after_given)
+ {
# return if --$tray_count{$char} < 0;
# }
return 1; # success -- all letters in tray
}
# read entire word-per-line dictionary, return as reference to single
+string.
sub slurp_dictionary {
my ($dictionary_file, # required: dictionary full/path/filename
) = @_;
open my $fh_dict, '<', $dictionary_file;
# slurp as single string with embedded newlines.
my $dict = do { local $/; <$fh_dict>; };
# printf "+++ |%s| ... |%s| \n", substr($dict, 0, 30), substr($dict,
+ -30); # for debug
close $fh_dict;
return \$dict; # return as scalar/string reference
}