Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??

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; }

In reply to Re^10: Inputing vectors into a scrabble-esque game by tybalt89
in thread Inputing vectors into a scrabble-esque game by Aldebaran

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others cooling their heels in the Monastery: (6)
    As of 2021-01-22 23:08 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Notices?