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

Aldebaran has asked for the wisdom of the Perl Monks concerning the following question:

Inputing vectors into a scrabble-esque game

In a recent thread, using perl to find words for scrabble, we did a survey of what exists and what would be a good continuation. I've had time to replicate what I could get working of the commentors, in particular those who posted source. I was anything but specific about the specification, and with the quality of the responses, I think we can cobble together an application that a) is usable on one's phone, and b) simple enough to use in the context of an actual game. The home run ball is a game that can actually incorporate the logic of the rules and calculate values acccording to this variation that I shall specify. Yet it has to start with something. So let's call that the front end. I'd like that to be the next focus.

The game I'm writing for is called Upwords. I don't think it is well-known. Here are the rules of the game. What might distinguish this variant is that tiles stack up to five high. Let me trot out some source, so as to motivate what I'm asking for. I won't attribute every line to original author. In this one, I have a bit that pryrt and tybalt89 posted in the above thread referenced. We're gonna have to adapt most of it anyways.

use 5.011;
use Path::Tiny;

my $n = 10;
my @board = map{ [('.') x $n]  } 0..($n-1);

print "Empty board:\n";

foreach my $row(@board){
    foreach my $col( @$row ){
        print $col;    
    }
    print "\n";
}
use List::Util qw( shuffle );

my @letters = split //, 'aaaaaaaaabbccddddeeeeeeeeeeeeffgggghhiiiiiiii
+ijkllllmmnnnnnnooooooooppqrrrrrrssssttttttuuuuvvwwxyyz';
my @tiles = ( shuffle @letters )[0 .. 6];
print "tiles: @tiles\n";
my $pattern = join '', map "$_?", sort @tiles;

