A word game program, similar to "Wordle".
Now with Term::ReadKey
#!/usr/bin/perl
use warnings;
use strict;
# Version 1.0
my $me = $0 =~ s|.*/||r;
my $usage = <<USAGE;
usage: $me -h -g N -w N -f WORD_FILE
-h This help message.
-g Number of guesses
Defaults to 6
-w Word length
Defaults to 5
-f Word file to use
Defaults to /usr/share/dict/words
USAGE
use Getopt::Std;
getopts( 'hg:w:f:', \my %opts ) or die $usage;
die $usage if exists $opts{ h };
use Term::ReadKey;
ReadMode 4;
END { ReadMode 0; }
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 $pre = qr/\e\[\d+m\e\[\d+m/; # colour
my $post = qr/\e\[0m/; # reset
# guesses allowed = number of lines displayed
my $guesses = $opts{ g } || 6;
# length of words to use
my $word_size = $opts{ w } || 5;
# file name to use
my $file_name = $opts{ f } || '/usr/share/dict/words';
my $divider = ' ---' x $word_size . "\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
BS RET ESC to exit
KB
my @lines = map [ ( ' ' ) x $word_size ], 1 .. $guesses;
my $curr_line = 0;
my %dict;
{
open my $FH, '<', $file_name or die "Cannot open '$file_name' beca
+use: $!";
# exclude proper nouns and punctuation
# words must have at least one vowel
@dict{ map uc, grep /[aeiouy]/, map /^([a-z]{$word_size})$/, <$FH>
+ } = ();
}
my $curr_word = ( keys %dict )[ rand keys %dict ];
my @letters;
{ local $| = 1;
print
$clear,
"\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;
}
# Only accept keys we want to use
# alphabetic, back space, return or escape
my $key;
1 until defined( $key = ReadLine( -1 ) ) && $key =~ /\A[a-zA-Z\177
+\n\e]\z/;
last if $key eq "\e";
if ( $key eq "\177" ) {
pop @letters if @letters;
for my $index ( 0 .. $#{ $lines[ $curr_line ] } ) {
$lines[ $curr_line ][ $index ] = defined $letters[ $index
+] ? " $letters[$index] " : ' ';
}
redo;
}
if ( $key =~ /\A[a-zA-Z]\z/ ) {
push @letters, uc $key if @letters < $word_size;
for my $index ( 0 .. $#{ $lines[ $curr_line ] } ) {
$lines[ $curr_line ][ $index ] = defined $letters[ $index
+] ? " $letters[$index] " : ' ';
}
redo;
}
if ( $key eq "\n" && @letters == $word_size ) {
my $word = join '', @letters;
# Not a valid five letter word
unless ( exists $dict{ $word } ) {
$lines[ $curr_line ] = [ map "$white_on_red $_ $reset", @l
+etters ];
redo;
}
# The correct answer
if ( $word eq $curr_word ) {
$lines[ $curr_line ] = [ map "$white_on_green $_ $reset",
+@letters ];
for my $letter ( @letters ) {
$kb =~ s/$pre? $letter $post?/$white_on_green $letter
+$reset/;
}
$curr_line = @lines;
redo;
}
# Default; all letters to white on gray
$lines[ $curr_line ] = [ map "$white_on_gray $_ $reset", @lett
+ers ];
for my $letter ( @letters ) {
$kb =~ s/$pre? $letter $post?/$white_on_gray $letter $rese
+t/;
}
# Find exact matches
my @found = ( 0 ) x $word_size;
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
+ $reset";
$kb =~ s/$pre? $letter $post?/$white_on_green $letter $res
+et/;
}
my $curr_remains = join '', ( split //, $curr_word )[ grep !$f
+ound[ $_ ], 0 .. $#found ];
# Find other correct letters
while ( my ( $index, $letter ) = each @letters ) {
next if $found[ $index ];
if ( $curr_remains =~ s/$letter/ / ) {
$lines[ $curr_line ][ $index ] = "$white_on_yellow $le
+tter $reset";
$kb =~ s/$pre? $letter $post?/$white_on_yellow $letter
+ $reset/;
}
}
++$curr_line;
@letters = ();
}
redo;
}