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

my $list = retrieve('word_list.db');

my %rule = (
    1  => [                                             ],
    2  => [
        {letter => [-1            ], position => [      ]}
    ],
    3  => [
        {letter => [              ], position => [-1    ]}
    ],
    4  => [
        {letter => [-1            ], position => [-1    ]}
    ],
    5  => [],
    6  => [
        {letter => [-1            ], position => [      ]},
        {letter => [-1, -2        ], position => [      ]}
    ],
    7  => [
        {letter => [-2            ], position => [-1    ]},
        {letter => [              ], position => [-1, -2]}
    ],
    8  => [
        {letter => [-1            ], position => [-1, -2]},
        {letter => [-1, -2        ], position => [-1, -2]}
    ],
    9  => [
        {letter => [-1            ], position => [-1    ]},
        {letter => [              ], position => [      ]}
    ],
    10 => [
        {letter => [-1            ], position => [      ]},
        {letter => [-1, -2        ], position => [      ]},
        {letter => [-1, -2, -3    ], position => [      ]}
    ],
    11 => [
        {letter => [-2, -3        ], position => [-1    ]},
        {letter => [-3            ], position => [-1, -2]},
        {letter => [              ], position => [-1, -2]}
    ],
    12 => [
        {letter => [-1            ], position => [-1, -2]},
        {letter => [-1, -2        ], position => [-1, -2]},
        {letter => [-1, -2, -3    ], position => [-1, -2]}
    ],
    13 => [
        {letter => [-2, -3        ], position => [-2    ]},
        {letter => [-3            ], position => [      ]},
        {letter => [              ], position => [      ]}
    ],
    14 => [
        {letter => [-1            ], position => [      ]},
        {letter => [-1, -2        ], position => [      ]},
        {letter => [-1, -2, -3    ], position => [      ]},
        {letter => [-1, -2, -3, -4], position => [      ]},
    ],
    15 => [
        {letter => [-2, -3, -4    ], position => [-1    ]},
        {letter => [-3, -4        ], position => [-1, -2]},
        {letter => [-4            ], position => [-1, -2]},
        {letter => [              ], position => [-1, -2]},
    ]
);

my (%used, @chain, %bonus);
while (1) {
    my $lvl = int(@chain / 10) + 1; 
    last if ! $rule{$lvl};
    my $next = get_next_word($list, \%used, \@chain, \%bonus, $rule{$lvl});
    last if ! $next;
    push @chain, $next;
    update_status(\%used, \@chain, \%bonus); 
}

sub update_status {
    my ($used, $chain, $bonus) = @_;
    my $last = $chain->[-1];
    my ($word, $pos) = @{$last}{qw/word position/};
    $used->{$word} = 1;
    $bonus->{$pos} = undef;
    %$bonus = () if keys %$bonus == 4;
}

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

my $last_pos = 0;
for (@chain) {
    my ($word, $pos, $let) = @{$_}{qw/word position letter/};
    move_position($last_pos, $pos) if $last_pos != $pos;
    $last_pos = $pos;
    print "Playing $word used $let at $pos\n";
    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 letter/};
            next if $used->{$word} || ! $avail{$pos} || fails_rule($chain, $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 $chain->[$_]{letter};   }; 
        for ( @{$rule->[$ord]{position}} ) { return 1 if $let eq $chain->[$_]{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;
}
__END__
Known Bugs/Issues
# If the same letter is repeated in the rules, the game chooses the previous letter but this code does not 
# There are a few words in the list this code uses that Word Chain Plus does not consider valid
# There are a few words in the list that Word Chain Plus uses that this code does not know about