File Coverage

blib/lib/Games/ABC_Path/Solver/Board.pm

Criterion	Covered	Total	%
statement	289	351	82.3
branch	62	96	64.5
condition	10	18	55.5
subroutine	58	60	96.6
pod	7	7	100.0
total	426	532	80.0

package Games::ABC_Path::Solver::Board;
$Games::ABC_Path::Solver::Board::VERSION = '0.6.2';
use warnings;
use strict;

use 5.008;


use Carp;

use parent 'Games::ABC_Path::Solver::Base';

use Games::ABC_Path::Solver::Constants;
use Games::ABC_Path::Solver::Move::LastRemainingCellForLetter;
use Games::ABC_Path::Solver::Move::LastRemainingLetterForCell;
use Games::ABC_Path::Solver::Move::LettersNotInVicinity;
use Games::ABC_Path::Solver::Move::ResultsInAnError;
use Games::ABC_Path::Solver::Move::ResultsInASuccess;
use Games::ABC_Path::Solver::Move::TryingLetterForCell;

use Games::ABC_Path::Solver::Coord;

use Scalar::Util qw(blessed);

my $ABCP_VERDICT_NO    = 0;
my $ABCP_VERDICT_MAYBE = 1;
my $ABCP_VERDICT_YES   = 2;

my %letters_map = ( map { $letters[$_] => $_ } ( 0 .. $ABCP_MAX_LETTER ) );

sub _get_letter_numeric
{
    my ( $self, $letter_ascii ) = @_;

    my $index = $letters_map{$letter_ascii};

    if ( !defined($index) )
    {
        confess "Unknown letter '$letter_ascii'";
    }

    return $index;
}

sub _iter_changed
{
    my $self = shift;

    if (@_)
    {
        $self->{_iter_changed} = shift;
    }

    return $self->{_iter_changed};
}

sub _moves
{
    my $self = shift;

    if (@_)
    {
        $self->{_moves} = shift;
    }

    return $self->{_moves};
}

sub _error
{
    my $self = shift;

    if (@_)
    {
        $self->{_error} = shift;
    }

    return $self->{_error};
}

sub _inc_changed
{
    my ($self) = @_;

    $self->_iter_changed( $self->_iter_changed + 1 );

    return;
}

sub _flush_changed
{
    my ($self) = @_;

    my $ret = $self->_iter_changed;

    $self->_iter_changed(0);

    return $ret;
}

sub _add_move
{
    my ( $self, $move ) = @_;

    push @{ $self->_moves() }, $move;

    $self->_inc_changed;

    return;
}


sub get_successful_layouts
{
    my ($self) = @_;

    return [ @{ $self->_successful_layouts } ];
}

sub _successful_layouts
{
    my $self = shift;

    if (@_)
    {
        $self->{_successful_layouts} = shift;
    }

    return $self->{_successful_layouts};
}

sub _layout
{
    my $self = shift;

    if (@_)
    {
        $self->{_layout} = shift;
    }

    return $self->{_layout};
}

# The letter indexes.
sub _l_indexes
{
    return ( 0 .. $ABCP_MAX_LETTER );
}

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

    my $layout_string = $args->{layout};

    if ( !defined($layout_string) )
    {
        $layout_string = '';
    }

    $self->_layout( \$layout_string );
    $self->_successful_layouts( [] );
    $self->_moves( [] );
    $self->_iter_changed(0);

    return;
}

sub _calc_offset
{
    my ( $self, $letter, $xy ) = @_;

    if ( ( $letter < 0 ) or ( $letter >= 25 ) )
    {
        confess "Letter $letter out of range.";
    }

    return $letter * $BOARD_SIZE + $self->_xy_to_int( [ $xy->y, $xy->x ] );
}

sub _get_verdict
{
    my ( $self, $letter, $xy ) = @_;

    return vec( ${ $self->_layout }, $self->_calc_offset( $letter, $xy, ), 2 );
}

