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

What I fail to see is a check that all words formed by adding tiles are kosher in both directions. It is the ability to do it in all 3 dimensions which separates the women from the men and their computter scripts now. I've added a bunch of (ugly) say statements in to proof the logic.

same is ] score values are arpeggio. 123312230 arpeggios --------------------chosen: 0 56 arpeggios score: 18 ..a....... 0020000000 ..j....... 0040000000 ..i....... 0030000000 ..v....... 0030000000 ..a....... 0020000000 .arpeggios 0123312231 .......... 0000000000 .......... 0000000000 .......... 0000000000 .......... 0000000000 all is c e f o t y y a e g i j o p r s v moves: 10 tiles: c e f o t y y in order is a?c?e?e?f?g?i?j?o?o?p?r?s?t?v?y?y? array is 0 ..a....... array is 11 ..j....... ... array is 0 ..a.. array is 1 .a... in order is a?c?e?e?f?g?i?j?o?o?p?r?s?t?v?y?y? array is 11 .....a.... ... array is 33 .....p array is 34 ....p. inside if clause, changed is 7 same is MAZW K score values are ....p. 000030 cotype --------------------chosen: 1 34 cotype score: 8 ..a....... 0020000000 ..jc...... 0041000000 ..io...... 0031000000 ..vt...... 0031000000 ..ay...... 0021000000 .arpeggios 0123312231 ...e...... 0001000000 .......... 0000000000 .......... 0000000000 .......... 0000000000

What we see here are non-words forming in the axis opposite to those in which the tiles are laid.

Current source. I included johngg's alternate way to form tile bag, if only because I like to run everyone's source when they post on one of my threads. I'm not insisting that it's The Right way to do it. I can always use practice with quote-like operators.

#!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11108138 use warnings; use feature 'say'; 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 $dict = 'c:\users\tblaz\documents\html_template_data\dict\enable1.t +xt'; my $n1 = $n + 1; my $board = ('.' x $n . "\n") x $n; #board represented as string my $heights = $board =~ tr/./0/r; my @dictwords; my $filename = "words.11108138.$n"; # for caching if( -f $filename ) { @dictwords = split /\n/, path($filename)->slurp; } else { print "caching words of length $n\n"; @dictwords = sort { length $b <=> length $a } grep /^[a-z]{2,$n}$/, split /\n/, path($dict)->slurp; path($filename)->spew(join "\n", @dictwords, ''); } my @drawpile = shuffle + do { my @chars = ( q{a} .. q{z} ); my @counts = ( 9, 2, 2, 4, 12, 2, 4, 2, 9, 1, 1, 4, 2, 6, 8, 2, 1, 6, 4, 6, 4, 2, 2, 1, 2, 1 ); map { ( $chars[ $_ ] ) x $counts[ $_ ] } 0 .. 25; }; 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"; say "word is $word"; 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 @chosen = $word; my $changed = 1; my $moves = 0; my $totalscore = 2 * length $word; printboard(); say "execution point 1; enter to continue"; my $prompt = <STDIN>; while( @tiles ) { $heights =~ tr/5// == $n ** 2 and last; # ?? my @best; # [ flip, pos, pat, old, highs, word ] my @all = (@tiles, ' ', sort +uniq $board =~ /\w/g); say "all is @all"; $moves++; print "moves: $moves tiles: @tiles\n"; my @subdict = grep /^[@all]+$/, @dictwords; #say "subdict is @subdict"; for my $flip ( 0, 1 ) { my $inorder = join '', map "$_?", sort "@all" =~ /\w/g; say "in order is $inorder"; my $orderpat = qr/^$inorder$/; 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 @array = @$_; say "array is @array"; my $old = substr $board, $pos, length $pat; my $highs = substr $heights, $pos, length $pat; my @under = $old =~ /\w/g; my $underpat = qr/[^@under@tiles]/; #say "under pat is $underpat"; my $w = first { length $pat == length $_ && !/$underpat/ && /^$pat$/ && ( /s$/ ? $pat ne s/s$/./r : 1 ) && matchrule( $old, $highs, $_ ) } @subdict; $w and $best[ length $w ] //= [ $flip, $pos, $pat, $old, $highs, $w ], last; } transpose(); } if( $changed = @best ) { say "inside if clause, changed is $changed"; my ($flip, $pos, $pat, $old, $highs, $word) = @{ $best[-1] }; $flip and transpose(); my $usedtiles = ''; $usedtiles = $word; my $same = $word ^ substr $board, $pos, length $word; say "same is $same"; my $tmppos = $pos; for ( split //, $same ) { if( $_ ne "\0" ) { substr( $heights, $tmppos, 1 ) =~ tr/0-4/1-5/; # new tile, add + 1 } else { $usedtiles =~ s/$_// for substr $board, $tmppos, 1; } $tmppos++; } substr $board, $pos, length $word, $word; $totalscore += my $score = score( $old, $highs, $word ); print '-' x 20, "chosen: $flip $pos $word score: $score\n"; push @chosen, $word; $flip and transpose(); my $tiles = join '', @tiles; $tiles =~ s/$_// for split //, $usedtiles; @tiles = split //, $tiles; } else { splice @tiles, rand @tiles, 1; # discard random tile } @tiles = sort @tiles, splice @drawpile, 0, $maxtiles - @tiles; $changed and printboard(); } print "\nchosen words: @chosen\ntotalscore: $totalscore\n"; sub score { my ($old, $high, $word) = @_; say "score values are $old $high $word"; my $score = ($old ^ $word) =~ tr/\0//c == $maxtiles ? 20 : 0; $score += chop($high) + (chop($old) ne $_) for reverse split //, $wo +rd; $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) = @_; #say "in match rule"; $old eq $word and return 0; #old word cannot be identical my $newmask = ($old ^ $word) =~ tr/\0/\xff/cr; #say "new mask is $newmask"; ($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; } __END__

Actually, I'll just hang on to my questions until I can frame them better. I wanted the prolific tybalt89 to see what remains yet to achieve in the core functionality.

Thanks for your interest,


In reply to Re^5: Inputing vectors into a scrabble-esque game by Aldebaran
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, details, 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, summary, 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.