Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

A Word Game (Update 3)

by jwkrahn (Monsignor)
on Feb 09, 2022 at 05:09 UTC ( #11141265=CUFP: print w/replies, xml ) Need Help??

Yes I play this game every day on the web. I just wanted to see if I could do it.

There are probably still bugs!

Tested with xterm on Debian.

If this is a copyright violation please remove it.

Update

I think I've fixed the bugs pointed out by toolic. Let me know if you find any more.

Update number 2

I think that this now works correctly, but if you find any bugs please let me know. TIA

Update number 3

Thanks to toolic and wazoox for helping to find bugs. I hope that this fix is the last.     :)

#!/usr/bin/perl use warnings; use strict; use Term::ANSIColor ':constants'; my $clear = `clear`; my $reset = RESET; my $white_on_red = BRIGHT_WHITE . ON_RED; my $white_on_green = BRIGHT_WHITE . ON_GREEN; my $white_on_yellow = BRIGHT_WHITE . ON_YELLOW; my $white_on_gray = BRIGHT_WHITE . ON_BRIGHT_BLACK; my $divider = " --- --- --- --- ---\n"; my $kb = <<KB; Q W E R T Y U I O P A S D F G H J K L Z X C V B N M KB my @lines = ( [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], [ ( ' ' ) x 5 ], ); my $curr_line = 0; my %dict; { open my $FH, '<', '/usr/share/dict/words' or die "Cannot open '/us +r/share/dict/words' because: $!"; @dict{ map uc, grep /[aeiou]|.y./, map /^([a-z]{5})$/, <$FH> } = ( +); } my $curr_word = ( keys %dict )[ rand keys %dict ]; { local $| = 1; print $clear, " ${white_on_gray}Letter not used.$reset\n", " ${white_on_yellow}Letter is used.$reset\n", " ${white_on_green}Letter in correct place.$reset\n", " ${white_on_red}Not a valid word.$reset\n", "\n", map( { my $line = $_; $divider, ' ', map( " |$_|", @{ $lines[ +$line ] } ), "\n", $divider } 0 .. $#lines ), "\n\n", $kb, "\n"; if ( $curr_line == @lines ) { #print "\L$curr_word\n"; last; } print 'Enter five letter word: '; my ( $word ) = map uc, <STDIN> =~ /^([a-zA-Z]{5})/; my @letters = split //, $word; @letters == 5 or redo; # Not a valid five letter word unless ( exists $dict{ $word } ) { $lines[ $curr_line ] = [ map "$white_on_red $_ $reset", @lette +rs ]; redo; } # The correct answer if ( $word eq $curr_word ) { $lines[ $curr_line ] = [ map "$white_on_green $_ $reset", @let +ters ]; for my $letter ( @letters ) { $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_ +on_green $letter $reset/; } $curr_line = @lines; redo; } # Default; all letters to white on gray $lines[ $curr_line ] = [ map "$white_on_gray $_ $reset", @letters +]; for my $letter ( @letters ) { $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_on_g +ray $letter $reset/; } # Find exact matches my @found = ( 0 ) x 5; my $xor_word = $word ^ $curr_word; while ( $xor_word =~ /\0/g ) { $found[ $-[ 0 ] ] = 1; my $letter = $letters[ $-[ 0 ] ]; $lines[ $curr_line ][ $-[ 0 ] ] = "$white_on_green $letter $re +set"; $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_on_g +reen $letter $reset/; } my $curr_remains = join '', ( split //, $curr_word )[ grep !$found +[ $_ ], 0 .. $#found ]; # Find other correct letters for my $index ( 0 .. $#letters ) { next if $found[ $index ]; my $letter = $letters[ $index ]; if ( $curr_remains =~ s/$letter/ / ) { $lines[ $curr_line ][ $index ] = "$white_on_yellow $letter + $reset"; $kb =~ s/(?:\e\[\d+m\e\[\d+m)? $letter (?:\e\[0m)?/$white_ +on_yellow $letter $reset/; } } ++$curr_line; redo; }

Replies are listed 'Best First'.
Re: A Word Game
by Fletch (Bishop) on Feb 09, 2022 at 07:16 UTC

    Related an interesting dive attempting to automate (and optimize) playing and the information theory underneath.

    The cake is a lie.
    The cake is a lie.
    The cake is a lie.

