|
in reply to Re^4: Inputing vectors into a scrabble-esque game
in thread Inputing vectors into a scrabble-esque game
I see non-words here. I'll save the vertical space for responders:
What I fail to see is a check that all words formed by adding tiles are kosher in both directions. It is the ability to do it in all 3 dimensions which separates the women from the men and their computter scripts now. I've added a bunch of (ugly) say statements in to proof the logic.
same is ]
score values are arpeggio. 123312230 arpeggios
--------------------chosen: 0 56 arpeggios score: 18
..a....... 0020000000
..j....... 0040000000
..i....... 0030000000
..v....... 0030000000
..a....... 0020000000
.arpeggios 0123312231
.......... 0000000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
all is c e f o t y y a e g i j o p r s v
moves: 10 tiles: c e f o t y y
in order is a?c?e?e?f?g?i?j?o?o?p?r?s?t?v?y?y?
array is 0 ..a.......
array is 11 ..j.......
...
array is 0 ..a..
array is 1 .a...
in order is a?c?e?e?f?g?i?j?o?o?p?r?s?t?v?y?y?
array is 11 .....a....
...
array is 33 .....p
array is 34 ....p.
inside if clause, changed is 7
same is MAZW K
score values are ....p. 000030 cotype
--------------------chosen: 1 34 cotype score: 8
..a....... 0020000000
..jc...... 0041000000
..io...... 0031000000
..vt...... 0031000000
..ay...... 0021000000
.arpeggios 0123312231
...e...... 0001000000
.......... 0000000000
.......... 0000000000
.......... 0000000000
What we see here are non-words forming in the axis opposite to those in which the tiles are laid.
Current source. I included johngg's alternate way to form tile bag, if only because I like to run everyone's source when they post on one of my threads. I'm not insisting that it's The Right way to do it. I can always use practice with quote-like operators.
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11108138
use warnings;
use feature 'say';
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 $dict = 'c:\users\tblaz\documents\html_template_data\dict\enable1.t
+xt';
my $n1 = $n + 1;
my $board = ('.' x $n . "\n") x $n; #board represented as string
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($dict)->slurp;
path($filename)->spew(join "\n", @dictwords, '');
}
my @drawpile = shuffle + 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;
};
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";
say "word is $word";
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();
say "execution point 1; enter to continue";
my $prompt = <STDIN>;
while( @tiles )
{
$heights =~ tr/5// == $n ** 2 and last; # ??
my @best; # [ flip, pos, pat, old, highs, word ]
my @all = (@tiles, ' ', sort +uniq $board =~ /\w/g);
say "all is @all";
$moves++;
print "moves: $moves tiles: @tiles\n";
my @subdict = grep /^[@all]+$/, @dictwords;
#say "subdict is @subdict";
for my $flip ( 0, 1 )
{
my $inorder = join '', map "$_?", sort "@all" =~ /\w/g;
say "in order is $inorder";
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 @array = @$_;
say "array is @array";
my $old = substr $board, $pos, length $pat;
my $highs = substr $heights, $pos, length $pat;
my @under = $old =~ /\w/g;
my $underpat = qr/[^@under@tiles]/;
#say "under pat is $underpat";
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 )
{
say "inside if clause, changed is $changed";
my ($flip, $pos, $pat, $old, $highs, $word) = @{ $best[-1] };
$flip and transpose();
my $usedtiles = '';
$usedtiles = $word;
my $same = $word ^ substr $board, $pos, length $word;
say "same is $same";
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) = @_;
say "score values are $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) = @_;
#say "in match rule";
$old eq $word and return 0; #old word cannot be identical
my $newmask = ($old ^ $word) =~ tr/\0/\xff/cr;
#say "new mask is $newmask";
($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;
}
__END__
Actually, I'll just hang on to my questions until I can frame them better. I wanted the prolific tybalt89 to see what remains yet to achieve in the core functionality.
Thanks for your interest,
|
Re^6: Inputing vectors into a scrabble-esque game
by tybalt89 (Monsignor) on Nov 04, 2019 at 23:50 UTC
|
#!/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 %isword = map +($_, 1), @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, $_ )
&& crosswords( $pos, $_ )
} @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 crosswords
{
my ($pos, $word) = @_;
my $tmpboard = '';
local $_ = $board;
substr($_, $pos, length $word) =~ tr//-/c;
$tmpboard .= "\n" while s/^./ $tmpboard .= $& ; '' /gem;
my @ch = split //, $word;
while( $tmpboard =~ /(\w*)-(\w*)/g )
{
my $check = $1 . shift(@ch) . $2;
length $check > 1 && ! $isword{ $check } and return 0;
}
return 1;
}
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;
}
| [reply]
[d/l] |
Re^6: Inputing vectors into a scrabble-esque game
by tybalt89 (Monsignor) on Nov 04, 2019 at 22:28 UTC
|
"all words formed by adding tiles are kosher in both directions."
A new rule I was not aware of...
Future posts may be coming (or not) ...
| [reply] |
|
|
A new rule I was not aware of...
Sorry about that. It's a hard game to understand without having manipulated the tiles onesself. I have to relearn the scoring everytime I do it. I called up the gal who has the game and asked her to read parts of the instructions. The part that I think is relevant is from "scoring."
"Two or more words can be formed." "They are each counted up separately, with the common tile stack being counted separately for each word."
These scores can be the whoppers.
| [reply] |
|
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11108138
use warnings;
use Path::Tiny;
use List::Util qw( shuffle uniq first sum );
$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
sub flip # transpose one of more grids
{
map
{
(local $_, my $flipped) = ($_, '');
$flipped .= "\n" while s/^./ $flipped .= $& ; '' /gem;
$flipped
} @_;
}
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 %isword = map +($_, 1), @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 "moves: 1 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";
my $pos = $n1 * ($n >> 1) + ($n - length($word) >> 1);
substr $board, $pos, length $word, $word;
substr $heights, $pos, 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 = 1;
my $totalscore = (length $word == $maxtiles) * 20 + 2 * length $word;
print '-' x 20, "chosen: 0 $pos $word score: $totalscore\n";
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 @words = grep {
length $pat == length $_
&& !/$underpat/
&& /^$pat$/
&& ( ($old ^ $_) !~ /^\0+\]$/ ) # adding just an 's' not allow
+ed
&& matchrule( $old, $highs, $_ )
&& crosswords( $pos, $_ )
} @subdict;
for my $word ( @words )
{
my $score = score( $board, $heights, $pos, $old, $word );
$score > $#best and $best[ $score ] //=
[ $flip, $pos, $pat, $old, $highs, $word, $score ];
}
}
($board, $heights) = flip $board, $heights;
}
if( $changed = @best )
{
my ($flip, $pos, $pat, $old, $highs, $word, $score) = @{ $best[-1]
+ };
my $newmask = ($old ^ $word) =~ tr/\0/\xff/cr;
$flip and ($board, $heights) = flip $board, $heights;
substr $board, $pos, length $word, $word;
substr $heights, $pos, length $highs,
($highs & $newmask) =~ tr/0-4/1-5/r | ($highs & ~$newmask);
$totalscore += $score;
$flip and ($board, $heights) = flip $board, $heights;
my $tiles = join '', @tiles;
$tiles =~ s/$_// for split //, $word & $newmask;
@tiles = split //, $tiles;
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";
# validate all words are in the dictionary
$isword{ $& } or die "$& is not a word\n" while $board =~ /\w{2,}/g;
$board = flip $board;
$isword{ $& } or die "$& is not a word\n" while $board =~ /\w{2,}/g;
sub crosswords
{
my ($pos, $word) = @_;
my $revboard = '';
local $_ = $board;
substr($_, $pos, length $word) =~ tr//-/c;
$revboard .= "\n" while s/^./ $revboard .= $& ; '' /gem;
my @ch = split //, $word;
while( $revboard =~ /(\w*)-(\w*)/g )
{
my $check = $1 . shift(@ch) . $2;
length $check > 1 && ! $isword{ $check } and return 0;
}
return 1;
}
sub score
{
my ($bd, $hi, $pos, $old, $word) = @_;
my $len = length $word;
my $mask = ( $old ^ $word ) =~ tr/\0/\xff/cr;
substr $bd, $pos, $len, ( $old & ~$mask ) =~ tr/\0/-/r;
my $highs = substr $hi, $pos, $len;
substr $hi, $pos, $len,
$highs = ( $highs & $mask ) =~ tr/0-4/1-5/r | ( $highs & ~$mask );
my $score = ($mask =~ tr/\xff// == $maxtiles) * 20 +
( $highs =~ /^1+$/ + 1 ) * sum split //, $highs;
my ($rbd, $rhi) = flip $bd, $hi;
my @ch = ($mask & $word) =~ /\w/g;
while( $rbd =~ /(\w*)-(\w*)/g ) # find each cross word of new tile
{
my $rpos = $-[0];
my $rword = $1 . shift(@ch) . $2;
length $rword > 1 or next;
$highs = substr $rhi, $rpos, length $rword;
$score += ( $highs =~ /^1+$/ + 1 ) * sum split //, $highs;
}
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 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;
}
| [reply]
[d/l] |
|
|
|
|
|
|
