view release on metacpan or  search on metacpan

lib/Game/Collisions.pm  view on Meta::CPAN

# 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.5';
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
{