File Coverage

blib/lib/Game/Collisions.pm

Criterion	Covered	Total	%
statement	61	67	91.0
branch	11	12	91.6
condition	5	6	83.3
subroutine	12	13	92.3
pod	6	7	85.7
total	95	105	90.4

# Copyright (c) 2018  Timm Murray
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
#     * Redistributions of source code must retain the above copyright notice,
#       this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
package Game::Collisions;
$Game::Collisions::VERSION = '0.4';
use v5.14;
use warnings;
use List::Util ();

use Game::Collisions::AABB;

# ABSTRACT: Fast, pure Perl collision 2D detection


sub new
{
    my ($class) = @_;
    my $self = {
        root_aabb => undef,
        all_aabbs => {},
    };
    bless $self => $class;


    return $self;
}


sub make_aabb
{
    my ($self, $args) = @_;
    my $aabb = Game::Collisions::AABB->new( $args );
    $self->_add_aabb( $aabb );
    return $aabb;
}

sub get_collisions
{
    my ($self) = @_;
    my @aabbs_to_check = values %{ $self->{all_aabbs} };
    my @collisions;

    foreach my $aabb (@aabbs_to_check) {
        push @collisions => $self->get_collisions_for_aabb( $aabb );
    }

    return @collisions;
}

sub get_collisions_for_aabb
{
    my ($self, $aabb) = @_;
    return () if ! defined $self->{root_aabb};
    my @collisions;

    my @nodes_to_check = ($self->{root_aabb});
    while( @nodes_to_check ) {
        my $check_node = shift @nodes_to_check;

        if( $check_node->is_branch_node ) {
            my $left_node = $check_node->left_node;
            my $right_node = $check_node->right_node;

            if( defined $left_node && $left_node->does_collide( $aabb ) ) {
                push @nodes_to_check, $left_node;
            }
            if( defined $right_node && $right_node->does_collide( $aabb ) ) {
                push @nodes_to_check, $right_node;
            }
        }
        else {
            # We already know it collided, since it wouldn't be added
            # to @nodes_to_check otherwise.
            push @collisions, [ $aabb, $check_node ];
        }
    }

    return @collisions;
}

sub get_collisions_for_aabb_bruteforce
{
    my ($self, $aabb) = @_;
    my @aabbs = values %{ $self->{all_aabbs} };

    my @collisions = grep { $_->does_collide( $aabb ) } @aabbs;
    return @collisions;
}

sub rebalance_tree
{
    my ($self) = @_;
    my @aabbs = values %{ $self->{all_aabbs} };
    $self->{all_aabbs} = {};

    my $new_root = $self->_new_meta_aabb({
        x => 0,
        y => 0,
        length => 1,
        height => 1,
    });
    $self->{root_aabb} = $new_root;
    $self->_add_aabb( $_ ) for @aabbs;

    return;
}

sub root
{
    my ($self) = @_;
    return $self->{root_aabb};
}


sub _add_aabb
{
    my ($self, $new_node) = @_;

    if(! defined $self->{root_aabb} ) {
        $self->{root_aabb} = $new_node;
    }
    else {
        my $new_root = $self->{root_aabb}->insert_new_aabb( $new_node );
        $self->{root_aabb} = $new_root if defined $new_root;
    }

    $self->{all_aabbs}{"$new_node"} = $new_node;
    return;
}

sub _new_meta_aabb
{
    my ($self, $args) = @_;
    my $aabb = Game::Collisions::AABB->new( $args );
    return $aabb;
}


1;
__END__