Re^2: Improve My FaceBook Scramble Solver

[Limbic~Region]

Anonymous Monk,
In my code, you can see I generate the my_dict.db from a plain text word file (in my case, 'all_words.txt'). Any dictionary file will do. I believe I used one of the word lists from here initially.

I actually got the official word file from the developer Gareth Taft but I do not have his permission to post it publicly. Actually, I realize now that I never updated this node with my revised code after he explained the missing components of my reverse engineering of the rules. See below:

Score: 292,581,765
Biggest Chain: 3581
Highest Multiplier: 267
Best Word: JEEZ (172,125)

#!/usr/bin/perl
use constant DEBUG => 1;
use constant CHAIN => 0;
use constant USED  => 1;
use constant POS_Q => 2;
use constant LET_Q => 3;
use strict;
use warnings;
use Storable;

my %rule = (
    1 => { key => {},                                           place 
+=> {} },
    2 => { key => {2 => 1, 6 => 2, 10 => 3, 14 => 4, '*' => 5}, place 
+=> {} },
    3 => { key => {},                                           place 
+=> {3 => 1, '*' => 2} },
    0 => { key => {4 => 1, 8 => 2, 12 => 3, 16 => 4, '*' => 5}, place 
+=> {4 => 1, '*' => 2} }
);

my $list = retrieve('word_list.db');
my $init = $ARGV[0] or die "Usage: $0 <word> <iterations>";
my $n    = $ARGV[1] or die "Usage: $0 <word> <iterations>";

open(my $chain_fh, '>', "${init}_longest_chain.txt") or die $!;
select $chain_fh;
$| = 1;
open(my $score_fh, '>', "${init}_highest_score.txt") or die $!;
select $score_fh;
$| = 1;
select STDOUT;
$| = 1;

my @work;
for (@{$list->{$init}}) {
    my %used = ($_->{word} => 1);
    my @chain = ($_);
    my (@pos_queue, @let_queue);
    push @work, [\@chain, \%used, \@pos_queue, \@let_queue];
}
print scalar localtime(), "\n";

my $max_score = {chain => [], score => -1, len => -1};
my $max_chain = {chain => [], score => -1, len => -1};

while (@work) {
    last if ! $n--;
    my $item = pop @work;
    my $curr = $item->[CHAIN][-1]{word};

    my $end_of_chain = 1;

    CANDIDATE:
    for (@{$list->{$curr}}) {
        my ($word, $pos, $let) = @{$_}{qw/word position letter/};

        # Already used this word
        next CANDIDATE if $item->[USED]{$word};
        my %used  = %{$item->[USED]};

        # Can't use this letter
        my @let_q = @{$item->[LET_Q]};
        for (@let_q) {
            next CANDIDATE if $let eq $_;
        }

        # Can't use this position
        my @pos_q = @{$item->[POS_Q]};
        for (@pos_q) {
            next CANDIDATE if $pos == $_;
        }

        my @chain = @{$item->[CHAIN]};

        # Update info 
        push @chain, $_; 
        $used{$word} = 1;

        my $lvl = int(@chain / 10) + 1;
        my $style = $lvl % 4;

        # Handle left over queue
        shift @let_q if $style == 1 || $style == 3;
        shift @pos_q if $style == 1 || $style == 2;

        shift @let_q if let_q_full($style, $lvl, scalar @let_q);
        push @let_q, $let if $style == 2 || $style == 0;
        shift @pos_q if pos_q_full($style, $lvl, scalar @pos_q);
        push @pos_q, $pos if $style == 3 || $style == 0;

        # Add the new item to the work queue
        push @work, [\@chain, \%used, \@pos_q, \@let_q];
        $end_of_chain = 0;
    }

    if ($end_of_chain) {
        my $count = @{$item->[CHAIN]};
        my $score = calculate_score($item->[CHAIN]);
        if ($count > $max_chain->{len}) {
            $max_chain->{len}   = $count;
            $max_chain->{score} = $score;
            $max_chain->{chain} = $item->[CHAIN];
            if (DEBUG) {
                print "Found new longest chain: $count with score of $
+score\n";
            }
            print $chain_fh join(' ', map $_->{word}, @{$item->[CHAIN]
+}), "\n";
        }
        if ($score > $max_score->{score}) {
            $max_score->{len}   = $count;
            $max_score->{score} = $score;
            $max_score->{chain} = $item->[CHAIN];
            if (DEBUG) {
                print "Found new high scoring chain: $count with score
+ of $score\n";
            }
            print $score_fh join(' ', map $_->{word}, @{$item->[CHAIN]
+}), "\n";
        }
    }
}
print scalar localtime(), "\n";

