File Coverage

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

Criterion	Covered	Total	%
statement	119	132	90.1
branch	33	46	71.7
condition	23	28	82.1
subroutine	16	16	100.0
pod	1	1	100.0
total	192	223	86.1

package Games::Solitaire::Verify::Golf;
$Games::Solitaire::Verify::Golf::VERSION = '0.2401';
use strict;
use warnings;
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 parent 'Games::Solitaire::Verify::Base';

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

my $MAX_RANK  = 13;
my $NUM_SUITS = 4;

sub _is_golf
{
    my $self = shift;

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

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

    my $variant = $self->_variant( $args->{variant} );
    if (
        not
        exists { golf => 1, all_in_a_row => 1, black_hole => 1, }->{$variant} )
    {
        Carp::confess("Unknown variant '$variant'!");
    }
    $self->_place_queens_on_kings( $args->{queens_on_kings} // '' );
    $self->_wrap_ranks( $args->{wrap_ranks}                 // '' );
    $self->_foundation(
        Games::Solitaire::Verify::Freecells->new( { count => 1 } ) );
    my $board_string = $args->{board_string};

    my @lines = split( /\n/, $board_string );

    my $_set_found_line = sub {
        my $foundation_str = shift;
        if ( my ($card_s) = $foundation_str =~ m#\AFoundations: (\S{2})\z# )
        {
            $self->_set_found(
                Games::Solitaire::Verify::Card->new( { string => $card_s } ) );
        }
        else
        {
            Carp::confess("Foundations str is '$foundation_str'");
        }
        return;
    };
    my $foundation_str = shift(@lines);
    if ( $self->_variant eq 'golf' )
    {
        if ( $foundation_str !~ s#\ATalon: ((?:\S{2} ){15}\S{2})#$1# )
        {
            die "improper talon line <$foundation_str>!";
        }
        $self->_talon(
            [
                map { Games::Solitaire::Verify::Card->new( { string => $_ } ) }
                    split / /,
                $foundation_str
            ]
        );

        $foundation_str = shift(@lines);
        $_set_found_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
        {
            $_set_found_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, $card ) = @_;
    $self->_foundation->assign( 0, $card );
    return;
}

sub process_solution
{
    my ( $self, $next_line_iter ) = @_;
    my $columns         = $self->_columns;
    my $NUM_COLUMNS     = @$columns;
    my $line_num        = 0;
    my $remaining_cards = sum( map { $_->len } @$columns );

    my $get_line = sub {
        my $ret = $next_line_iter->();
        return ( $ret, ++$line_num );
    };

    my $assert_empty_line = sub {
        my ( $s, $line_idx ) = $get_line->();

        if ( $s ne '' )
        {
            die "Line '$line_idx' is not empty, but '$s'";
        }

        return;
    };

    my ( $l, $first_l ) = $get_line->();

    if ( $l ne "Solved!" )
    {
        die "First line is '$l' instead of 'Solved!'";
    }
    my $IS_GOLF     = $self->_is_golf;
    my $CHECK_EMPTY = ( $IS_GOLF or $self->_variant eq "black_hole" );

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

        my $card;
        if (    $IS_GOLF
            and $move_line =~ m/\ADeal talon\z/ )
        {
            if ( !@{ $self->_talon } )
            {
                die "Talon is empty on line no. $move_line_idx";
            }
            $card = shift @{ $self->_talon };
        }
        elsif ( $move_line !~
            m/\AMove a card from stack ([0-9]+) to the foundations\z/ )
        {
            die
"Incorrect format for move line no. $move_line_idx - '$move_line'";
        }

        my $col_idx = $1;

        if ( !defined $card )
        {
            if ( ( $col_idx < 0 ) or ( $col_idx >= $NUM_COLUMNS ) )
            {
                die "Invalid column index '$col_idx' at $move_line_idx";
            }
        }

        $assert_empty_line->();

        my ( $info_line, $info_line_idx ) = $get_line->();

        if ( $info_line !~ m/\AInfo: Card moved is ([A23456789TJQK][HCDS])\z/ )
        {
            die
"Invalid format for info line no. $info_line_idx - '$info_line'";
        }

        my $moved_card_str = $1;

        $assert_empty_line->();
        $assert_empty_line->();

        my ( $sep_line, $sep_line_idx ) = $get_line->();

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

        $assert_empty_line->();

        if ( defined $card )
        {
            my $top_card_moved_str = $card->to_string();
            if ( $top_card_moved_str ne $moved_card_str )
            {
                die
"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 )
            {
                die
"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(0);
            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
                        )
                    )
                    )
                {
                    die
"Cannot put $top_card_moved_str in the foundations that contain "
                        . $found_card->to_string();
                }
            }
            $card = $col->pop;
            --$remaining_cards;
        }

        $self->_set_found($card);
        if ($CHECK_EMPTY)
        {
            if ( $remaining_cards == 0 )
            {
                last MOVES;
            }
        }
    }
    return;
}

1;

__END__