Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Re^6: Inputing vectors into a scrabble-esque game

by tybalt89 (Prior)
on Nov 04, 2019 at 23:50 UTC ( #11108316=note: print w/replies, xml ) Need Help??


in reply to Re^5: Inputing vectors into a scrabble-esque game
in thread Inputing vectors into a scrabble-esque game

This has passed a couple of runs...

This was a fun little algorithm :)

#!/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; }

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://11108316]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (5)
As of 2020-11-27 07:15 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?