You got me wordle!

 Since a few days, I am following the hype and play wordle. I think I got lucky the first days but I had already put in some strategy as in starting with words where the possible results are most telling. I was thinking that getting the vowels right early is a good idea so I tend to start with "HOUSE" (continuing three vowels and an S) possibly followed by "FAINT" (containing the remaining vowels plus important N and T).

With this start it never took me more than four guesses so far and twice I managed to find the solution in three guesses.

Of course, over time you start thinking how to optimise this. I knew that Donald Knuth had written a paper solving the original Mastermind showing that five moves are sufficient to always find the answer. So today, I sat down and wrote a perl script to help. It does not do the full minimax (but that shouldn't be too hard from where I am) but at least tells you which of your possible next guesses leaves the best worst case in terms of number of remaining words after knowing the result of your guess. 

In that metric, it turns out "ARISE" is the optional first guess (leaving at most 168 out of the possible 2314 words on this list after knowing the result). In any case, here is the source: 

NB: Since i started playing, there was no word that contained the same letter more than once, so I am not 100% sure how those cases are handled (like what color do the two 'E' in "AGREE" receive if the solution is "AISLE" (in mastermind logic, the second would be green the other grey, not yellow) and what when the solution were "EARLY"? So my script does not handle those cases correct probably (for EARLY it would color both yellow).

#!/usr/local/bin/perl -w

use strict;

# Load the word list of possible answers
my @words = ();
open (IN, "answers.txt") || die "Cannot open answers: $!\n";
while(<IN>) {
  chomp;
  push @words, uc($_);
}
close IN;

my %letters = ();
my @appears = ();

# Positions at which letter $l can still appear
foreach my $c (0..25)  {
  my $l = chr(65 + $c);
  $letters{$l} = [1,1,1,1,1];
}


# Running without an initial guess shows that ARISE is the best guess at it leaves 168 words.

&filter("ARISE", &bewerten("ARISE", "SOLAR"));
#&filter("SMART", &bewerten("SMART", "SOLAR"));

# Find the remaining words
my @remain = @words;
# Only keep words containing the letters in @appeads
foreach my $a(@appears) {
  @remain = grep {/$a/} @remain;
}
my $re = &makeregex;

# Apply positional constraints
@remain = grep {/$re/} @remain;


my $min = @remain;
my $best = '';

# Loop over all possible guesses and targets and count how ofter a potential result appears for a guess
foreach my $g(@remain) {
  my %results = ();
  foreach my $t(@remain) {
    ++$results{&bewerten($g, $t)}
  }
  my $max = 0;
  foreach my $res(keys %results) {
    $max = $results{$res} if $results{$res} > $max;
  }
  #print "$g leaves at most $max.\n";
  if ($min > $max) {
    $min = $max;
    $best = $g;
  }
}

print "Best guess: $best leaves at most $min.\n";

# Assemble a regex for the postional informatiokn
sub makeregex {
  my $rem = '';
  foreach my $p (0..4) {
    $rem .= '[';
    foreach my $l (sort keys %letters) {
      $rem .= $l if $letters{$l}->[$p];
    }
    $rem .= ']';
  }
  return $rem;
}

# Find new constraints arising from the result of a guess
sub filter {
  my ($guess, $result) = @_;

  my @a = split //, $result;
  my @w = split //, uc($guess);
  foreach my $p (0..4) {
    my $l = $w[$p];
    if ($a[$p] == 0) {
      $letters{$l} = [0,0,0,0,0];
    } elsif ($a[$p] == 1) {
      &setletter($l, $p, 0);
      push @appears, $l;
    } else {
      foreach my $o (sort keys %letters) {
	&setletter($o, $p, 0);
      }
      &setletter($l, $p, 1);
    }
  }
}

# Update the positional information for letter $l at position $p with value $v
sub setletter {
  my ($l, $p, $v) = @_;
  my @a = @{$letters{$l}};
  $a[$p] = $v;
  $letters{$l} = \@a;
}

# Find the result for $guess given the $target
sub bewerten {
  my ($guess, $target) = @_;
  my @g = split //, $guess;
  my @t = split //, $target;

  my @result = (0,0,0,0,0);
  foreach my $p(0..4) {
    if($g[$p] eq $t[$p]) {
      $result[$p] = 2;
      $t[$p] = '';
      $g[$p] = 'x';
    }
  }
  $target = join('', @t);
  foreach my $p(0..4) {
    if($target =~ /$g[$p]/) {
      $result[$p] = 1;
    }
  }
  return join('', @result);
}