File Coverage

blib/lib/Game/Battleship/Grid.pm

Criterion	Covered	Total	%
statement	61	83	73.4
branch	16	48	33.3
condition	8	24	33.3
subroutine	7	7	100.0
pod	1	1	100.0
total	93	163	57.0

package Game::Battleship::Grid;
$Game::Battleship::Grid::VERSION = '0.0601';
our $AUTHORITY = 'cpan:GENE';

use Carp;
use Game::Battleship::Craft;
use Moo;
use Types::Standard qw( ArrayRef Int );

has dimension => (
    is      => 'ro',
    isa     => ArrayRef[Int],
    default => sub { [ 9, 9 ] },
);

has fleet => (
    is  => 'ro',
    isa => ArrayRef,
);

# Place the array reference of craft on the grid.
sub BUILD {
    my $self = shift;

    # Initialize the matrix.
    for my $i (0 .. $self->dimension->[0]) {
        for my $j (0 .. $self->dimension->[1]) {
            $self->{matrix}[$i][$j] = '.';
        }
    }

    # Place the fleet on the grid.
    for my $craft (@{ $self->{fleet} }) {
        my ($ok, $x0, $y0, $x1, $y1, $orient);

        if (defined $craft->position) {
            ($x0, $y0) = ($craft->position->[0], $craft->position->[1]);

            # Set the craft orientation and tail coordinates.
            ($orient, $x1, $y1) = _tail_coordinates(
                $x0, $y0,
                $craft->points - 1
            );
        }
        else {
# XXX This looping is needlessly brutish. refactoring please
            while (not $ok) {
                # Grab a random coordinate that we haven't seen.
                $x0 = int(rand($self->dimension->[0] + 1));
                $y0 = int(rand($self->dimension->[1] + 1));

                # Set the craft orientation and tail coordinates.
                ($orient, $x1, $y1) = _tail_coordinates(
                    $x0, $y0,
                    $craft->points - 1
                );

                # If the craft is not placed off the grid and it does
                # not collide with another craft, then we are ok to
                # move on.
# XXX regex constraint rules here?
                if ($x1 <= $self->dimension->[0] &&
                    $y1 <= $self->dimension->[1]
                ) {
                    # For each craft (except the current one) that has
                    # a position, do the craft share a common point?
                    my $collide = 0;

                    for (@{ $self->{fleet} }) {
                        # Ships can't be the same.
                        if ($craft->name ne $_->name) {
                            # Ships can't intersect.
                            if (defined $_->position &&
                                _segment_intersection(
                                    $x0, $y0,
                                    $x1, $y1,
                                    @{ $_->position->[0] },
                                    @{ $_->position->[1] }
                                )
                            ) {
                                $collide = 1;
                                last;
                            }
                        }
                    }

                    $ok = 1 unless $collide;
                }
            }

            # Set the craft position.
            $craft->{position} = [[$x0, $y0], [$x1, $y1]];
        }
#warn "$craft->{name}: [$x0, $y0], [$x1, $y1], $craft->{points}\n";

        # Add the craft to the grid.
        for my $n (0 .. $craft->points - 1) {
            if ($orient) {
                $self->{matrix}[$x0 + $n][$y0] = $craft->{id};
            }
            else {
                $self->{matrix}[$x0][$y0 + $n] = $craft->{id};
            }
        }
    }
}

sub _tail_coordinates {
    # Get the coordinates of the end of the segment based on a given
    # span.
    my ($x0, $y0, $span) = @_;

    # Set orientation to 0 (vertical) or 1 (horizontal).
    my $orient = int rand 2;

    my ($x1, $y1) = ($x0, $y0);

    if ($orient) {
        $x1 += $span;
    }
    else {
        $y1 += $span;
    }

    return $orient, $x1, $y1;
}

sub _segment_intersection {
    # 0 - Intersection doesn't exist.
    # 1 - Intersection exists.
# NOTE: In Battleship, we only care about yes/no, but the
#       original code can tell much more:
    # 0 (was 2) - line segments are parallel
    # 0 (was 3) - line segments are collinear but do not overlap.
    # 4 - line segments are collinear and share an end point.
    # 5 - line segments are collinear and overlap.

    croak "segment_intersection needs 4 points\n" unless @_ == 8;
    my(
        $x0, $y0,  $x1, $y1,  # AB segment 1
        $x2, $y2,  $x3, $y3   # CD segment 2
    ) = @_;
#warn "[$x0, $y0]-[$x1, $y1], [$x2, $y2]-[$x3, $y3]\n";

    my $xba = $x1 - $x0;
    my $yba = $y1 - $y0;
    my $xdc = $x3 - $x2;
    my $ydc = $y3 - $y2;
    my $xca = $x2 - $x0;
    my $yca = $y2 - $y0;

    my $delta = $xba * $ydc - $yba * $xdc;
    my $t1 = $xca * $ydc - $yca * $xdc;
    my $t2 = $xca * $yba - $yca * $xba;

    if ($delta != 0) {
        my $u = $t1 / $delta;
        my $v = $t2 / $delta;

        # Two segments intersect (including at end points).
        return ($u <= 1 && $u >= 0 && $v <= 1 && $v >= 0) ? 1 : 0;
    }
    else {
        # AB & CD are parallel.
        return 0 if $t1 != 0 && $t2 != 0;
# NOTE:  We just care about yes/no, so this is the old way:
#        return 2 if $t1 != 0 && $t2 != 0;

        # When AB & CD are collinear...
        my ($a, $b, $c, $d);

        # If AB isn't a vertical line segment, project to x-axis.
        if ($x0 != $x1) {
            # < is min, > is max
            $a = $x0 < $x1 ? $x0 : $x1;
            $b = $x0 > $x1 ? $x0 : $x1;
            $c = $x2 < $x3 ? $x2 : $x3;
            $d = $x2 > $x3 ? $x2 : $x3;

            if ($d < $a || $c > $b) {
# NOTE:  We just care about yes/no.  The old way returns 3:
                return 0;#3;
            }
            elsif ($d == $a || $c == $b) {
                return 4;
            }
            else {
                return 5;
            }
        }
        # If AB is a vertical line segment, project to y-axis.
        else {
            # < is min, > is max
            $a = $y0 < $y1 ? $y0 : $y1;
            $b = $y0 > $y1 ? $y0 : $y1;
            $c = $y2 < $y3 ? $y2 : $y3;
            $d = $y2 > $y3 ? $y2 : $y3;

            if ($d < $a || $c > $b) {
# NOTE:  We just care about yes/no.  The old way returns 3:
                return 0;#3;
            }
            elsif ($d == $a || $c == $b) {
                return 4;
            }
            else {
                return 5;
            }
        }
    }
}

1;

__END__