sub _set_verdict
{
    my ( $self, $letter, $xy, $verdict ) = @_;

    # Temporary - remove later.
    if ( @_ != 4 )
    {
        confess "_set_verdict has wrong number of args.";
    }

    if (
        not(   ( $verdict == $ABCP_VERDICT_NO )
            || ( $verdict == $ABCP_VERDICT_MAYBE )
            || ( $verdict == $ABCP_VERDICT_YES ) )
        )
    {
        confess "Invalid verdict $verdict .";
    }

    vec( ${ $self->_layout }, $self->_calc_offset( $letter, $xy ), 2 ) =
        $verdict;

    return;
}

sub _xy_loop
{
    my ( $self, $sub_ref ) = (@_);

    foreach my $y ( $self->_y_indexes )
    {
        if ( $self->_error() )
        {
            return;
        }
        foreach my $x ( $self->_x_indexes )
        {
            if ( $self->_error() )
            {
                return;
            }
            $sub_ref->(
                Games::ABC_Path::Solver::Coord->new( { x => $x, y => $y } ) );
        }
    }
    return;
}

sub _set_verdicts_for_letter_sets
{
    my ( $self, $letter_list, $maybe_list ) = @_;

    my %cell_is_maybe = ( map { $_->_to_s() => 1 } @$maybe_list );

    foreach my $letter_ascii (@$letter_list)
    {
        my $letter = $self->_get_letter_numeric($letter_ascii);

        $self->_xy_loop(
            sub {
                my ($xy) = @_;

                $self->_set_verdict(
                    $letter, $xy,
                    (
                        ( exists $cell_is_maybe{ $xy->_to_s() } )
                        ? $ABCP_VERDICT_MAYBE
                        : $ABCP_VERDICT_NO
                    )
                );
            }
        );
    }

    return;
}

sub _set_conclusive_verdict_for_letter
{
    my ( $self, $letter, $l_xy ) = @_;

    $self->_xy_loop(
        sub {
            my ($xy) = @_;

            $self->_set_verdict(
                $letter, $xy,
                (
                      $l_xy->_equal($xy)
                    ? $ABCP_VERDICT_YES
                    : $ABCP_VERDICT_NO
                )
            );
        }
    );

OTHER_LETTER:
    foreach my $other_letter ( $self->_l_indexes )
    {
        if ( $other_letter == $letter )
        {
            next OTHER_LETTER;
        }
        $self->_set_verdict( $other_letter, $l_xy, $ABCP_VERDICT_NO );
    }

    return;
}

sub _get_possible_letter_indexes
{
    my ( $self, $xy ) = @_;

    return [ grep { $self->_get_verdict( $_, $xy ) != $ABCP_VERDICT_NO }
            $self->_l_indexes() ];
}


sub get_possible_letters_for_cell
{
    my ( $self, $x, $y ) = @_;

    return [
        @letters[
            @{
                $self->_get_possible_letter_indexes(
                    Games::ABC_Path::Solver::Coord->new( { x => $x, y => $y } )
                )
            }
        ]
    ];
}

sub _get_possible_letters_string
{
    my ( $self, $xy ) = @_;

    return
        join( ',',
        @{ $self->get_possible_letters_for_cell( $xy->x, $xy->y ) } );
}

