Updated code:
#!/usr/bin/perl
# Todo:
# Narrow possibilties by eliminating words with repeat letters when I
+have
# guessed one of the repeats letters but the letter I guessed is eithe
+r not a
# repeat in the target word or is in a different position.
# Example:
# "rustlers" is a possible word, I guess 'r' and am presented with
# "r _ _ _ r _ _ _", meaning the word has two r's, just in the wrong s
+pot,
# and therefore rustlers should be eliminated.
use warnings;
use strict;
use 5.010;
# Simple instructions:
# perl $0 "w _ r d" "previousfailedguesses"
say $ARGV[0];
my @word = split(/ /, $ARGV[0]);
my $guessed = $ARGV[1] ? join('|', split(//, $ARGV[1])) : "0";
say $guessed;
my %wordlist; # Hash of word-length arrays
open(WORD, '<', '/usr/share/dict/words') or die $!; # Edited to /words
+ as per request
while (<WORD>) {
chomp;
next if /[^a-z]/; # Lazy way out~
my @chars = split(//, $_);
push @{$wordlist{$#chars}}, $_;
}
close WORD;
my @narrowed = @{$wordlist{$#word}}; # Narrowed possible answers by si
+ze
OUTER: for (my $i = 0; $i <= $#narrowed; $i++) {
my @chars = split(//, $narrowed[$i]);
# Narrowed by previous guesses
if ($narrowed[$i] =~ /$guessed/) {
splice(@narrowed, $i, 1);
$i--; # Decrement counter now that word has been removed
next OUTER;
}
# Narrowed by matching characters
for (my $pos = 0; $pos <= $#word; $pos++) {
next if $word[$pos] eq '_';
if ($word[$pos] ne $chars[$pos]) {
splice(@narrowed, $i, 1);
$i--;
next OUTER;
}
}
}
# %alphabet holds the number of times a letter occurs within all words
# %seen holds the number times a letter occurs in one word
my %alphabet;
$alphabet{$_} = 0 foreach ('a'..'z');
foreach my $word (@narrowed) {
my %seen;
$seen{$_} = 0 foreach ('a'..'z');
my @chars = split(//, $word);
foreach my $char (@chars) {
$alphabet{$char}++ if $seen{$char} == 0; # Limit 1 increment f
+or each letter once per word
$seen{$char}++;
}
undef %seen;
}
say $#narrowed + 1;
if ($#narrowed <= 10) {
say $_ foreach @narrowed; # Word list
say sort { $alphabet{$b} <=> $alphabet{$a} } keys %alphabet; # Mos
+t common letter, including ones already guessed
} else {
# Find how close each letter is to half of the total word possibil
+ities to ensure maximum gain every guess after being sorted
foreach my $occur (keys %alphabet) {
$alphabet{$occur} = abs($#narrowed/2 - abs($alphabet{$occur} -
+ $#narrowed + 1));
}
say sort { $alphabet{$a} <=> $alphabet{$b} } keys %alphabet;
}
Updated example:
$ perl hangman.pl "_ _ _ _ _ _ _ _" ""
_ _ _ _ _ _ _ _
0
10588
rantislodecgupmhbyfkwvxzqj
$ perl hangman.pl "_ _ _ _ _ _ _ _" "r"
_ _ _ _ _ _ _ _
r
5252
atlnsieodcgumhpbyfkwvxzqjr
$ perl hangman.pl "_ _ _ _ _ _ _ _" "ra"
_ _ _ _ _ _ _ _
r|a
2761
tolnsdgueichpmbfykwvxzqjra
$ perl hangman.pl "_ _ _ _ _ t _ _" "ra"
_ _ _ _ _ t _ _
r|a
165
isncdolupmghbfykvxejqwtraz
$ perl hangman.pl "_ _ _ _ _ t i _" "ra"
_ _ _ _ _ t i _
r|a
17
slhpodungmxytieqbwrajkfvcz
$ perl hangman.pl "_ _ _ _ _ t i _" "ras"
_ _ _ _ _ t i _
r|a|s
9
bulletin
dietetic
eclectic
ecliptic
elliptic
eutectic
hypnotic
phonetic
quixotic
ticelpunohxdyqbwrajkgfvmsz
$ perl hangman.pl "_ c _ _ c t i c" "ras"
_ c _ _ c t i c
r|a|s
1
eclectic
tielcwraxdjyukhgfnvmspqbzo
Same amount of guesses as before, but a better way to get there (I think).
I don't mind occasionally having to reinvent a wheel; I don't even mind using someone's reinvented wheel occasionally. But it helps a lot if it is symmetric, contains no fewer than ten sides, and has the axle centered. I do tire of trapezoidal wheels with offset axles. --Joseph Newcomer