Re: A Word Game
by toolic (Bishop) on Feb 09, 2022 at 22:55 UTC
    I think I see a minor bug.

    For example, if I hack the code to add the following line after the my $curr_word = ... line:

    $curr_word = 'QUOTE';
    this has the affect of forcing a specific word, just for debug. When I run it, and guess the word "emote", it displays:
    --- --- --- --- --- | E | | M | | O | | T | | E | --- --- --- --- ---
    "M" shows up as gray, and "OTE" shows up as green, as expected.

    However, the 1st "E" shows up as yellow. I interpret that to mean that the word should have 2 "E"'s. I expect the 1st "E" to be gray.

    If I guess the word "smote", it displays the "S" as gray, as expected. Therefore, I think there is a problem when the guess has 2 of the same letter.

    What do you think?

      I think you are right about the behavior and it's not the way I saw wordle handling this case.

      But the OP didn't want to infringe any copyrights anyway... ;-)

      update

      more explicitly;

      The code does

      1. # Find letters that are in the word
      2. # Find letters that are in the word and at the correct position
      it should be the other way round, and correct positions excluded previous to step 2

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      Wikisyntax for the Monastery

      Thank you for the feedback.

      Yes, this is the bug to which I eluded, but I am working on it.

        I tried the updated code, but I still get the same result. Did you test the code with QUOTE as the current word and EMOTE as the guess? Don't you see the 1st "E" as yellow?
Re: A Word Game
by toolic (Bishop) on Feb 09, 2022 at 20:16 UTC
    Thanks for this!

    I was unfortunate enough to randomly get a non-word from my /usr/share/dict/words file:

    fldxt
    I added a grep to only allow words with a vowel (or "y"):
    @dict{ map uc, grep /[aeiouy]/, map /^([a-z]{5})$/, <$FH> } = ();
    I found this out by adding an option to print the current word at the end:
    print "\n Answer = $curr_word\n" if @ARGV;
      > non-word

      It seems it is a word: fluid extract (used in Amercian prescriptions).

      map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
      > I added a grep to only allow words with a vowel (or "y"):

      since "j" is a variant of "i", I wouldn't be surprised if it was occasionally used as a vowel

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      Wikisyntax for the Monastery

        Not in English.

        What we do see is the use of 'j' in place of 'i' when that 'i' is functioning more like a consontantal 'y'. For example, eject from Latin eiectus

        "since "j" is a variant of "i", I wouldn't be surprised if it was occasionally used as a vowel"

        The word "fjord" springs to mind. I expect there are others.

        — Ken

Re: A Word Game
by LanX (Sage) on Feb 09, 2022 at 11:29 UTC
    > If this is a copyright violation please remove it.

    I would have guessed that Wordle is already infringing the patent of Mastermind. (almost same rules, just with letters from "real" words instead of colors).

    But it turns out that Mastermind is "inspired" by an old pen-and-paper game called Bulls and Cows

    So if you are worried just generalize the mechanisms slightly and add new dictionaries to create a "new" game.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

    ) For instance: I was thinking of adapting perlglossary, one would need a way to incorporate words of different length and starting position. :)

Re: A Word Game (my solution)
by jdporter (Chancellor) on Feb 15, 2022 at 14:41 UTC
    # given a wordle W and a guess G, calculate the result. package Wordle; use strict; use warnings; # returns a vector of match codes: 2=right/right; 1=right/wrong; 0=w +rong. sub guess { my( $wordl, $guess ) = @_; my @result=(0)x5; # first, look for the right/right: for my $i ( 0 .. 4 ) { if ( substr($wordl, $i, 1) eq substr($guess, $i, 1) ) { $result[$i] = 2; substr($wordl, $i, 1) = ' '; substr($guess, $i, 1) = ' '; } } $guess eq ' ' and return(5,0); # done # second, look for the right/wrong: for my $i ( 0 .. 4 ) { my $l = substr $guess, $i, 1; next if $l eq ' '; if ( $wordl =~ /$l/ ) { $result[$i] = 1; substr($wordl, $i, 1) = ' '; substr($guess, $i, 1) = ' '; } } @result } # returns a vector of counts ( right/right, right/wrong ) sub numeric_guess { my( $wordl, $guess ) = @_; # first, look for the right/right: my $right=0; for my $i ( reverse( 0 .. 4 ) ) { if ( ord(substr $wordl, $i, 1) eq ord(substr $guess, $i, 1) ) { $right++; substr($wordl, $i, 1) = ''; substr($guess, $i, 1) = ''; } } $right == 5 and return(5,0); # done # second, look for the right/wrong: my $wrong = 0; for my $l ( split '', $guess ) { $wordl =~ s/$l// and $wrong++; } join '', ($right, $wrong) } __PACKAGE__
Re: A Word Game (Updated)
by jdporter (Chancellor) on Feb 11, 2022 at 14:25 UTC

    Has anyone found the dictionary Josh W uses? He must have one, for when determining whether a guess is a "valid word". I asked him by email; have not gotten a response.

      I suppose it's loaded with the JS. There is no network traffic while playing.

      update

      check the array Oa with its 10600 entries, please note that the solutions from Ma are not included.

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      Wikisyntax for the Monastery

      PS: I'm wondering how long the NY-Times will need to shut down the commercial copycats.

        Thank you so much!

        Now I'm just sad that the official dictionary being used is almost double the size of the one I had.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://11141265]
Approved by Discipulus
Front-paged by toolic
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (4)
As of 2022-10-07 08:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My preferred way to holiday/vacation is:











    Results (29 votes). Check out past polls.

    Notices?