sub _infer_letters
{
    my ($self) = @_;

    foreach my $letter ( $self->_l_indexes )
    {
        my @true_cells;

        $self->_xy_loop(
            sub {
                my ($xy) = @_;

                my $ver = $self->_get_verdict( $letter, $xy );
                if (   ( $ver == $ABCP_VERDICT_YES )
                    || ( $ver == $ABCP_VERDICT_MAYBE ) )
                {
                    push @true_cells, $xy;
                }
            }
        );

        if ( !@true_cells )
        {
            $self->_error( [ 'letter', $letter ] );
            return;
        }
        elsif ( @true_cells == 1 )
        {
            my $xy = $true_cells[0];
            if ( $self->_get_verdict( $letter, $xy ) == $ABCP_VERDICT_MAYBE )
            {
                $self->_set_conclusive_verdict_for_letter( $letter, $xy );
                $self->_add_move(
                    Games::ABC_Path::Solver::Move::LastRemainingCellForLetter
                        ->new(
                        {
                            vars => {
                                letter => $letter,
                                coords => $xy,
                            },
                        }
                        )
                );
            }
        }

        my @neighbourhood = ( map { [ (0) x $LEN ] } ( $self->_y_indexes ) );

        foreach my $true (@true_cells)
        {
            foreach my $coords (
                grep {
                            $self->_x_in_range( $_->[0] )
                        and $self->_y_in_range( $_->[1] )
                }
                map { [ $true->x + $_->[0], $true->y + $_->[1] ] }
                map {
                    my $d = $_;
                    map { [ $_, $d ] } ( -1 .. 1 )
                } ( -1 .. 1 )
                )
            {
                $neighbourhood[ $coords->[1] ][ $coords->[0] ] = 1;
            }
        }

        foreach my $neighbour_letter (
            ( ( $letter > 0 )                ? ( $letter - 1 ) : () ),
            ( ( $letter < $ABCP_MAX_LETTER ) ? ( $letter + 1 ) : () ),
            )
        {
            $self->_xy_loop(
                sub {
                    my ($xy) = @_;

                    if ( $neighbourhood[ $xy->y ][ $xy->x ] )
                    {
                        return;
                    }

                    my $existing_verdict =
                        $self->_get_verdict( $neighbour_letter, $xy );

                    if ( $existing_verdict == $ABCP_VERDICT_YES )
                    {
                        $self->_error( [ 'mismatched_verdict', $xy ] );
                        return;
                    }

                    if ( $existing_verdict == $ABCP_VERDICT_MAYBE )
                    {
                        $self->_set_verdict( $neighbour_letter, $xy,
                            $ABCP_VERDICT_NO );
                        $self->_add_move(
                            Games::ABC_Path::Solver::Move::LettersNotInVicinity
                                ->new(
                                {
                                    vars => {
                                        target => $neighbour_letter,
                                        coords => $xy,
                                        source => $letter,
                                    },
                                }
                                )
                        );
                    }
                }
            );
        }
    }

    return;
}

sub _infer_cells
{
    my ($self) = @_;

    $self->_xy_loop(
        sub {
            my ($xy) = @_;

            my $letters_aref = $self->_get_possible_letter_indexes($xy);

            if ( !@$letters_aref )
            {
                $self->_error( [ 'cell', $xy ] );
                return;
            }
            elsif ( @$letters_aref == 1 )
            {
                my $letter = $letters_aref->[0];

                if (
                    $self->_get_verdict( $letter, $xy ) == $ABCP_VERDICT_MAYBE )
                {
                    $self->_set_conclusive_verdict_for_letter( $letter, $xy );
                    $self->_add_move(
                        Games::ABC_Path::Solver::Move::LastRemainingLetterForCell
                            ->new(
                            {
                                vars => {
                                    coords => $xy,
                                    letter => $letter,
                                },
                            },
                            )
                    );
                }
            }
        }
    );

    return;
}

sub _inference_iteration
{
    my ($self) = @_;

    $self->_infer_letters;

    $self->_infer_cells;

    return $self->_flush_changed;
}

sub _neighbourhood_and_individuality_inferring
{
    my ($self) = @_;

    my $num_changed = 0;

    while ( my $iter_changed = $self->_inference_iteration() )
    {
        if ( $self->_error() )
        {
            return;
        }
        $num_changed += $iter_changed;
    }

    return $num_changed;
}

sub _clone
{
    my ($self) = @_;

    return ref($self)->new(
        {
            layout => ${ $self->_layout() },
        }
    );
}


sub solve
{
    my ($self) = @_;

    my $error = $self->_solve_wrapper;

    return [
        map {
            my $obj = $_;
            ( blessed($obj) && $obj->isa('Games::ABC_Path::Solver::Coord') )
                ? ( $obj->x, $obj->y )
                : ($obj)
        } @$error
    ];
}

