I'm a little dumbfounded that this much progress got made this quickly...wow.... I'll show sample output and then list source.
C:\Users\tblaz\Documents\evelyn>perl 1.up.pl
tiles: a b c r s s t
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
..bracts.. 0011111100
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 1 tiles: a b c r s s t
--------------------chosen: 0 57 brassart
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
..brassart 0011122211
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 2 tiles: a a b c d e t
--------------------chosen: 0 57 cadastre
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
..cadastre 0022232312
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 3 tiles: b i r u v w w
--------------------chosen: 1 34 urbia
.......... 0000000000
...u...... 0001000000
...r...... 0001000000
...b...... 0001000000
...i...... 0001000000
..cadastre 0022232312
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 4 tiles: a f n p v w w
--------------------chosen: 1 33 purana
...p...... 0001000000
...u...... 0001000000
...r...... 0001000000
...a...... 0002000000
...n...... 0002000000
..cadastre 0022232312
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 5 tiles: e f o t v w w
--------------------chosen: 1 33 furane
...f...... 0002000000
...u...... 0001000000
...r...... 0001000000
...a...... 0002000000
...n...... 0002000000
..cedastre 0023232312
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 6 tiles: k n o t v w w
--------------------chosen: 0 11 knout
...f...... 0002000000
knout..... 1111100000
...r...... 0001000000
...a...... 0002000000
...n...... 0002000000
..cedastre 0023232312
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 7 tiles: e e f l v w w
--------------------chosen: 0 25 reflew
...f...... 0002000000
knout..... 1111100000
...reflew. 0001111110
...a...... 0002000000
...n...... 0002000000
..cedastre 0023232312
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
moves: 8 tiles: e g i l u v w
C:\Users\tblaz\Documents\evelyn>
Source:
#!/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.1101.$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('c:\users\tblaz\documents\html_template_data\dict\enable1.txt
+')->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;
}
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....