File Coverage

blib/lib/Games/LMSolve/Base.pm

Criterion	Covered	Total	%
statement	75	167	44.9
branch	10	34	29.4
condition	2	9	22.2
subroutine	13	29	44.8
pod	17	17	100.0
total	117	256	45.7

package Games::LMSolve::Base;

use strict;
use warnings;

use Getopt::Long;

our $VERSION = '0.8.6';

use Exporter;

use vars qw(@ISA @EXPORT_OK);

@ISA = qw(Exporter);

@EXPORT_OK = qw(%cell_dirs);

use vars qw(%cell_dirs);

%cell_dirs = (
    'N'  => [ 0,  -1 ],
    'NW' => [ -1, -1 ],
    'NE' => [ 1,  -1 ],
    'S'  => [ 0,  1 ],
    'SE' => [ 1,  1 ],
    'SW' => [ -1, 1 ],
    'E'  => [ 1,  0 ],
    'W'  => [ -1, 0 ],
);


sub new
{
    my $class = shift;

    my $self = {};

    bless $self, $class;

    $self->initialize(@_);

    return $self;
}

sub initialize
{
    my $self = shift;

    $self->{'state_collection'} = {};
    $self->{'cmd_line'}         = { 'scan' => "brfs", };

    $self->{'num_iters'} = 0;

    return 0;
}


my %scan_functions = (
    'dfs' => sub {
        my $self = shift;

        return $self->_solve_brfs_or_dfs( 1, @_ );
    },
    'brfs' => sub {
        my $self = shift;

        return $self->_solve_brfs_or_dfs( 0, @_ );
    },
);

sub main
{
    my $self = shift;

    # This is a flag that specifies whether to present the moves in Run-Length
    # Encoding.
    my $to_rle                  = 1;
    my $output_states           = 0;
    my $scan                    = "brfs";
    my $run_time_states_display = 0;

    #my $p = Getopt::Long::Parser->new();
    if (
        !GetOptions(
            'rle!'           => \$to_rle,
            'output-states!' => \$output_states,
            'method=s'       => \$scan,
            'rtd!'           => \$run_time_states_display,
        )
        )
    {
        die "Incorrect options passed!\n";
    }

    if ( !exists( $scan_functions{$scan} ) )
    {
        die "Unknown scan \"$scan\"!\n";
    }

    $self->{'cmd_line'}->{'to_rle'}        = $to_rle;
    $self->{'cmd_line'}->{'output_states'} = $output_states;
    $self->{'cmd_line'}->{'scan'}          = $scan;
    $self->set_run_time_states_display( $run_time_states_display
            && \&_default_rtd_callback );

    my $filename = shift(@ARGV) || "board.txt";

    my @ret = $self->solve_board($filename);

    $self->display_solution(@ret);
}


sub _die_on_abstract_function
{
    my (
        $package,   $filename, $line,       $subroutine, $hasargs,
        $wantarray, $evaltext, $is_require, $hints,      $bitmask
    ) = caller(1);
    die(      "The abstract function $subroutine() was "
            . "called, while it needs to be overrided by the derived class.\n"
    );
}


sub input_board
{
    return _die_on_abstract_function();
}


# A function that accepts the expanded state (as an array ref)
# and returns an atom that represents it.
sub pack_state
{
    return _die_on_abstract_function();
}


# A function that accepts an atom that represents a state
# and returns an array ref that represents it.
sub unpack_state
{
    return _die_on_abstract_function();
}


# Accept an atom that represents a state and output a
# user-readable string that describes it.
sub display_state
{
    return _die_on_abstract_function();
}


sub check_if_final_state
{
    return _die_on_abstract_function();
}


# This function enumerates the moves accessible to the state.
# If it returns a move, it still does not mean that this move is a valid
# one. I.e: it is possible that it is illegal to perform it.
sub enumerate_moves
{
    return _die_on_abstract_function();
}


# This function accepts a state and a move. It tries to perform the
# move on the state. If it is succesful, it returns the new state.
#
# Else, it returns undef to indicate that the move is not possible.
sub perform_move
{
    return _die_on_abstract_function();
}


# This function checks if a state it receives as an argument is a
# dead-end one.
sub check_if_unsolvable
{
    return 0;
}


# This is a function that should be overrided in case
# rendering the move into a string is non-trivial.
sub render_move
{
    my $self = shift;

    my $move = shift;

    return defined($move) ? $move : "";
}


