Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

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

by tybalt89 (Prior)
on Nov 09, 2019 at 18:56 UTC ( #11108516=note: print w/replies, xml ) Need Help??


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

Here's a multiplayer version of the game. Put players names as arguments on the command line. Ending the game on "player out of tiles" or "all players pass" is now implemented, as well as deducting points for unused tiles. Players running score is shown after the score for the play.

$totalscore was put in out of curiosity. It's gone now.

#!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11108138 multiplayer upwo +rds 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 @ARGV or @ARGV = qw( one two three four ); # for testing 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 ; @ARGV * $maxtiles > @drawpile and die "too many players for tiles\n"; my @players; my $maxname = ''; for ( @ARGV ) { $maxname |= $_; push @players, { name => $_, score => 0, tiles => [ sort splice @drawpile, 0, $maxtiles ] }; } my $printf = '%' . length($maxname) . "s score: %3d tiles: %s\n"; my $current = 0; my $who = $players[$current]{name}; my @tiles = @{ $players[$current]{tiles} }; my $passes = 0; print "$who 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 $score = (length $word == $maxtiles) * 20 + 2 * length $word; print '-' x 20, "$who plays: 0 $pos $word score: $score\n"; printboard(); $players[$current]{tiles} = [ @tiles ]; $players[$current]{score} = $score; while( 1 ) { $current = ($current + 1) % @players; $who = $players[$current]{name}; @tiles = sort @{ $players[$current]{tiles} }; @tiles or last; $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 "$who 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 ]; } } ($board, $heights) = flip $board, $heights; } if( $changed = @best ) { my ($flip, $pos, $pat, $old, $highs, $word) = @{ $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); $flip and ($board, $heights) = flip $board, $heights; my $tiles = join '', @tiles; $tiles =~ s/$_// for split //, $word & $newmask; @tiles = split //, $tiles; my $total = $players[$current]{score} += $#best; print '-' x 20, "$who choses: $flip $pos $word score: $#best $t +otal\n"; push @chosen, $word; $passes = 0; } elsif( @drawpile ) { my $tiles = join '', @tiles; # discard random tile $tiles =~ s/$_// and last for 'q', 'z', $tiles[rand @tiles]; @tiles = split //, $tiles; print "$who discards and draws a new tile\n"; } else { print "$who passes\n"; if( ++$passes >= @players ) { print "All players pass so the game is ended.\n"; last; } } @tiles = sort @tiles, splice @drawpile, 0, $maxtiles - @tiles; $changed and printboard(); $players[$current]{tiles} = [ @tiles ]; @tiles or @drawpile or last; } print "\n\nchosen words: @chosen\n\n"; for ( @players ) { $who = $_->{name}; $tiles = $_->{tiles}; $score = $_->{score} - 5 * @$tiles; printf $printf, $who, $score, "@$tiles"; } # 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; }

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (10)
As of 2020-11-24 12:30 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?