my @matches = grep join('', sort split //) =~ /^$pattern$/,
  grep /^[@tiles]{2,}\z/ && /[aeiouy]/,        # lc, size & vowel
  path('c:\users\tblaz\documents\html_template_data\dict\enable1.txt')
+->lines({chomp => 1});
print "\nmatches:\n\n@matches\n";


__END__

[download]

Typical output:

Microsoft Windows [Version 10.0.17763.805]
(c) 2018 Microsoft Corporation. All rights reserved.

C:\Users\tblaz\Documents\evelyn>perl 3.letters.pl
Empty board:
..........
..........
..........
..........
..........
..........
..........
..........
..........
..........
tiles: m l i r p g m

matches:

gimp gip girl glim grim grip imp li limp lip mi mig mil mim mir pi pig
+ prig prim rig rim rip

C:\Users\tblaz\Documents\evelyn>

[download]

What a lucky draw, because this shows how narrow the logic of the game can be as opposed to the way we regard words. The grep line as tybalt89 wrote it is:

grep /^[@tiles]{2,}\z/ && /[aeiouy]/,        # lc, size & vowel

This game has no requirement of a vowel, so 'mm' is taken as a word and does not show in the list of @matches. Obviously, this means removing the && condition.

The empty board could be represented as rows and columns of empty dots, but an array is not gonna have a means to specify its height, so we would have to have something more like what Disciplus suggested:

my @board;
foreach my $row(0..14){
    foreach my $col( 0..14 ){
        $board[$row][$col] = { letter => '.', lett_mod => 1, word_mod 
+=> 1};    
    }
}

[download]

But the whole thing does not get off the ground unless I have some means to input into this data container in real time on my phone. Games::Literati has useful parts, but without some type of front end, using the command line and a text editor is much too burdensome on a phone.

It seems to me that the best way to specify a vector in two-space like this to use alphanumerics, like unto the game battleship. Rows are letters and columns are numbers. while it is appealing to stick a colon in between to signify range, the colon is not a good symbol to input for a phone, because it requires either a shift or another screen entirely. So while it might be visually better to have a2:a6, a2 a6is all that STDIN needs to understand the range.

My question is how do I use STDIN to specify a range and then come back to me and ask me to input a word, which it checks for appropriate length, kosherness as a word, (is kosherness a word?), deposits it into a Disciplus-style array of hashes, and eventually, calculates the value of all the words thus formed?

Thanks in advance,

Replies are listed 'Best First'.
Re: Inputing vectors into a scrabble-esque game
by GrandFather (Saint) on Oct 31, 2019 at 00:12 UTC

    For purposes of maintenance and code validation the @letter initialization code may be better written:

    my @letters =
    ('a') x 9, ('b') x 2, ('c') x 2, ('d') x 4, ('e') x 12, ('f') x 2,
    ('g') x 4, ('h') x 2, ('i') x 9, ('j') x 1, ('k') x 1, ('l') x 4, 
+('m') x 2,
    ('n') x 6, ('o') x 8, ('p') x 2, ('q') x 1, ('r') x 6, ('s') x 4, 
+('t') x 6,
    ('u') x 4, ('v') x 2, ('w') x 2, ('x') x 1, ('y') x 2, ('z') x 1;

    [download]

    and of course you should always use strictures.

    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
[reply]
[d/l]

      Perhaps you can save some fiddly typing map'ing the product of two source arrays to produce the @letters array. It doesn't look quite as straightforward but might be less prone to typos.

      use 5.026;
use warnings;

my @letters = do {
   my @chars   = ( q{a} .. q{z} );
   my @counts  = (
      9, 2, 2, 4, 12, 2, 4, 2, 9, 1, 1, 4, 2,
      6, 8, 2, 1, 6, 4, 6, 4, 2, 2, 1, 2, 1 );
   map { ( $chars[ $_ ] ) x $counts[ $_ ] } 0 .. 25;
   };

say join q{}, @letters;

      [download]

      Produces:-

      aaaaaaaaabbccddddeeeeeeeeeeeeffgggghhiiiiiiiiijkllllmmnnnnnnoooooooopp
+qrrrrrrssssttttttuuuuvvwwxyyz

      [download]

      I hope this is of interest.

      Cheers,

      JohnGG

[reply]
[d/l]
[select]

        But way less verifiable with a quick look. Keystrokes are much less important than understanding. The long winded suggestion I made is easy to understand even if you don't speak Perl and is easy to check. Anything that breaks the obvious one to one visual mapping between the letter and its repeat count is a step backwards for maintainability and easy understanding.

        Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond
[reply]
Re: Inputing vectors into a scrabble-esque game
by bliako (Monsignor) on Oct 30, 2019 at 23:12 UTC

    If that's one more act in the battle of the sexes (oh the most iconic of the palindromes!), I will gladly give my 2 bits to achieve balance:

    How about you have the phone take a picture of the board, reconstruct the board in memory, find best move for you? And optionally looking ahead and minimising the score of your opponent's next move.

    I have looked briefly at your previously-related post, its answers and the link provided to an older thread for scrabble, but I could not see a function which searches for words in dictionary when some of its letters are clamped on specific values. I.e. for those letters already set on the board squares where you plan to place your new word. So, can you start with a filter for the results of tybalt89's my $pattern = join '', map "$_?", sort @tiles; to make sure your candidate words have specific letters at specific positions?

    Then have another function which calculates the score of each candidate word taking into consideration what's already on board (i think appending to existing words gives you extra credit?). Would that be easier by having that function taking the board state as input, adds your candidate word in it and re-calculates the total board score? Subtracting this from initial score will be your word's score - more or less, right?

    bw, bliako

[reply]
[d/l]
      ... have the phone take a picture ...

      25 years ago, that sentence would not have made any sense at all. It's quite impressive how the prefered instrument for taking a snapshot has moved from a dedicated, perhaps analog camera to the camera embedded in a smartphone.

      Alexander

      --
      Today I will gladly share my knowledge and experience, for there are no sweeter words than "I told you so". ;-)
