http://qs321.pair.com?node_id=11136520


in reply to Problem with regex wildcard operator (.)...?

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.

scrabble_cheater_3.pl:

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 }
Output:
Win8 Strawberry 5.30.3.1 (64) Tue 09/07/2021 6:24:31 C:\@Work\Perl\monks\Marshall >perl scrabble_cheater_3.pl given: 'led' tray: 'ooidgkle' deLED doiLED doLED dolLED gelLED gilLED gLED gLEDe idLED kilLED LEDe LEDge LEDged LEDol ogLED oiLED Win8 Strawberry 5.30.3.1 (64) Tue 09/07/2021 7:22:34 C:\@Work\Perl\monks\Marshall >perl scrabble_cheater_3.pl -g no -t wk given: 'no' tray: 'wk' kNOw NOw


Give a man a fish:  <%-{-{-{-<