.......... 0000000000 .......c.. 0000000200 .lauze.o.. 0211110100 .e.....a.. 0100000100 .g.....r.. 0200000100 baronies.. 1533553100 .t.....e.. 0200000100 .e.....r.. 0100000200 .......... 0000000000 .......... 0000000000 #### #!/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$/ } @dictwords; 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 =~ /(?[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 //, $same; } 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; } #### 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