Re: Hangman Assistant

[Limbic~Region]

Lawliet,
Here is some proof of concept code I wrote for an algorithm I outlined here. It is rather naive and I didn't spend a lot of time making it efficient but I figured I would share anyway.

#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Std;

my %opt;
get_args(\%opt);

my $dict = load_dictionary($opt{d}, $opt{w});
my %guessed;
my $curr_guess = join '', map {'*'} 1 .. length($opt{w}); 
while (1) {
    last if $curr_guess eq $opt{w} || ! $opt{g};
    print "Current value:\t$curr_guess\n";
    my $best_letter = find_best_letter($dict, \%guessed);
    print "Best letter to choose: $best_letter\n"; 
    my $result = index($opt{w}, $best_letter) == -1 ? 'wrong' : 'right
+';
    if (index($opt{w}, $best_letter) == -1) {
        print "You guessed wrong\n";
        --$opt{g};
        prune_dict_bad_guess($dict, $best_letter);
    }
    else {
        print "You guessed right\n";
        $curr_guess = update_current($curr_guess, $opt{w}, $best_lette
+r);
        prune_dict_correct_guess($dict, $curr_guess);
    }
    $guessed{$best_letter} = undef;
}
print "\n$curr_guess\n";

sub prune_dict_correct_guess {
    my ($dict, $curr) = @_;
    my %correct;
    for (0 .. length($curr) - 1) {
        my $chr = substr($curr, $_, 1);
        next if $chr eq '*';
        $correct{$_} = $chr;
    }
    for my $word (keys %$dict) {
        for my $pos (keys %correct) {
            if (substr($word, $pos, 1) ne $correct{$pos}) {
                delete $dict->{$word};
                last;
            }
        }
    }
}

sub update_current {
    my ($src, $tgt, $let) = @_;
    for (0 .. length($tgt) - 1) {
        substr($src, $_, 1, $let) if substr($tgt, $_, 1) eq $let;
    }
    return $src;
}

sub prune_dict_bad_guess {
    my ($dict, $letter) = @_;
    for my $word (keys %$dict) {
        delete $dict->{$word} if index($word, $letter) != -1;
    }
}


sub find_best_letter {
    my ($dict, $guessed) = @_;
    my %alpha;
    for my $word (keys %$dict) {
        my %uniq = map {$_ => undef} split //, $word;
        $alpha{$_}++ for keys %uniq;
    }
    delete @alpha{keys %$guessed};
    # Would be better as water mark algorithm
    my @best = sort {$alpha{$b} <=> $alpha{$a}} keys %alpha;
    return $best[0];
}

sub get_args {
    my ($opt) = @_;
    my $Usage = qq{Usage: $0 [options]
        -h : This help message

        -d : The (d)ictionary file
             Default: 'words.txt' in the current working directory

        -g : The number of (g)uesses
             Default: 7 

        -w : The (w)ord to be guessed
    } . "\n";
    getopts('hd:g:w:', $opt)   or die $Usage;
    die $Usage               if   $opt->{h};
    die $Usage               if ! $opt->{w} || $opt->{w} =~ /[^a-zA-Z]
+/;
    $opt->{d} = 'words.txt'  if ! defined $opt->{d};
    $opt->{g} = 7            if ! defined $opt->{g};
    $opt->{w} = lc($opt->{w});
}

sub load_dictionary {
    my ($file, $word) = @_;
    my $desired_length = length($word);
    my %dict;
    open(my $fh, '<', $file) or die "Unable to open '$file' for readin
+g: $!";
    while (<$fh>) {
        tr/a-zA-Z//cd;
        next if length($_) != $desired_length;
        $dict{lc($_)} = undef;
    }
    return \%dict;
}

[Lawliet]

Thanks for the effort!

I think your algorithm is the same as the one I initially used, suggesting the letter that is most common throughout the words. I think further investigation should be done, testing all the words and then seeing the data produced for each algorithm.

[Limbic~Region]

Lawliet,
...testing all the words and then seeing the data produced for each algorithm

I suggested the very thing elsewhere in the thread. I can easily modify this code to only produce "lose" if it is unable to guess the word in the allowed number of wrong guesses or "win <total_guesses> <wrong_guesses>" if it does win. I haven't looked at your code so I would think it would be easier for you to modify it accordingly.