#!/usr/bin/perl

use strict;
use warnings;

use Carp ();

use Games::Solitaire::Verify::KlondikeTalon;
use Games::Solitaire::Verify::Column;
use Games::Solitaire::Verify::Foundations;

package KlondikeBoard;

use parent 'Games::Solitaire::Verify::Base';

__PACKAGE__->mk_acc_ref(
    [
        qw(
            foundations
            orig_talon_string
            talon
            orig_columns_strings
        )
    ]
);

sub _init
{
    my ( $self, $args ) = @_;

    $self->foundations(
        Games::Solitaire::Verify::Foundations->new(
            {
                num_decks => 1,
            }
        )
    );

    my $orig_talon_string = $args->{orig_talon_string}
        or die "orig_talon_string not specified.";
    $self->orig_talon_string($orig_talon_string);

    $self->talon(
        Games::Solitaire::Verify::KlondikeTalon->new(
            {
                string          => $self->orig_talon_string(),
                max_num_redeals => 3,
            }
        )
    );

    $self->orig_columns_strings( $args->{orig_columns_strings} );

    $self->columns(
        [
            map { Games::Solitaire::Verify::Column->new( { string => $_ } ) }
                @{ $self->orig_columns_strings() }
        ]
    );

    return;
}

sub try_to_put_in_foundations
{
    my ( $self, $card ) = @_;

    my $idx = 0;

    my $suit = $card->suit;

    if ( $self->foundations->value( $suit, $idx ) == $card->rank() - 1 )
    {
        $self->foundations->increment( $card->suit(), $idx );
    }
    else
    {
        Carp::confess( "Cannot increment from card " . $card->to_string() );
    }
}

sub can_put
{
    my ( $self, $args ) = @_;

    my $parent = $args->{parent};
    my $child  = $args->{child};

    return (    ( $parent->color() ne $child->color() )
            and ( $parent->rank() == $child->rank() + 1 ) );
}

package main;

use IO::All;
use Getopt::Long qw(GetOptions);

my ( $board_fn, $solution_fn, $help );

GetOptions(
    'h|help'     => \$help,
    'board=s'    => \$board_fn,
    'solution=s' => \$solution_fn,
) or die "Wrong arguments - $! - type --help for more info.";

if ($help)
{
    print <<'EOF';
This program verifies the Klondike solutions of KlondikeSolver (
https://github.com/shlomif/KlondikeSolver ) and displays them in a more
user-friendly manner.

It requires:

1. An initial board as given by «make_pysol_freecell_board.py -t 24 klondike»
(note the "-t").

2. A solution as given by:

make_pysol_freecell_board.py -t 24 klondike | perl from-fc-solve-board-gen > deck.txt
./KlondikeSolver deck.txt | tee solution.txt

After that run it with --board and --solution and capture its output to
standard output.
EOF
    exit(0);
}
if ( !defined($board_fn) )
{
    die "--board or --help not specified.";
}

if ( !defined($solution_fn) )
{
    die "--solution or --help not specified.";
}

my $board_str = io->file($board_fn)->all();

my @board_lines = split( /\n/, $board_str );

my $talon_line = shift(@board_lines);

my $board = KlondikeBoard->new(
    {
        orig_columns_strings => [ map { ": $_" } @board_lines ],
        orig_talon_string    => $talon_line,
    }
);

use List::Util qw(first);

my $moves_line = first { /\A(?:\[[^\]]+\])+\s*\z/ }
    io->file($solution_fn)->chomp->getlines();

pos($moves_line) = 0;

my $out_fh;
open $out_fh, '>&STDOUT';

my $out_board = sub {
    print {$out_fh} $board->foundations->to_string(), "\n",
        $board->talon->to_string(), "\n",
        map { $_->to_string(), "\n", } @{ $board->columns() };
    print {$out_fh} "\n\n";
};

# $board->talon->draw();

$out_board->();