sub _solve_wrapper
{
    my ($self) = @_;

    $self->_neighbourhood_and_individuality_inferring;

    if ( $self->_error )
    {
        return $self->_error;
    }

    my @min_coords;
    my @min_options;

    $self->_xy_loop(
        sub {
            my ($xy) = @_;

            my $letters_aref = $self->_get_possible_letter_indexes($xy);

            if ( !@$letters_aref )
            {
                $self->_error( [ 'cell', $xy ] );
            }
            elsif ( @$letters_aref > 1 )
            {
                if ( ( !@min_coords ) or ( @$letters_aref < @min_options ) )
                {
                    @min_options = @$letters_aref;
                    @min_coords  = ($xy);
                }
            }

            return;
        }
    );

    if ( $self->_error )
    {
        return $self->_error;
    }

    if (@min_coords)
    {
        my ($xy) = @min_coords;

        # We have at least one multiple rank cell. Let's recurse there:
        foreach my $letter (@min_options)
        {
            my $recurse_solver = $self->_clone;

            $self->_add_move(
                Games::ABC_Path::Solver::Move::TryingLetterForCell->new(
                    {
                        vars => { letter => $letter, coords => $xy, },
                    }
                ),
            );

            $recurse_solver->_set_conclusive_verdict_for_letter( $letter, $xy );

            $recurse_solver->_solve_wrapper;

            foreach my $move ( @{ $recurse_solver->get_moves } )
            {
                $self->_add_move( $move->bump() );
            }

            if ( $recurse_solver->_error() )
            {
                $self->_add_move(
                    Games::ABC_Path::Solver::Move::ResultsInAnError->new(
                        {
                            vars => {
                                letter => $letter,
                                coords => $xy,
                            },
                        }
                    )
                );
            }
            else
            {
                $self->_add_move(
                    Games::ABC_Path::Solver::Move::ResultsInASuccess->new(
                        {
                            vars => { letter => $letter, coords => $xy, },
                        }
                    )
                );
                push @{ $self->_successful_layouts },
                    @{ $recurse_solver->get_successful_layouts() };
            }
        }

        my $count = @{ $self->_successful_layouts() };
        if ( !$count )
        {
            return ['all_options_bad'];
        }
        elsif ( $count == 1 )
        {
            return ['success'];
        }
        else
        {
            return ['success_multiple'];
        }
    }
    else
    {
        $self->_successful_layouts( [ $self->_clone() ] );
        return ['success'];
    }
}

my $letter_re_s         = join( '', map { quotemeta($_) } @letters );
my $letter_re           = qr{[$letter_re_s]};
my $letter_and_space_re = qr{[ $letter_re_s]};
my $top_bottom_re       = qr/^${letter_re}{7}\n/ms;
my $inner_re = qr/^${letter_re}${letter_and_space_re}{5}${letter_re}\n/ms;

