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

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

by 1nickt (Canon)
on Nov 04, 2019 at 21:03 UTC ( [id://11108311]=note: print w/replies, xml ) Need Help??


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

Hrm, some of the words in the list look a bit funny/repeated?

--------------------chosen: 1 71 rove score: 8 ....du.... 0000120000 ..s.en.... 0010120000 mantal.... 4134550000 antimodel. 2212551210 ..r.at.... 0010150000 ..unttrrid 0033451511 ..p.ueo... 0010231000 ..i.rdv... 0010121000 ..clever.. 0011111100 .......... 0000000000 moves: 28 tiles: q chosen words: achira satrap benign watered satrapic ailuro injury untu +rgid untorrid isozooid unhoaxed defeater unhooted unpitted unpotted d +efeature antibody unlotted defeature wakeel defeature gantsl clever a +ntimodel santal mangal mantal rove totalscore: 544
?


The way forward always starts with a minimal test.

Replies are listed 'Best First'.
Re^5: Inputing vectors into a scrabble-esque game
by tybalt89 (Monsignor) on Nov 04, 2019 at 21:36 UTC

    funny - these words are all from /usr/share/dict/words from my ArchLinux system, blame them :)

    repeated - yep, this surprised me.
    There are several ways this can happen. Take 'food', put a 't' over the 'd' and get 'foot', next put a 'd' over the 't' and get 'food' again.
    Or put an opposite transpose word over some letter and then replace that letter in a subsequent move.
    I've seen 3 or 4 copies of the same word in some runs. I think I'm following the rules of Upwords, but I've never played the real game.

Re^5: Inputing vectors into a scrabble-esque game
by Aldebaran (Curate) on Nov 04, 2019 at 21:54 UTC

    I see non-words here. I'll save the vertical space for responders:

    Thanks for your interest,

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

      "all words formed by adding tiles are kosher in both directions."
      A new rule I was not aware of...

      Future posts may be coming (or not) ...

        A new rule I was not aware of...

        Sorry about that. It's a hard game to understand without having manipulated the tiles onesself. I have to relearn the scoring everytime I do it. I called up the gal who has the game and asked her to read parts of the instructions. The part that I think is relevant is from "scoring."

        "Two or more words can be formed." "They are each counted up separately, with the common tile stack being counted separately for each word."

        These scores can be the whoppers.

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others meditating upon the Monastery: (3)
As of 2024-03-29 07:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found