while ( $moves_line =~ m/\G\[([^\]]+)\]/gms )
{
    my $move = $1;

    if ( $move eq 'Draw' )
    {
        $board->talon->draw();
        $out_fh->print("Move Draw\n\n");
    }
    elsif ( $move eq 'Waste ToFnd' )
    {
        my $card = $board->talon->extract_top();
        $board->try_to_put_in_foundations($card);
        printf {$out_fh} "Move %s from Waste to Foundations\n\n",
            $card->to_string();
    }
    elsif ( my ($col_idx) = $move =~ /\ATab([0-9]+) ToFnd\z/ )
    {
        # 1-based instead of 0-based.
        $col_idx--;

        my $col = $board->columns->[$col_idx];

        my $card = $col->pop();

        if ( !defined($card) )
        {
            die "No card at column $col_idx.";
        }

        if ( $card->is_flipped() )
        {
            die "Card " . $card->to_string() . " is flipped.";
        }

        $board->try_to_put_in_foundations($card);

        printf {$out_fh} "Move %s from Column %d to Foundations\n\n",
            $card->to_string(), $col_idx;
    }
    elsif ( ($col_idx) = $move =~ /\AWaste To Tab([0-9]+)\z/ )
    {
        $col_idx--;

        my $card = $board->talon->extract_top();

        my $col         = $board->columns->[$col_idx];
        my $parent_card = $col->top();

        if ( $col->len() && $parent_card->is_flipped() )
        {
            die "Cannot perform '$move' because parent card is flipped.";
        }
        if (
            $col->len()
            && ( !$board->can_put( { parent => $parent_card, child => $card, } )
            )
            )
        {
            die "Cannot perform '$move' due to parent/child mismatch.";
        }
        $col->push($card);
        printf {$out_fh} "Move %s from Waste to Column %d\n\n",
            $card->to_string(), $col_idx;
    }
    elsif ( $move eq 'NewRound' )
    {
        $board->talon->redeal();
        print {$out_fh} "Move: Redeal talon.\n\n";
    }
    elsif ( ($col_idx) = $move =~ /\AFlip Tab([0-9]+)\z/ )
    {
        $col_idx--;
        my $col         = $board->columns->[$col_idx];
        my $parent_card = $col->top();

        if ( !$parent_card->is_flipped() )
        {
            die "Cannot perform '$move' because parent card is not flipped.";
        }
        $parent_card->set_flipped(0);

        printf {$out_fh} "Move: flip %s on Column %d\n\n",
            $parent_card->to_string(), $col_idx;
    }
    elsif ( my ( $src_col_idx, $dest_col_idx, $with_cards ) =
        $move =~ /\ATab([0-9]+) To Tab([0-9]+)((?: With [0-9]+)?)\z/ )
    {
        $src_col_idx--;
        $dest_col_idx--;

        my $num_cards = ( $with_cards ? ( $with_cards =~ s/\A With //r ) : 1 );

        my $dest_col    = $board->columns->[$dest_col_idx];
        my $parent_card = $dest_col->top();

        if ( $dest_col->len() && $parent_card->is_flipped() )
        {
            die "Cannot perform '$move' because parent card is flipped.";
        }

        my $src_col = $board->columns->[$src_col_idx];
        foreach my $i ( 1 .. $num_cards )
        {
            my $card = $src_col->pos( -$i );
            if ( $card->is_flipped() )
            {
                die "Cannot perform '$move' because source card '"
                    . $card->to_string()
                    . "' is flipped.";
            }
        }

        my $src_card = $src_col->pos( -$num_cards );

        if (
            $dest_col->len()
            && (
                !$board->can_put(
                    { parent => $parent_card, child => $src_card, }
                )
            )
            )
        {
            die "Cannot perform '$move' due to parent/child mismatch.";
        }

        my @cards;

        foreach my $i ( 1 .. $num_cards )
        {
            push @cards, $src_col->pop();
        }
        foreach my $i ( 1 .. $num_cards )
        {
            $dest_col->push( pop(@cards) );
        }
        printf {$out_fh} "Move %d cards from Column %d to Column %d\n\n",
            $num_cards, $src_col_idx, $dest_col_idx;
    }
    else
    {
        die "Unknown move '$move';";
    }
    print {$out_fh} "--------------\n\n";

    $out_board->();

    print {$out_fh} "\n\n==============\n\n";

}
