#!/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

##</code><code>##

#!/usr/bin/perl
use strict;
use warnings;
use Storable;
use Text::LevenshteinXS 'distance';

my @word;
open(my $fh, '<', 'four_dict.txt') or die $!;
while (<$fh>) {
    tr/\r\n//d;
    push @word, $_;
}

my %dict;

for my $i (0 .. $#word - 1) {
    my $i_score = score($word[$i]);
    for my $j ($i + 1 .. $#word) {
        if (distance($word[$i], $word[$j]) == 1) {
            my $j_score = score($word[$i]);
            $_ = $word[$i] ^ $word[$j];
            /[^\0]/;
            my $pos = $-[0];
            my $i_let = substr($word[$i], $pos, 1);
            my $j_let = substr($word[$j], $pos, 1);
            push @{$dict{$word[$i]}}, {word => $word[$j], score => $j_score, letter => $j_let, position => $pos};
            push @{$dict{$word[$j]}}, {word => $word[$i], score => $i_score, letter => $i_let, position => $pos};
        }
    }
}
store \%dict, 'word_list.db';
sub score {
    my ($word) = @_;
    my %point = (
        A => 10, B => 40, C => 40, D => 30,  E => 10, F => 50, G => 40, H => 40, I => 20, J => 80, K => 40, L => 20, M => 30,
        N => 20, O => 10, P => 30, Q => 100, R => 20, S => 10, T => 20, U => 20, V => 60, W => 80, X => 90, Y => 40, Z => 80
    );
    my $score = 0;
    for (split //, $word) {
        $_ = uc($_);
        $score += $point{$_};
    }
    return $score;
}