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; }
In reply to Re^3: Inputing vectors into a scrabble-esque game
by tybalt89
in thread Inputing vectors into a scrabble-esque game
by Aldebaran
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |