File Coverage

blib/lib/Games/Solitaire/Verify/Golf.pm

Criterion	Covered	Total	%
statement	155	168	92.2
branch	47	64	73.4
condition	23	28	82.1
subroutine	17	17	100.0
pod	1	1	100.0
total	243	278	87.4

package Games::Solitaire::Verify::Golf;
$Games::Solitaire::Verify::Golf::VERSION = '0.2601';
use strict;
use warnings;
use 5.014;
use autodie;


use Carp       ();
use List::Util qw/ sum /;

use Games::Solitaire::Verify::Card      ();
use Games::Solitaire::Verify::Column    ();
use Games::Solitaire::Verify::Freecells ();
use Games::Solitaire::Verify::LinesIter ();

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

__PACKAGE__->mk_acc_ref(
    [
        qw(
            _columns
            _foundation
            _num_foundations
            _place_queens_on_kings
            _talon
            _variant
            _wrap_ranks
        )
    ]
);

my $MAX_RANK  = 13;
my $NUM_SUITS = 4;
my $CARD_RE   = qr/[A23456789TJQK][HCDS]/;

my %_VARIANTS = (
    all_in_a_row => 1,
    binary_star  => 1,
    black_hole   => 1,
    golf         => 1,
);

sub _is_binary_star
{
    my $self = shift;

    return $self->_variant eq 'binary_star';
}

sub _is_golf
{
    my $self = shift;

    return $self->_variant eq 'golf';
}

