Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??

This post will mark the beginning of a third on this subject, with the first two having been more productive than I had anticipated. If you missed them and want to catch up, here is the first, using perl to find words for scrabble, and here is the second, Inputing vectors into a scrabble-esque game. I do have results, and just wanted to regroup, and restate the problem, informed now by output, a better-specified logic, and experience. I like to save the vertical space in my posts for respondents, so I'll continue for interested parties between readmore tags:

On windows 10, the one player script works well. Typical output:

,
C:\Users\tblaz\Documents\evelyn\to_phone>perl 8.board.pl moves: 1 tiles: a e g o r t u --------------------chosen: 0 56 outrage score: 34 .......... 0000000000 .......... 0000000000 .......... 0000000000 .......... 0000000000 .......... 0000000000 .outrage.. 0111111100 .......... 0000000000 .......... 0000000000 .......... 0000000000 .......... 0000000000 moves: 2 tiles: x w m u c n e --------------------chosen: 1 15 cowmen score: 12 .......... 0000000000 .......... 0000000000 .......... 0000000000 .......... 0000000000 .c........ 0100000000 .outrage.. 0111111100 .w........ 0100000000 .m........ 0100000000 .e........ 0100000000 .n........ 0100000000 ... moves: 13 tiles: a e e f j p r --------------------chosen: 0 77 eme score: 14 .......... 0000000000 ...u...... 0001000000 ...n...... 0001000000 ..owl..... 0011100000 .c.iota... 0101131000 .outraged. 0111111110 .w.sec.... 0101130000 eme..e.... 1110010000 regilt.... 1121210000 .nodi..... 0111100000 moves: 14 tiles: a a f j n p r --------------------chosen: 0 100 nona score: 13 .......... 0000000000 ...u...... 0001000000 ...n...... 0001000000 ..owl..... 0011100000 .c.iota... 0101131000 .outraged. 0111111110 .w.sec.... 0101130000 eme..e.... 1110010000 regilt.... 1121210000 .nona..... 0112200000 moves: 15 tiles: a d f j p r v --------------------chosen: 1 59 tared score: 26 ... --------------------chosen: 0 22 kern score: 10 .......... 0000000000 ..burp.... 0011110000 kern...... 1221000000 ..owl.f... 0011101000 .c.iota... 0101131000 .outraved. 0111112110 .w.sepal.. 0101151100 eme..e.o.. 1110010100 regild.i.. 1121220100 .nona..n.. 0112200100 moves: 22 tiles: e g i j o y z Terminating on signal SIGINT(2) C:\Users\tblaz\Documents\evelyn\to_phone>

The source that produced this is:

#!/usr/bin/perl use strict; use warnings; use feature 'say'; use Path::Tiny; use List::Util qw( shuffle uniq first sum ); my $n = 10; # configuration board will be $n by $n my $maxtiles = 7; my $dictionaryfile = path( "dict", 'enable1.txt' ); my $cachefilename = "words.11108138.$n"; # for caching subsets of +dictionary 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; say "dict words are @dictwords"; 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; sub flip # transpose one of more grids { map { ( local $_, my $flipped ) = ( $_, '' ); $flipped .= "\n" while s/^./ $flipped .= $& ; '' /gem; $flipped } @_; } my @tiles = sort splice @drawpile, 0, $maxtiles; print "moves: 1 tiles: @tiles\n"; my $pat = join '', map "$_?", @tiles; my $word = first { /^[@tiles]+$/ and ( join '', sort split // ) =~ /^$ +pat$/ } @dictwords; $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 $totalscore = ( length $word == $maxtiles ) * 20 + 2 * length $word +; print '-' x 20, "chosen: 0 $pos $word score: $totalscore\n"; printboard(); while (@tiles) { $heights =~ tr/5// == $n**2 and last; # all 5, no more play possib +le my @best; # [ flip, pos, pat, old, hig +hs, 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 @words = grep { length $pat == length $_ && !/$underpat/ && /^$pat$/ && ( ( $old ^ $_ ) !~ /^\0+\]$/ ) # adding just an 's' no +t allowed && 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, $score ]; } } ( $board, $heights ) = flip $board, $heights; } if ( $changed = @best ) { my ( $flip, $pos, $pat, $old, $highs, $word, $score ) = @{ $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 ); $totalscore += $score; $flip and ( $board, $heights ) = flip $board, $heights; my $tiles = join '', @tiles; $tiles =~ s/$_// for split //, $word & $newmask; @tiles = split //, $tiles; 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"; say "finishing\n"; # validate all words are in the dictionary $isword{$&} or die "$& is not a word\n" while $board =~ /\w{2,}/g; say "word is $&"; say "$board"; $board = flip $board; $isword{$&} or die "$& is not a word\n" while $board =~ /\w{2,}/g; say "word is $&"; say "$board"; 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 ti +le { 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 l +etter pats { my @ans; my ( $pos, $pat ) = @{ shift() }; push @ans, [ $pos, $` =~ tr//./cr . $& . $' =~ tr//./cr ] while $pat + =~ /\w/g; return @ans; }

While this script has many similarities to what tybalt89 posted in his responses, this one differs primarily in how the path to the dictionary is specified. It seems to me that I needed to have everything I wanted to deploy to termux in one directory. So I created a 'dict' directory, and put the dictionary there. As this script matures, I hope to pull the functions out into a package that could be put in the same directory, which makes the directory 'dict' non-descriptive.

Q1) If I'm going to have one and only one subdirectory, what makes for a good name? lib, my_data, ?

Meanwhile, this exact script and architecture do not successfully get off the mark on my linux machine:

$ lsb_release -a No LSB modules are available. Distributor ID: Ubuntu Description: Ubuntu 18.04.2 LTS Release: 18.04 Codename: bionic $ perl 8.board.pl moves: 1 tiles: a e e l o p w no starting word can be found $

If one looks at the output that I posted from the termux session, this is exactly what it does as well. What seems to happen is that @dictwords is populated only by the last item in the dictionary, which it cannot match, having two zz's. So that's a big head scratcher for me, which I'll state like this:

Q2) Why does this script show proper behavior on windows but bomb out on *nix systems?

Part of the questions I present with are about termux. I intend to use the same data to motivate a discussion on stack exchange for the less perly matters. my own opinion is that the topic of perl doesn't suffer much if the OT stuff doesn't go on and on. I will post a link to that discussion when that happens.

I did purchase a brand new game on amazon for 16 bucks. I do consider this a fair use, as I don't know how I could hustle money by becoming an Upwards shark. Here I scanned the rules.

Thanks for your comment,


In reply to implementing a scrabble-esque game on Termux III by Aldebaran

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



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others goofing around in the Monastery: (3)
As of 2024-04-26 02:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found