sub let_q_full {
    my ($style, $lvl, $count) = @_;
    return if $style == 1 || $style == 3;
    my $full = $rule{$style}{key}{$lvl} || $rule{$style}{key}{'*'}; 
    return $count >= $full;
}

sub pos_q_full {
    my ($style, $lvl, $count) = @_;
    return if $style == 1 || $style == 2;
    my $full = $rule{$style}{place}{$lvl} || $rule{$style}{place}{'*'}
+; 
    return $count >= $full;
}

sub calculate_score {
    my ($chain) = @_;
    my ($total, $multiplier, %bonus) = (0, 1, ());
    for (@$chain) {
        my ($pos, $score) = @{$_}{qw/position score/};
        if ($bonus{$pos}) {
            %bonus = ($pos => 1);
        }
        else {
            $bonus{$pos} = 1;
        }
        if (keys %bonus == 4) {
            $multiplier++;
            %bonus = ();
        }
        $total += ($score * $multiplier);
    }
    return $total;
}

#!/usr/bin/perl
use constant DELAY => 15;
use strict;
use warnings;
use Storable;
use Win32::GuiTest 'SendKeys';

my $list = retrieve('word_list.db');
my $word = $ARGV[0] or die "Usage: $0 <input_word>";
my $file = "${word}_highest_score.txt";

open(my $fh, '<', $file) or die "Unable to open '$file' for reading: $
+!";
my $last_line;
while (<$fh>) {
    chomp;
    $last_line = $_;
}

my @guess = grep length($_) == 4, split ' ', $last_line;
my ($curr, @chain) = ($list->{$word}, ());
GUESS:
for my $want (@guess) {
    for my $have (@$curr) {
        if ($have->{word} eq $want) {
            push @chain, $have;
            $curr = $list->{$have->{word}};
            next GUESS;
        }
    }
}


my $score = calculate_score(\@chain);
print "Ready to get $score points (excludes time bonus)\n";
<STDIN>;
sleep 5;

my ($last_pos, $last_word) = (0, $word);
for (@chain) {
    my ($word, $pos, $let) = @{$_}{qw/word position letter/};
    move_position($last_pos, $pos) if $last_pos != $pos;
    $last_pos = $pos;
    print "Changing '$last_word' into '$word' by using $let at $pos\n"
+;
    $last_word = $word;
    SendKeys($let, DELAY);
}

sub calculate_score {
    my ($chain) = @_;
    my ($total, $multiplier, %bonus) = (0, 1, ());
    for (@$chain) {
        my ($pos, $score) = @{$_}{qw/position score/};
        if ($bonus{$pos}) {
            %bonus = ($pos => 1);
        }
        else {
            $bonus{$pos} = 1;
        }
        if (keys %bonus == 4) {
            $multiplier++;
            %bonus = ();
        }
        $total += ($score * $multiplier);
    }
    return $total;
}

sub move_position {
    my ($src, $tgt) = @_;
    if ($src > $tgt) {
        SendKeys("{LEFT}",  DELAY) for 1 .. $src - $tgt;
    }
    else {
        SendKeys("{RIGHT}", DELAY) for 1 .. $tgt - $src;
    }
}

sub get_next_word {
    my ($list, $used, $chain, $bonus, $rule) = @_;
    my $curr = @$chain ? $chain->[-1]{word} : $ARGV[0];
    die "Usage: $0 <word>" if ! $curr;
    my ($best, $max) = ('', 0);
    {
        my %avail = map {$_ => 1} 0 .. 3;
        delete $avail{$_} for keys %$bonus;
        for my $neighbor (@{$list->{$curr}}) {
            my ($word, $pos, $let) = @{$neighbor}{qw/word position let
+ter/};
            next if $used->{$word} || ! $avail{$pos} || fails_rule($ch
+ain, $rule, $pos, $let);
            my $count = @{$list->{$word}};
            ($best, $max) = ($neighbor, $count) if $count > $max;
        }
        if (! $best) {
            return if ! %$bonus;
            %$bonus = ();
            redo;
        }
    }
    return $best;
}

sub fails_rule {
    my ($chain, $rule, $let, $pos) = @_;
    return if ! @$rule;
    my $ord = @$chain % 10;
    if ($rule->[$ord]) {
        for ( @{$rule->[$ord]{letter}}   ) { return 1 if $let eq $chai
+n->[$_]{letter};   }; 
        for ( @{$rule->[$ord]{position}} ) { return 1 if $let eq $chai
+n->[$_]{position}; }; 
    }
    else {
        for ( @{$rule->[-1]{letter}}   ) { return 1 if $let eq $chain-
+>[$_]{letter};   }; 
        for ( @{$rule->[-1]{position}} ) { return 1 if $let eq $chain-
+>[$_]{position}; }; 
    }
    return;
}