sub _read_foundation_line
{
    my ( $self, $foundation_str ) = @_;
    my $num_foundations = $self->_num_foundations();

    if ( my ($card_s) = $foundation_str =~
        m#\AFoundations:((?: $CARD_RE){$num_foundations})\z# )
    {
        $card_s =~ s/\A //ms
            or Carp::confess("_set_found_line: no leading space");
        my @c = split( / /, $card_s );
        if ( @c != $num_foundations )
        {
            Carp::confess( "num_foundations is "
                    . scalar(@c)
                    . " rather than $num_foundations" );
        }
        for my $i ( keys @c )
        {
            my $s = $c[$i];
            $self->_set_found( $i,
                Games::Solitaire::Verify::Card->new( { string => $s } ) );
        }
    }
    else
    {
        Carp::confess("Foundations str is '$foundation_str'");
    }
    return;
}

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

    my $variant = $self->_variant( $args->{variant} );
    if ( not exists $_VARIANTS{$variant} )
    {
        Carp::confess("Unknown variant '$variant'!");
    }
    my $IS_BINARY_STAR = $self->_is_binary_star;
    $self->_place_queens_on_kings( $args->{queens_on_kings} // '' );
    $self->_wrap_ranks( $args->{wrap_ranks}                 // '' );
    my $num_foundations = ( $IS_BINARY_STAR ? 2 : 1 );
    $self->_num_foundations($num_foundations);
    $self->_foundation(
        Games::Solitaire::Verify::Freecells->new(
            { count => $num_foundations, }
        )
    );
    my $board_string = $args->{board_string};

    my @lines          = split( /\n/, $board_string );
    my $foundation_str = shift(@lines);
    if ( $self->_variant eq 'golf' )
    {
        if ( $foundation_str !~ s#\ATalon: ((?:$CARD_RE ){15}$CARD_RE)#$1# )
        {
            Carp::confess("improper talon line <$foundation_str>!");
        }
        $self->_talon(
            [
                map { Games::Solitaire::Verify::Card->new( { string => $_ } ) }
                    split / /,
                $foundation_str
            ]
        );

        $foundation_str = shift(@lines);
        $self->_read_foundation_line($foundation_str);
    }
    else
    {
        $self->_talon( [] );
        if ( $self->_variant eq "all_in_a_row" )
        {
            if ( $foundation_str ne "Foundations: -" )
            {
                Carp::confess("Foundations str is '$foundation_str'");
            }
        }
        else
        {
            $self->_read_foundation_line($foundation_str);
        }
    }

    $self->_columns(
        [
            map {
                Games::Solitaire::Verify::Column->new(
                    {
                        string => ": $_",
                    }
                )
            } @lines
        ]
    );
    if ( $self->_wrap_ranks )
    {
        $self->_place_queens_on_kings(1);
    }

    return;
}

sub _set_found
{
    my ( $self, $i, $card ) = @_;
    $self->_foundation->assign( $i, $card, );
    return;
}

sub process_solution
{
    my ( $self, $next_line_iter ) = @_;
    my $columns     = $self->_columns;
    my $NUM_COLUMNS = @$columns;
    my $it          = Games::Solitaire::Verify::LinesIter->new(
        { _get => $next_line_iter, } );
    my $remaining_cards = sum( map { $_->len } @$columns );

    $it->_compare_line( "Solved!", "First line" );

    my $IS_BINARY_STAR     = $self->_is_binary_star;
    my $IS_GOLF            = $self->_is_golf;
    my $CHECK_EMPTY        = ( $IS_GOLF or $self->_variant eq "black_hole" );
    my $IS_DETAILED_MOVE   = $IS_BINARY_STAR;
    my $IS_DISPLAYED_BOARD = $IS_BINARY_STAR;
    my $num_decks          = $self->_num_foundations();
    my $num_foundations    = $self->_num_foundations();

    # As many moves as the number of cards.
MOVES:
    for my $move_idx (
        0 .. (
            $num_decks * $MAX_RANK * $NUM_SUITS -
                $num_foundations -
                ( $num_foundations > 1 )
        )
        )
    {
        my ( $move_line, $move_line_idx ) = $it->_get_line;

        my $card;
        my $col_idx;
        my $foundation_idx = 0;
        my $moved_card_str;
        if (    $IS_GOLF
            and $move_line =~ m/\ADeal talon\z/ )
        {
            if ( !@{ $self->_talon } )
            {
                Carp::confess("Talon is empty on line no. $move_line_idx");
            }
            $card = shift @{ $self->_talon };
        }
        else
        {
            if (
                not(
                    $IS_DETAILED_MOVE
                    ? ( ( $moved_card_str, $col_idx, $foundation_idx ) =
                            $move_line =~
m/\AMove ($CARD_RE) from stack ([0-9]+) to foundations ([0-9]+)\z/
                    )
                    : ( ($col_idx) =
                            $move_line =~
m/\AMove a card from stack ([0-9]+) to the foundations\z/
                    )
                )
                )
            {
                Carp::confess(
"Incorrect format for move line no. $move_line_idx - '$move_line'"
                );
            }
        }

        if ( !defined $card )
        {
            if ( ( $col_idx < 0 ) or ( $col_idx >= $NUM_COLUMNS ) )
            {
                Carp::confess(
                    "Invalid column index '$col_idx' at line no. $move_line_idx"
                );
            }
        }

        $it->_assert_empty_line();
        my ( $info_line, $info_line_idx );
        if ( not $IS_DETAILED_MOVE )
        {
            ( $info_line, $info_line_idx ) = $it->_get_line;
            if ( $info_line !~ m/\AInfo: Card moved is ($CARD_RE)\z/ )
            {
                Carp::confess(
"Invalid format for info line no. $info_line_idx - '$info_line'"
                );
            }

            $moved_card_str = $1;

            $it->_assert_empty_line();
            $it->_assert_empty_line();

            my ( $sep_line, $sep_line_idx ) = $it->_get_line;

            if ( $sep_line !~ m/\A=+\z/ )
            {
                Carp::confess(
"Invalid format for separator line no. $sep_line_idx - '$sep_line'"
                );
            }

            $it->_assert_empty_line();
        }

        if ( defined $card )
        {
            my $top_card_moved_str = $card->to_string();
            if ( $top_card_moved_str ne $moved_card_str )
            {
                Carp::confess(
"Card moved should be '$top_card_moved_str', but the info says it is '$moved_card_str' at line $info_line_idx"
                );
            }
        }
        else
        {
            my $col                = $columns->[$col_idx];
            my $top_card           = $col->top();
            my $top_card_moved_str = $top_card->to_string();

            if ( $top_card_moved_str ne $moved_card_str )
            {
                Carp::confess(
"Card moved should be '$top_card_moved_str', but the info says it is '$moved_card_str' at line $info_line_idx"
                );
            }

            my $found_card = $self->_foundation->cell($foundation_idx);
            if ( defined($found_card) )
            {
                my $found_rank = $found_card->rank();
                my $src_rank   = $top_card->rank();

                my $delta = abs( $src_rank - $found_rank );
                if (
                    not( $delta == 1 or $delta == ( $MAX_RANK - 1 ) )
                    or (
                            $IS_GOLF
                        and ( !$self->_wrap_ranks )
                        and (
                            (
                                $self->_place_queens_on_kings
                                ? ( $found_rank == $MAX_RANK )
                                : 0
                            )
                            or $delta != 1
                        )
                    )
                    )
                {
                    Carp::confess(
"Cannot put $top_card_moved_str in the foundations that contain "
                            . $found_card->to_string() );
                }
                if ($IS_DISPLAYED_BOARD)
                {
                    my $wanted_line = $self->_foundation->to_string();
                    $wanted_line =~ s#\AFreecells:#Foundations:#
                        or Carp::confess("Unimpl!");
                    $wanted_line =~ s#  # #g;
                    my $fstr = $found_card->to_string();
                    my $tstr = $top_card->to_string();
                    $wanted_line =~
s#\AFoundations:(?: $CARD_RE){$foundation_idx} \K(\Q$fstr\E)#my$c=$1;"[ $c -> $tstr ]"#e
                        or Carp::confess(
"Failed substitute! foundation_idx=$foundation_idx wanted_line=$wanted_line fstr='$fstr'"
                        );
                    $it->_compare_line( $wanted_line, "Foundations" );
                    for my $i ( keys @$columns )
                    {
                        my $col         = $columns->[$i];
                        my $wanted_line = $col->to_string();
                        if ( $i == $col_idx )
                        {
                            $wanted_line =~
                                s# \K(\Q$tstr\E)\z#my$c=$1;"[ $c -> ]"#e
                                or Carp::confess(
"Failed column substitute! foundation_idx=$foundation_idx wanted_line=$wanted_line tstr='$tstr'"
                                );
                        }
                        $it->_compare_line( $wanted_line, "Column $i" );
                    }
                    $it->_assert_empty_line();
                }
            }
            $card = $col->pop;
            --$remaining_cards;
        }
        if ( not defined $foundation_idx )
        {
            Carp::confess("\$foundation_idx not set");
        }
        $self->_set_found( $foundation_idx, $card, );
        if ($CHECK_EMPTY)
        {
            if ( $remaining_cards == 0 )
            {
                last MOVES;
            }
        }
    }
    return;
}

1;

__END__