[reply]
      How about you have the phone take a picture of the board, reconstruct the board in memory, find best move for you? And optionally looking ahead and minimising the score of your opponent's next move.

      I would love to be able to use phone technology in such a manner. These might be my first tepid steps to coding for this device. I'm always glad to entertain asides and "what are we on the cusp of" discussions, provided that we're also addressing the main topic of the thread.

      but I could not see a function which searches for words in dictionary when some of its letters are clamped on specific values. I.e. for those letters already set on the board squares where you plan to place your new word.

      I have some ideas on how to deal with that clamping. Our algorithm would move bottom to top for possible placing of vertical vectors, and right to left if they are horizontal. I would think that that would create analogous logic for the two cases. You either have to place your tiles vertically, or horizontally, but never both.

      So, can you start with a filter for the results of tybalt89's my $pattern = join '', map "$_?", sort @tiles; to make sure your candidate words have specific letters at specific positions?

      The resulting string is simply the tiles with a question mark as padding. I didn't find that useful for this version.

      Then have another function which calculates the score of each candidate word taking into consideration what's already on board (i think appending to existing words gives you extra credit?). Would that be easier by having that function taking the board state as input, adds your candidate word in it and re-calculates the total board score? Subtracting this from initial score will be your word's score - more or less, right?

      I've started with a calculation function and "gotten on the proverbial board." Let me trot out some output then source next:

      Read more... (5 kB)

      Questions:

      Q1) How do I print the board by showing the letter value in the hash stored at each array location?

      As I'm looking at what I have, I realize what I want for the board. It's to have the column numbers displayed in the first row and the row letters displayed in the first column. We could put a character in the corner like a black square. Thus, the array of hashes will be 11x11, but the values will no longer be zero indexed in a way that needs to be accounted for.

      Q2) How do I best create these arrays?

      Q3 How am I getting greater than 7! = 5040 values from the uniq call on 7 tiles?

      Q4) How to I take the best word that %found has and insert it into the array of hashes at, say, the sixth row beginning at the third column and going right? We are guaranteed to have enough room for the first word. It is the only one that can be played without touching the previous graph at some point. (no floaters after the first one).

      Thanks for your comments

[reply]
[d/l]
Re: Inputing vectors into a scrabble-esque game
by tybalt89 (Monsignor) on Nov 01, 2019 at 19:28 UTC

    Here's some (incomplete) code that (sort of) plays upwords. What's missing is any scoring or score keeping.

    I use a simple string for the board, and another string for the height of each cell.
    Example board and example heights: 

    ..........   0000000000
.......c..   0000000200
.lauze.o..   0211110100
.e.....a..   0100000100
.g.....r..   0200000100
baronies..   1533553100
.t.....e..   0200000100
.e.....r..   0100000200
..........   0000000000
..........   0000000000

    [download]

    Using a string enables me to "fairly" easily find all the locations where a new word could go using a regex.
    Since words can be either left-right or top-down I go through the core of finding words twice, once normally, and the second time with the those two strings transposed(flipped around the major axis) to get the best (longest) word to play.

    Other than scoring, I think I've got most of the rules followed correctly.
    The program continues to play until it runs out of tiles, or (if you play smaller versions, like 4x4) the height string is all 5's. 

    #!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11108138
use warnings;
use Path::Tiny;
use List::Util qw( shuffle uniq first );
$SIG{__WARN__} = sub { die @_ };

my $n = 10;
my $maxtiles = 7;
my $upwords = 1; # 0 => extending(normal scrabble?)  1 => upwords

my $n1 = $n + 1;
my $board = ('.' x $n . "\n") x $n;
my $heights = $board =~ tr/./0/r;
my @dictwords;
my $filename = "words.11108138.$n"; # for caching
if( -f $filename )
  {
  @dictwords = split /\n/, path($filename)->slurp;
  }
else
  {
  @dictwords = sort { length $b <=> length $a }
    grep /^[a-z]{2,$n}$/,
    path('/usr/share/dict/words')->lines({chomp => 1});
  path($filename)->spew(map "$_\n", @dictwords);
  }

