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, defaults 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 letters 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 letters 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]*) $ }xmsg) { my ($word_len, $pre_given, $post_given) = ($+[2]-$-[1], $1, $2); # print "$word_len '$pre_given' '$post_given' \n"; next WORD; # for 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 .. length($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 } #### 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