Calculates the highest score possible from the letters given, taking into account any bonuses on the squares to be covered.

(Rudimentary tool that does not handle combinations with the words already on the board).

My local newspaper has a Scrabble-based game that involves simply finding the highest scoring word from seven letters and bonus tile positions provided. Note: quite often the highest scoring word according to the newspaper is not found in my words list :-(

Specify double- and triple-word bonuses with -dw and -tw, and double- and triple-letter bonuses with -dl=N and -tl=N where N is the letter position.

Examples: 

$ perl scrabble.pl eoaprzn 
Found 13,699 1-7 letter strings in eoaprzn.
Found 57 words in eoaprzn.
zap : 14

$ perl scrabble.pl eoaprzn -dw
Found 13,699 1-7 letter strings in eoaprzn.
Found 57 words in eoaprzn.
zap : 28

$ perl scrabble.pl eoaprzn -tl=3
Found 13,699 1-7 letter strings in eoaprzn.
Found 57 words in eoaprzn.
raze : 33

[download]

use strict; use warnings; use feature 'say';
use Path::Tiny;
use Algorithm::Permute;
use Number::Format 'format_number';
use List::Util 'uniq';
use Getopt::Long;

my @dl;
my @tl;
my $dw;
my $tw;
my $debug;

GetOptions(
    'dl=i' => \@dl,
    'tl=i' => \@tl,
    'dw'   => \$dw,
    'tw'   => \$tw,
    'v'    => \$debug,
);

my $input       = shift or die 'Died: No input!';
my $length      = length $input;
my @input_chars = split '', $input;

my $words_file  = '/usr/share/dict/words';
my %words       = map { $_ => 1 } path( $words_file )->lines({chomp =>
+ 1});

my %worth = (
    a => 1, b => 3,  c => 3, d => 2, e => 1,
    f => 4, g => 2,  h => 4, i => 1, j => 8,
    k => 5, l => 1,  m => 3, n => 1, o => 1,
    p => 3, q => 10, r => 1, s => 1, t => 1,
    u => 1, v => 2,  w => 2, x => 8, y => 4, z => 10,
);

my @partials;

for (1 .. $length) {
    my $P = Algorithm::Permute->new( \@input_chars, $_ );
    
    while (my @res = $P->next) {
        push @partials, join '', @res;
    }
}

@partials = uniq @partials;

say sprintf 'Found %s 1-%s letter strings in %s.',
            format_number(scalar @partials), $length, $input;

my %found = map { $_ => calc_score($_) } grep { $words{$_} } @partials
+ ;

say sprintf 'Found %s words in %s.', format_number(scalar keys %found)
+, $input;

for ( sort { $found{$b} <=> $found{$a} } keys %found ) {
    say "$_ : $found{$_}";
    last if not $debug;
}

###############

sub calc_score {
    my $word = shift;
    my $val;
    $val += $worth{$_} for split '', $word;

    $val += 50 if length $word == 7;

    return $val + calc_bonus($word, $val);
}

sub calc_bonus {
    my ($word, $val) = @_;
    my @chars = split '', $word;

    my $bonus = 0;

    for (@dl) {
        $bonus += $worth{ $chars[$_ - 1] } if $chars[$_ - 1];
    }

    for (@tl) {
        $bonus += 2 * $worth{ $chars[$_ - 1] } if $chars[$_ - 1];
    }

    $bonus += $val if $dw;
    $bonus += 2 * $val if $tw;

    return $bonus;
}

__END__

[download]


Replies are listed 'Best First'.
Re: Cheat at Scrabble
by localshop (Monk) on Oct 21, 2018 at 17:50 UTC
    While the unix words file is probably cool enough .. I also came across this file on Stack Exchange in case the rules are required ( even if a couple years out of date )
[reply]
Re: Cheat at Scrabble
by jwkrahn (Abbot) on Oct 21, 2018 at 21:33 UTC

    Wouldn't it be simpler to just do: 

    
my %found;

for ( 1 .. $length ) {
    my $P = Algorithm::Permute->new( \@input_chars, $_ );
    
    while ( my @res = $P->next ) {
        my $word = join '', @res;
        $found{ $word } = calc_score( $word ) if exists $words{ $word 
+};
    }
}

    [download]

    And get rid of the @partials array altogether?

    Also, the calc_score and calc_bonus functions could be combined: 

    
sub calc_score {
    my @chars = split //, shift;

    my $val = 0;
    $val += $worth{ $_ } for @chars;

    $val += 50 if @chars == 7;

    my $bonus = 0;

    for ( @dl ) {
        $bonus += $worth{ $chars[ $_ - 1 ] } if $chars[ $_ - 1 ];
    }

    for ( @tl ) {
        $bonus += 2 * $worth{ $chars[ $_ - 1 ] } if $chars[ $_ - 1 ];
    }

    $bonus += $val if $dw;
    $bonus += 2 * $val if $tw;

    return $val + $bonus;
}

    [download]
[reply]
[d/l]
[select]
Re: Cheat at Scrabble
by pryrt (Abbot) on Oct 22, 2018 at 15:16 UTC

    Back in 2003, Chicheng Zhang released Games::Literati to handle Scrabble and the Yahoo!Games clone called "Literati". In 2016, I took over maintenance, and updated it to fix a couple of scoring bugs, and to handle Words With Friends (and Super Scrabble, which has a bigger board and more tiles). My guess is that the word-searching itself is not as efficient as it could be (I just kept CZ's search intact) -- and maybe not even as good as what you've shown -- but it does present another way of doing things.

[reply]
Re: Cheat at Scrabble
by bliako (Abbot) on Oct 22, 2018 at 09:21 UTC 
     is not found in my words list :-(

    For building your own list of words: download a lot of plain text files from Project Gutenberg (https://www.gutenberg.org/ebooks/42324) and make your own list of words. For example a word is valid if it exists in the work of at least 3 different authors.

    Parsing Gutenberg's plain texts might be a project on its own though, it's simple but a bit tedious to remove preambles and colofons, abbreviations etc.

[reply]
      Lots of good data here:

      www.dict.org/w/databases/start

[reply]
Re: Cheat at Scrabble
by tybalt89 (Monsignor) on Oct 22, 2018 at 14:42 UTC

    Fun little problem. thanks.

    In the spirit of TIMTOWTDI, here's a solution that does not use permutation or perl's sort. 

    #!/usr/bin/perl

# https://perlmonks.org/?node_id=1224403

use strict;
use warnings;
use Path::Tiny;
use List::Util 'sum';
use Getopt::Long;

GetOptions(
    'dl=i' => \my @dl,
    'tl=i' => \my @tl,
    'dw'   => \my $dw,
    'tw'   => \my $tw,
);

my %worth = (
    a => 1, b => 3,  c => 3, d => 2, e => 1,
    f => 4, g => 2,  h => 4, i => 1, j => 8,
    k => 5, l => 1,  m => 3, n => 1, o => 1,
    p => 3, q => 10, r => 1, s => 1, t => 1,
    u => 1, v => 2,  w => 2, x => 8, y => 4, z => 10,
);

my $input = shift // die "No Input!\n";
my $length = length $input;
my $pattern = qr/@{[ join '', map "$_?", sort split '', $input ]}/;
my @best;

push @{ $best[score($_)] }, $_ for my @legalwords =
  grep { length() <= $length and join('', sort split //) =~ /^$pattern
+$/ }
  path( '/usr/share/dict/words' )->lines({chomp => 1});

print <<END;
     input = $input
legalwords = @{[scalar @legalwords]}
best score = $#best
best words = @{ $best[-1] }
END

sub score
  {
  my @eachvalue = @worth{ my @chars = split //, shift };
  @eachvalue > $_ and $eachvalue[$_ - 1] *= 2 for @dl;
  @eachvalue > $_ and $eachvalue[$_ - 1] *= 3 for @tl;
  my $value = sum @eachvalue, @chars == 7 && 50;
  $value *= ($dw ? 2 : 1) * ($tw ? 3 : 1);
  }

    [download]

    outputs 

         input = eoaprzn
legalwords = 67
best score = 14
best words = zap

    [download]
[reply]
[d/l]
[select]

Back to Cool Uses for Perl