sub _assert_letters_appear_once
{
    my ( $self, $layout_string ) = @_;

    my %count_letters = ( map { $_ => 0 } @letters );
    foreach my $letter ( $layout_string =~ m{($letter_re)}g )
    {
        if ( $count_letters{$letter}++ )
        {
            confess "Letter '$letter' encountered twice in the layout.";
        }
    }

    return;
}

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

    my @major_diagonal_letters;

    $args->{top} =~ m{\A($letter_re)};

    push @major_diagonal_letters, $1;

    $args->{bottom} =~ m{($letter_re)\z};

    push @major_diagonal_letters, $1;

    $self->_set_verdicts_for_letter_sets(
        \@major_diagonal_letters,
        [
            map { Games::ABC_Path::Solver::Coord->new( { x => $_, y => $_ } ) }
                $self->_y_indexes
        ],
    );

    return;
}

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

    my @minor_diagonal_letters;

    $args->{top} =~ m{($letter_re)\z};

    push @minor_diagonal_letters, $1;

    $args->{bottom} =~ m{\A($letter_re)};

    push @minor_diagonal_letters, $1;

    $self->_set_verdicts_for_letter_sets(
        \@minor_diagonal_letters,
        [
            map {
                Games::ABC_Path::Solver::Coord->new( { x => $_, y => 4 - $_ } )
            } ( $self->_y_indexes )
        ]
    );

    return;
}

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

    my $top_row    = $args->{top};
    my $bottom_row = $args->{bottom};

    foreach my $x ( $self->_x_indexes )
    {
        $self->_set_verdicts_for_letter_sets(
            [
                substr( $top_row, $x + 1, 1 ), substr( $bottom_row, $x + 1, 1 ),
            ],
            [
                map {
                    Games::ABC_Path::Solver::Coord->new( { x => $x, y => $_ } )
                } $self->_y_indexes
            ],
        );
    }

    return;
}

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

    my $rows = $args->{rows};

    my ( $clue_x, $clue_y, $clue_letter );

    foreach my $y ( $self->_y_indexes )
    {
        my $row = $rows->[$y];
        $self->_set_verdicts_for_letter_sets(
            [ substr( $row, 0, 1 ), substr( $row, -1 ), ],
            [
                map {
                    Games::ABC_Path::Solver::Coord->new( { x => $_, y => $y } )
                } $self->_x_indexes
            ],
        );

        my $s = substr( $row, 1, -1 );
        if ( $s =~ m{($letter_re)}g )
        {
            my ( $l, $x_plus_1 ) = ( $1, pos($s) );
            if ( defined($clue_letter) )
            {
                confess "Found more than one clue letter in the layout!";
            }
            ( $clue_x, $clue_y, $clue_letter ) = ( $x_plus_1 - 1, $y, $l );
        }
    }

    if ( !defined($clue_letter) )
    {
        confess "Did not find any clue letters inside the layout.";
    }

    $self->_set_conclusive_verdict_for_letter(
        $self->_get_letter_numeric($clue_letter),
        Games::ABC_Path::Solver::Coord->new( { x => $clue_x, y => $clue_y } ),
    );

    return;
}

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

    if ( $args->{version} ne 1 )
    {
        die "Can only handle version 1";
    }

    my $layout_string = $args->{layout};
    if ( $layout_string !~
        m/\A${top_bottom_re}${inner_re}{5}${top_bottom_re}\z/ms )
    {
        die
"Invalid format. Should be Letter{7}\n(Letter{spaces or one letter}{5}Letter){5}\nLetter{7}";
    }

    my @rows = split( /\n/, $layout_string );

    my $top_row    = shift(@rows);
    my $bottom_row = pop(@rows);

    # Now let's process the layout string and populate the verdicts table.
    $self->_assert_letters_appear_once($layout_string);

    my $parse_context =
        { top => $top_row, bottom => $bottom_row, rows => \@rows, };

    $self->_process_major_diagonal($parse_context);

    $self->_process_minor_diagonal($parse_context);

    $self->_process_input_columns($parse_context);

    $self->_process_input_rows_and_initial_letter_clue($parse_context);

    return;
}

sub _get_results_text_table
{
    my ($self) = @_;

    my $render_row = sub {
        my $cols = shift;

        return
              "| "
            . join( " | ", map { length($_) == 1 ? "  $_  " : $_ } @$cols )
            . " |\n";
    };

    return join(
        '',
        map { $render_row->($_) } (
            [ map { sprintf( "X = %d", $_ + 1 ) } $self->_x_indexes ],
            map {
                my $y = $_;
                [
                    map {
                        $self->_get_possible_letters_string(
                            Games::ABC_Path::Solver::Coord->new(
                                { x => $_, y => $y }
                            )
                        )
                    } $self->_x_indexes
                ]
            } $self->_y_indexes
        )
    );
}


sub get_successes_text_tables
{
    my ($self) = @_;

    return [ map { $_->_get_results_text_table() }
            @{ $self->get_successful_layouts() } ];
}


sub input_from_file
{
    my ( $class, $board_fn ) = @_;

    open my $in_fh, "<", $board_fn
        or die "Cannot open '$board_fn' - $!";

    my $first_line = <$in_fh>;
    chomp($first_line);

    my $magic = 'ABC Path Solver Layout Version 1:';
    if ( $first_line !~ m{\A\Q$magic\E\s*\z} )
    {
        die "Can only process files whose first line is '$magic'!";
    }

    my $layout_string = '';
    foreach my $line_idx ( 1 .. 7 )
    {
        chomp( my $line = <$in_fh> );
        $layout_string .= "$line\n";
    }
    close($in_fh);

    return $class->input_from_v1_string($layout_string);
}


sub input_from_v1_string
{
    my ( $class, $layout_string ) = @_;

    my $self = $class->new;

    $self->_input( { layout => $layout_string, version => 1 } );

    return $self;
}


sub get_moves
{
    my ($self) = @_;

    return [ @{ $self->_moves } ];
}


1;    # End of Games::ABC_Path::Solver::Board

__END__