my @drawpile = shuffle + #  thanks to GrandFather 11108145
  ('a') x 9, ('b') x 2, ('c') x 2, ('d') x 4, ('e') x 12, ('f') x 2,
  ('g') x 4, ('h') x 2, ('i') x 9, ('j') x 1, ('k') x 1, ('l') x 4, ('
+m') x 2,
  ('n') x 6, ('o') x 8, ('p') x 2, ('q') x 1, ('r') x 6, ('s') x 4, ('
+t') x 6,
  ('u') x 4, ('v') x 2, ('w') x 2, ('x') x 1, ('y') x 2, ('z') x 1 ;
my @tiles = sort splice @drawpile, 0, $maxtiles;
print "tiles: @tiles\n";
my $pat = join '', map "$_?", @tiles;

my $word = first
  { /^[@tiles]+$/ and (join '', sort split //) =~ /^$pat$/ } @dictword
+s;
substr $board, $n1 * ($n >> 1) + ($n - length($word) >> 1),
  length $word, $word;
substr $heights, $n1 * ($n >> 1) + ($n - length($word) >> 1),
  length $word, ($upwords ? 1 : 5) x length $word;
my @chosen = $word;
my $changed = 1;
my $moves = 0;
my $b = $board =~ tr/\n/-/r;
$b =~ s/-/   $_/ for $heights =~ /.*\n/g;
print $b;

while( @tiles )
  {
  $upwords or $board =~ /\./ or last;
  $upwords && $heights =~ tr/0-4// == 0 and last;
  my @best; # [ flip, pos, pat, word ]
  my @all = (@tiles, ' ', sort +uniq $board =~ /\w/g);
  $moves++;
  print "moves: $moves  tiles: @tiles\n";
  my @subdict = grep /^[@all]+$/, @dictwords;
  for my $flip ( 0, 1 )
    {
    my $inorder = join '', map "$_?", sort "@all" =~ /\w/g;
    my $orderpat = qr/^$inorder$/;

    my @pat;
    $board =~ /(?<!\w).{2,}(?!\w)(?{
      push @pat, [ $flip, $-[0], $& ]
      })(*FAIL)/;
    $upwords and @pat = map expand($_), @pat;
    @pat = grep $_->[2] =~ /\w/, @pat;
    $upwords or
      @pat = grep { substr( $board, $_->[1], length $_->[2]) =~ /\./ }
+ @pat;

    for my $p ( @pat )
      {
      my ($flip, $pos, $pat) = @$p;
      my @under = substr( $board, $pos, length $pat) =~ /\w/g;
      my $w = first { /^[@under@tiles]+$/
        && /^$pat$/
        && (join '', sort /\w/g ) =~ /$orderpat/
        && ( /s$/ ? $pat ne s/s$/./r : 1 )
        && ( $upwords ? matchrule( $pos, $_ ) : 1 )
        } @subdict;
      $w and $best[ length $w ] //= [ $flip, $pos, $pat, $w ];
      }
    transpose();
    }
  if( $changed = @best )
    {
    my ($flip, $pos, $pat, $word) = @{ $best[-1] };
    $flip and transpose();
    if( $upwords )
      {
      my $same = $word ^ substr $board, $pos, length $word;
      my $tmppos = $pos;
      substr( $heights, $tmppos++, 1 ) += $_ ne "\0" for split //, $sa
+me;
      }
    else
      {
      substr($heights, $pos, length $word) =~ tr/0/5/;
      }
    substr $board, $pos, length $word, $word;
    print '-' x 20, "chosen: $flip $pos $word\n";
    push @chosen, $word;
    $flip and transpose();
    my $tmpword = $word;
    $tmpword =~ s/$_// for $pat =~ /\w/g;
    my $tiles = join '', @tiles;
    $tiles =~ s/$_// for split //, $tmpword;
    @tiles = split //, $tiles;
    }
  else
    {
    splice @tiles, rand @tiles, 1; # discard random tile
    }
  @tiles = sort @tiles, splice @drawpile, 0, $maxtiles - @tiles;
  if( $changed )
    {
    my $b = $board =~ tr/\n/-/r;
    $b =~ s/-/   $_/ for $heights =~ /.*\n/g;
    print $b;
    }
  }
print "\nchosen words: @chosen\n";

sub matchrule
  {
  my ($pos, $word) = @_;
  my $tiles = join '', @tiles;
  my $bd = substr $board, $pos, length $word;
  my $count = substr $heights, $pos, length $word;
  $bd eq $word and return 0;
  for ( reverse split //, $word )
    {
    my $bchar = chop $bd;
    my $stack = chop $count;
    $_ eq $bchar and next;
    $stack >= 5 and return 0;
    $tiles =~ s/$_// or return 0;
    }
  return 1;
  }

sub transpose
  {
  local $_ = $board;
  $board = '';
  $board .= "\n" while s/^./ $board .= $& ; '' /gem;
  local $_ = $heights;
  $heights = '';
  $heights .= "\n" while s/^./ $heights .= $& ; '' /gem;
  }

sub expand
  {
  my @ans;
  my ($flip, $pos, $pat) = @{ shift() };
  push @ans, [ $flip, $pos, $` =~ tr//./cr . $& . $' =~ tr//./cr ]
    while $pat =~ /\w/g;
  return @ans;
  }

    [download]

    And here's a sample partial output: 

    moves: 9  tiles: c g j l n q x
--------------------chosen: 1 78 coarsen
..........   0000000000
.......c..   0000000200
.gauze.o..   0111110100
.e.....a..   0100000100
.l.....r..   0100000100
baronies..   1533553100
.d.....e..   0100000100
.......n..   0000000100
..........   0000000000
..........   0000000000
moves: 10  tiles: g j l q r t x
--------------------chosen: 1 78 coarser
..........   0000000000
.......c..   0000000200
.gauze.o..   0111110100
.e.....a..   0100000100
.l.....r..   0100000100
baronies..   1533553100
.d.....e..   0100000100
.......r..   0000000200
..........   0000000000
..........   0000000000
moves: 11  tiles: e g j l q t x
--------------------chosen: 1 13 legate
..........   0000000000
.......c..   0000000200
.lauze.o..   0211110100
.e.....a..   0100000100
.g.....r..   0200000100
baronies..   1533553100
.t.....e..   0200000100
.e.....r..   0100000200
..........   0000000000
..........   0000000000

    [download]

    Lots of little interesting problems in this game. It was fun, thanks.

[reply]
[d/l]
[select]

      I'm a little dumbfounded that this much progress got made this quickly...wow.... I'll show sample output and then list source.

      Read more... (8 kB)
      Lots of little interesting problems in this game. It was fun, thanks.

      You bet. I think I'm going to get an extra physical game for myself.

      I'm gonna need some time just to catch up to all this....

[reply]
[d/l]
[select]

        Fixed a bug allowing adding an 's' to existing word. Also tweaked some algorithms,

        It now picks highest scoring move (instead of longest word). I think it now follows all the rules from the wikipedia page except the one about the "Qu" tile. 

        #!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11108138
use warnings;
use Path::Tiny;
use List::Util qw( shuffle uniq first );
$SIG{__WARN__} = sub { die @_ };

my $n = 10;            # configuration  board will be  $n by $n
my $maxtiles = 7;
my $dictionaryfile = '/usr/share/dict/words';
my $cachefilename = "words.11108138.$n"; # for caching subsets of dict
+ionary

my $n1 = $n + 1;
my $board = ('.' x $n . "\n") x $n;
my $heights = $board =~ tr/./0/r;
my @dictwords;
if( -f $cachefilename )
  {
  @dictwords = split /\n/, path($cachefilename)->slurp;
  }
else
  {
  print "caching words of max length $n\n";
  @dictwords = sort { length $b <=> length $a }
    grep /^[a-z]{2,$n}$/,
    split /\n/, path($dictionaryfile)->slurp;
  path($cachefilename)->spew(join "\n", @dictwords, '');
  }

my @drawpile = shuffle + #  thanks to GrandFather 11108145
  ('a') x 9, ('b') x 2, ('c') x 2, ('d') x 4, ('e') x 12, ('f') x 2,
  ('g') x 4, ('h') x 2, ('i') x 9, ('j') x 1, ('k') x 1, ('l') x 4, ('
+m') x 2,
  ('n') x 6, ('o') x 8, ('p') x 2, ('q') x 1, ('r') x 6, ('s') x 4, ('
+t') x 6,
  ('u') x 4, ('v') x 2, ('w') x 2, ('x') x 1, ('y') x 2, ('z') x 1 ;
my @tiles = sort splice @drawpile, 0, $maxtiles;
print "tiles: @tiles\n";
my $pat = join '', map "$_?", @tiles;

my $word = first
  { /^[@tiles]+$/ and (join '', sort split //) =~ /^$pat$/ } @dictword
+s;
$word or die "no starting word can be found\n";
substr $board, $n1 * ($n >> 1) + ($n - length($word) >> 1),
  length $word, $word;
substr $heights, $n1 * ($n >> 1) + ($n - length($word) >> 1),
  length $word, 1 x length $word;
my $tiles = join '', @tiles;
$tiles =~ s/$_// for split //, $word;
@tiles = split //, $tiles;
push @tiles, splice @drawpile, 0, $maxtiles - @tiles;
my @chosen = $word;
my $changed = 1;
my $moves = 0;
my $totalscore = 2 * length $word;
printboard();

while( @tiles )
  {
  $heights =~ tr/5// == $n ** 2 and last; # all 5, no more play possib
+le
  my @best; # [ flip, pos, pat, old, highs, word ]
  my @all = (@tiles, ' ', sort +uniq $board =~ /\w/g);
  $moves++;
  print "moves: $moves  tiles: @tiles\n";
  my @subdict = grep /^[@all]+$/, @dictwords;
  for my $flip ( 0, 1 )
    {
    my @pat;
    $board =~ /(?<!\w).{2,}(?!\w)(?{ push @pat, [ $-[0], $& ] })(*FAIL
+)/;
    @pat = map expand($_), @pat;
    @pat = sort { length $b->[1] <=> length $a->[1] } @pat;

    for ( @pat )
      {
      my ($pos, $pat) = @$_;
      my $old = substr $board, $pos, length $pat;
      my $highs = substr $heights, $pos, length $pat;
      my @under = $old =~ /\w/g;
      my $underpat = qr/[^@under@tiles]/;
      my @w = grep {
        length $pat == length $_
        && !/$underpat/
        && /^$pat$/
        && ( ($old ^ $_) !~ /^\0+\]$/ ) # adding just an 's' not allow
+ed
        && matchrule( $old, $highs, $_ )
        } @subdict;
      $best[ score($old, $highs, $_) ] //=
        [ $flip, $pos, $pat, $old, $highs, $_ ] for @w;
      }
    transpose();
    }
  if( $changed = @best )
    {
    my ($flip, $pos, $pat, $old, $highs, $word) = @{ $best[-1] };
    my $newmask = ($old ^ $word) =~ tr/\0/\xff/cr;
    $flip and transpose();
    substr $board, $pos, length $word, $word;
    substr $heights, $pos, length $highs,
      ($highs & $newmask) =~ tr/0-5/1-6/r | ($highs & ~$newmask);
    $flip and transpose();
    my $tiles = join '', @tiles;
    $tiles =~ s/$_// for split //, $word & $newmask;
    @tiles = split //, $tiles;
    $totalscore += my $score = score( $old, $highs, $word );
    print '-' x 20, "chosen: $flip $pos $word   score: $score\n";
    push @chosen, $word;
    }
  else
    {
    my $tiles = join '', @tiles; # discard random tile
    $tiles =~ s/$_// and last for 'q', 'z', $tiles[rand @tiles];
    @tiles = split //, $tiles;
    }
  @tiles = sort @tiles, splice @drawpile, 0, $maxtiles - @tiles;
  $changed and printboard();
  }
print "\nchosen words: @chosen\ntotalscore: $totalscore\n";

sub score
  {
  my ($old, $highs, $word) = @_;
  my $score = ($old ^ $word) =~ tr/\0//c == $maxtiles ? 20 : 0;
  $score += chop($highs) + (chop($old) ne $_) for reverse split //, $w
+ord;
  $score == length $word and $score *= 2; # no stacked letters
  return $score;
  }

sub printboard
  {
  my $bd = $board =~ tr/\n/-/r;
  $bd =~ s/-/   $_/ for $heights =~ /.*\n/g;
  print $bd;
  }

sub matchrule
  {
  my ($old, $highs, $word) = @_;
  $old eq $word and return 0;
  my $newmask = ($old ^ $word) =~ tr/\0/\xff/cr;
  ($newmask & $highs) =~ tr/5// and return 0;
  my $tiles = "@tiles";
  $tiles =~ s/$_// or return 0 for ($newmask & $word) =~ /\w/g;
  return 1;
  }

sub transpose # both board and heights arrays
  {
  local $_ = $board;
  $board = '';
  $board .= "\n" while s/^./ $board .= $& ; '' /gem;
  $_ = $heights;
  $heights = '';
  $heights .= "\n" while s/^./ $heights .= $& ; '' /gem;
  }

sub expand # change patterns with several letters to several single le
+tter pats
  {
  my @ans;
  my ($pos, $pat) = @{ shift() };
  push @ans, [ $pos, $` =~ tr//./cr . $& . $' =~ tr//./cr ]
    while $pat =~ /\w/g;
  return @ans;
  }

        [download]
[reply]
[d/l]

        I found and fixed a bug in tile handling, and also removed the option to play normal scrabble (it was adding too much noise). Also cleaned up some parts, including a major streamlining to 'matchrule'. 

        #!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11108138
use warnings;
use Path::Tiny;
use List::Util qw( shuffle uniq first );
$SIG{__WARN__} = sub { die @_ };

my $n = 10;            # configuration  board will be  $n by $n
my $maxtiles = 7;

my $n1 = $n + 1;
my $board = ('.' x $n . "\n") x $n;
my $heights = $board =~ tr/./0/r;
my @dictwords;
my $filename = "words.11108138.$n"; # for caching
if( -f $filename )
  {
  @dictwords = split /\n/, path($filename)->slurp;
  }
else
  {
  print "caching words of length $n\n";
  @dictwords = sort { length $b <=> length $a }
    grep /^[a-z]{2,$n}$/,
    split /\n/, path('/usr/share/dict/words')->slurp;
  path($filename)->spew(join "\n", @dictwords, '');
  }

my @drawpile = shuffle + #  thanks to GrandFather 11108145
  ('a') x 9, ('b') x 2, ('c') x 2, ('d') x 4, ('e') x 12, ('f') x 2,
  ('g') x 4, ('h') x 2, ('i') x 9, ('j') x 1, ('k') x 1, ('l') x 4, ('
+m') x 2,
  ('n') x 6, ('o') x 8, ('p') x 2, ('q') x 1, ('r') x 6, ('s') x 4, ('
+t') x 6,
  ('u') x 4, ('v') x 2, ('w') x 2, ('x') x 1, ('y') x 2, ('z') x 1 ;
my @tiles = sort splice @drawpile, 0, $maxtiles;
print "tiles: @tiles\n";
my $pat = join '', map "$_?", @tiles;

my $word = first
  { /^[@tiles]+$/ and (join '', sort split //) =~ /^$pat$/ } @dictword
+s;
$word or die "no starting word can be found\n";
substr $board, $n1 * ($n >> 1) + ($n - length($word) >> 1),
  length $word, $word;
substr $heights, $n1 * ($n >> 1) + ($n - length($word) >> 1),
  length $word, 1 x length $word;
my @chosen = $word;
my $changed = 1;
my $moves = 0;
my $totalscore = 2 * length $word;
printboard();

while( @tiles )
  {
  $heights =~ tr/5// == $n ** 2 and last; # all 5, no more play possib
+le
  my @best; # [ flip, pos, pat, old, highs, word ]
  my @all = (@tiles, ' ', sort +uniq $board =~ /\w/g);
  $moves++;
  print "moves: $moves  tiles: @tiles\n";
  my @subdict = grep /^[@all]+$/, @dictwords;
  for my $flip ( 0, 1 )
    {
    my $inorder = join '', map "$_?", sort "@all" =~ /\w/g;
    my $orderpat = qr/^$inorder$/;

    my @pat;
    $board =~ /(?<!\w).{2,}(?!\w)(?{ push @pat, [ $-[0], $& ] })(*FAIL
+)/;
    @pat = map expand($_), @pat;
    @pat = sort { length $b->[1] <=> length $a->[1] } @pat;

    for ( @pat )
      {
      my ($pos, $pat) = @$_;
      my $old = substr $board, $pos, length $pat;
      my $highs = substr $heights, $pos, length $pat;
      my @under = $old =~ /\w/g;
      my $underpat = qr/[^@under@tiles]/;
      my $w = first {
        length $pat == length $_
        && !/$underpat/
        && /^$pat$/
        && ( /s$/ ? $pat ne s/s$/./r : 1 )
        && matchrule( $old, $highs, $_ )
        } @subdict;
      $w and $best[ length $w ] //=
        [ $flip, $pos, $pat, $old, $highs, $w ], last;
      }
    transpose();
    }
  if( $changed = @best )
    {
    my ($flip, $pos, $pat, $old, $highs, $word) = @{ $best[-1] };
    $flip and transpose();
    my $usedtiles = '';
    $usedtiles = $word;
    my $same = $word ^ substr $board, $pos, length $word;
    my $tmppos = $pos;
    for ( split //, $same )
      {
      if( $_ ne "\0" )
        {
        substr( $heights, $tmppos, 1 ) =~ tr/0-4/1-5/; # new tile, add
+ 1
        }
      else
        {
        $usedtiles =~ s/$_// for substr $board, $tmppos, 1;
        }
      $tmppos++;
      }
    substr $board, $pos, length $word, $word;
    $totalscore += my $score = score( $old, $highs, $word );
    print '-' x 20, "chosen: $flip $pos $word   score: $score\n";
    push @chosen, $word;
    $flip and transpose();
    my $tiles = join '', @tiles;
    $tiles =~ s/$_// for split //, $usedtiles;
    @tiles = split //, $tiles;
    }
  else
    {
    splice @tiles, rand @tiles, 1; # discard random tile
    }
  @tiles = sort @tiles, splice @drawpile, 0, $maxtiles - @tiles;
  $changed and printboard();
  }
print "\nchosen words: @chosen\ntotalscore: $totalscore\n";

sub score
  {
  my ($old, $high, $word) = @_;
  my $score = ($old ^ $word) =~ tr/\0//c == $maxtiles ? 20 : 0;
  $score += chop($high) + (chop($old) ne $_) for reverse split //, $wo
+rd;
  $score == length $word and $score *= 2; # no stacked letters
  return $score;
  }

sub printboard
  {
  my $bd = $board =~ tr/\n/-/r;
  $bd =~ s/-/   $_/ for $heights =~ /.*\n/g;
  print $bd;
  }

sub matchrule
  {
  my ($old, $highs, $word) = @_;
  $old eq $word and return 0;
  my $newmask = ($old ^ $word) =~ tr/\0/\xff/cr;
  ($newmask & $highs) =~ tr/5// and return 0;
  my $tiles = "@tiles";
  $tiles =~ s/$_// or return 0 for ($newmask & $word) =~ /\w/g;
  return 1;
  }

sub transpose # both board and heights arrays
  {
  local $_ = $board;
  $board = '';
  $board .= "\n" while s/^./ $board .= $& ; '' /gem;
  $_ = $heights;
  $heights = '';
  $heights .= "\n" while s/^./ $heights .= $& ; '' /gem;
  }

sub expand # change patterns with several letters to several single le
+tter pats
  {
  my @ans;
  my ($pos, $pat) = @{ shift() };
  push @ans, [ $pos, $` =~ tr//./cr . $& . $' =~ tr//./cr ]
    while $pat =~ /\w/g;
  return @ans;
  }

        [download]
[reply]
[d/l]
Re: Inputing vectors into a scrabble-esque game
by tybalt89 (Monsignor) on Nov 02, 2019 at 15:46 UTC

    For input, how about just entering a string consisting of

    a row digit of starting position of word
    a column digit ditto
    either a 'h' or a 'v' for whether the word is horizontal or vertical
    the word

    Example program: 

    #!/usr/bin/perl

use strict;
use warnings;

my $board = ('.' x 10 . "\n") x 10;
print "$board\n";

my $input = '23hacross'; # simulated read from STDIN
place($input);
print "$board\n";

$input = '16vdown'; # simulated read from STDIN
place($input);

print "$board\n";

sub place
  {
  my $input = shift;
  my ($row, $column, $direction, $word) = $input =~ /^(\d)(\d)(v|h)(.*
+)/;
  my $position = 11 * $row + $column;
  for ( split //, $word )
    {
    substr $board, $position, 1, $_;
    if( $direction eq 'h' ) 
      {
      $position++;
      }
    else
      {
      $position += 11;
      }
    }
  }

    [download]

    Outputs: 

    ..........
..........
..........
..........
..........
..........
..........
..........
..........
..........

..........
..........
...across.
..........
..........
..........
..........
..........
..........
..........

..........
......d...
...across.
......w...
......n...
..........
..........
..........
..........
..........

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

Back to Seekers of Perl Wisdom