sub _solve_brfs_or_dfs
{
    my $self             = shift;
    my $state_collection = $self->{'state_collection'};
    my $is_dfs           = shift;
    my %args             = @_;

    my $run_time_display = $self->{'cmd_line'}->{'rt_states_display'};
    my $rtd_callback     = $self->{'run_time_display_callback'};
    my $max_iters        = $args{'max_iters'} || (-1);
    my $check_iters      = ( $max_iters >= 0 );

    my ( @queue, $state, $coords, $depth, @moves, $new_state );

    if ( exists( $args{'initial_state'} ) )
    {
        push @queue, $args{'initial_state'};
    }

    my @ret;

    @ret = ( "unsolved", undef );

    while ( scalar(@queue) )
    {
        if ( $check_iters && ( $max_iters <= $self->{'num_iters'} ) )
        {
            @ret = ( "interrupted", undef );
            goto Return;
        }
        if ($is_dfs)
        {
            $state = pop(@queue);
        }
        else
        {
            $state = shift(@queue);
        }
        $coords = $self->unpack_state($state);
        $depth  = $state_collection->{$state}->{'d'};

        $self->{'num_iters'}++;

        # Output the current state to the screen, assuming this option
        # is set.
        if ($run_time_display)
        {
            $rtd_callback->(
                $self,
                'depth' => $depth,
                'state' => $coords,
                'move'  => $state_collection->{$state}->{'m'},
            );

# print ((" " x $depth) . join(",", @$coords) . " M=" . $self->render_move($state_collection->{$state}->{'m'}) ."\n");
        }

        if ( $self->check_if_unsolvable($coords) )
        {
            next;
        }

        if ( $self->check_if_final_state($coords) )
        {
            @ret = ( "solved", $state );
            goto Return;
        }

        @moves = $self->enumerate_moves($coords);

        foreach my $m (@moves)
        {
            my $new_coords = $self->perform_move( $coords, $m );

           # Check if this move leads nowhere and if so - skip to the next move.
            if ( !defined($new_coords) )
            {
                next;
            }

            $new_state = $self->pack_state($new_coords);
            if ( !exists( $state_collection->{$new_state} ) )
            {
                $state_collection->{$new_state} = {
                    'p' => $state,
                    'm' => $m,
                    'd' => ( $depth + 1 )
                };
                push @queue, $new_state;
            }
        }
    }

Return:

    return @ret;
}

sub _run_length_encoding
{
    my @moves = @_;
    my @ret   = ();

    my $prev_m = shift(@moves);
    my $count  = 1;
    my $m;
    while ( $m = shift(@moves) )
    {
        if ( $m eq $prev_m )
        {
            $count++;
        }
        else
        {
            push @ret, [ $prev_m, $count ];
            $prev_m = $m;
            $count  = 1;
        }
    }
    push @ret, [ $prev_m, $count ];

    return @ret;
}

sub _solve_state
{
    my $self = shift;

    my $initial_coords = shift;

    my $state = $self->pack_state($initial_coords);
    $self->{'state_collection'}->{$state} = { 'p' => undef, 'd' => 0 };

    return $self->run_scan(
        'initial_state' => $state,
        @_
    );
}


sub solve_board
{
    my $self = shift;

    my $filename = shift;

    my $initial_coords = $self->input_board($filename);

    return $self->_solve_state( $initial_coords, @_ );
}


sub run_scan
{
    my $self = shift;

    my %args = @_;

    return $scan_functions{ $self->{'cmd_line'}->{'scan'} }->( $self, %args );
}


sub get_num_iters
{
    my $self = shift;

    return $self->{'num_iters'};
}


sub display_solution
{
    my $self = shift;

    my @ret = @_;

    my $state_collection = $self->{'state_collection'};

    my $output_states = $self->{'cmd_line'}->{'output_states'};
    my $to_rle        = $self->{'cmd_line'}->{'to_rle'};

    my $echo_state = sub {
        my $state = shift;
        return $output_states
            ? ( $self->display_state($state) . ": Move = " )
            : "";
    };

    print $ret[0], "\n";

    if ( $ret[0] eq "solved" )
    {
        my $key    = $ret[1];
        my $s      = $state_collection->{$key};
        my @moves  = ();
        my @states = ($key);

        while ( $s->{'p'} )
        {
            push @moves, $s->{'m'};
            $key = $s->{'p'};
            $s   = $state_collection->{$key};
            push @states, $key;
        }
        @moves  = reverse(@moves);
        @states = reverse(@states);
        my $num_state;
        if ($to_rle)
        {
            my @moves_rle = _run_length_encoding(@moves);

            $num_state = 0;
            foreach my $m (@moves_rle)
            {
                print $echo_state->( $states[$num_state] )
                    . $self->render_move( $m->[0] ) . " * "
                    . $m->[1] . "\n";
                $num_state += $m->[1];
            }
        }
        else
        {
            for ( $num_state = 0 ; $num_state < scalar(@moves) ; $num_state++ )
            {
                print $echo_state->( $states[$num_state] )
                    . $self->render_move( $moves[$num_state] ) . "\n";
            }
        }
        if ($output_states)
        {
            print $self->display_state( $states[$num_state] ), "\n";
        }
    }
}

sub _default_rtd_callback
{
    my $self = shift;

    my %args = @_;
    print(( " " x $args{depth} )
        . join( ",", @{ $args{state} } ) . " M="
            . $self->render_move( $args{move} )
            . "\n" );
}


sub set_run_time_states_display
{
    my $self           = shift;
    my $states_display = shift;

    if ( !$states_display )
    {
        $self->{'cmd_line'}->{'rt_states_display'} = undef;
    }
    else
    {
        $self->{'cmd_line'}->{'rt_states_display'} = 1;
        $self->{'run_time_display_callback'} = $states_display;
    }

    return 0;
}


1;

__END__