File Coverage

blib/lib/Game/RaycastFOV.pm

Criterion	Covered	Total	%
statement	49	50	98.0
branch	14	16	87.5
condition	2	3	66.6
subroutine	11	11	100.0
pod	4	4	100.0
total	80	84	95.2

# -*- Perl -*-
#
# raycast and shadowcast field-of-view and related routines (see also
# the *.xs file)

package Game::RaycastFOV;

our $VERSION = '2.02';

use strict;
use warnings;
use Math::Trig ':pi';

require XSLoader;

use base qw(Exporter);
our @EXPORT_OK =
  qw(bypair bypairall cached_circle circle line raycast shadowcast sub_circle swing_circle %circle_points);

XSLoader::load( 'Game::RaycastFOV', $VERSION );

# precomputed via swing_circle(). only up to 11 due to 80x24 terminal.
# can be added to or changed as desired by caller. one could for example
# have a 0 radius that only fills in the compass directions adjacent or
# other shapes suitable to the need at hand
#
# NOTE these may change to be more efficient at doing a minimally
# complete raycast instead of the complete exterior circle (which
# probably creates more raycasts than may be necessary)
our %circle_points = (
    1 => [ 1, 0, 1, 1, 0, 1, -1, 1, -1, 0, -1, -1, 0, -1, 1, -1 ],
    2 => [
        2,  0, 2,  1,  1,  1,  1,  2,  0, 2,  -1, 2,  -1, 1,  -2, 1,
        -2, 0, -2, -1, -1, -1, -1, -2, 0, -2, 1,  -2, 1,  -1, 2,  -1
    ],
    3 => [
        3,  0,  3,  1,  2,  1,  2,  2,  1,  2,  1,  3,  0,  3,  -1, 3,
        -1, 2,  -2, 2,  -2, 1,  -3, 1,  -3, 0,  -3, -1, -2, -1, -2, -2,
        -1, -2, -1, -3, 0,  -3, 1,  -3, 1,  -2, 2,  -2, 2,  -1, 3,  -1
    ],
    4 => [
        4,  0,  4,  1,  4,  2,  3,  2,  3,  3,  2,  3,  2,  4,  1,  4,
        0,  4,  -1, 4,  -2, 4,  -2, 3,  -3, 3,  -3, 2,  -4, 2,  -4, 1,
        -4, 0,  -4, -1, -4, -2, -3, -2, -3, -3, -2, -3, -2, -4, -1, -4,
        0,  -4, 1,  -4, 2,  -4, 2,  -3, 3,  -3, 3,  -2, 4,  -2, 4,  -1
    ],
    5 => [
        5,  0,  5,  1,  5,  2,  4,  2,  4,  3,  3,  3,  3,  4,  2,  4,
        2,  5,  1,  5,  0,  5,  -1, 5,  -2, 5,  -2, 4,  -3, 4,  -3, 3,
        -4, 3,  -4, 2,  -5, 2,  -5, 1,  -5, 0,  -5, -1, -5, -2, -4, -2,
        -4, -3, -3, -3, -3, -4, -2, -4, -2, -5, -1, -5, 0,  -5, 1,  -5,
        2,  -5, 2,  -4, 3,  -4, 3,  -3, 4,  -3, 4,  -2, 5,  -2, 5,  -1
    ],
    6 => [
        6,  0,  6,  1,  6,  2,  5,  2,  5,  3,  5,  4,  4,  4,  4,  5,
        3,  5,  2,  5,  2,  6,  1,  6,  0,  6,  -1, 6,  -2, 6,  -2, 5,
        -3, 5,  -4, 5,  -4, 4,  -5, 4,  -5, 3,  -5, 2,  -6, 2,  -6, 1,
        -6, 0,  -6, -1, -6, -2, -5, -2, -5, -3, -5, -4, -4, -4, -4, -5,
        -3, -5, -2, -5, -2, -6, -1, -6, 0,  -6, 1,  -6, 2,  -6, 2,  -5,
        3,  -5, 4,  -5, 4,  -4, 5,  -4, 5,  -3, 5,  -2, 6,  -2, 6,  -1
    ],
    7 => [
        7,  0,  7,  1,  7,  2,  6,  2,  6,  3,  6,  4,  5,  4,  5,  5,
        4,  5,  4,  6,  3,  6,  2,  6,  2,  7,  1,  7,  0,  7,  -1, 7,
        -2, 7,  -2, 6,  -3, 6,  -4, 6,  -4, 5,  -5, 5,  -5, 4,  -6, 4,
        -6, 3,  -6, 2,  -7, 2,  -7, 1,  -7, 0,  -7, -1, -7, -2, -6, -2,
        -6, -3, -6, -4, -5, -4, -5, -5, -4, -5, -4, -6, -3, -6, -2, -6,
        -2, -7, -1, -7, 0,  -7, 1,  -7, 2,  -7, 2,  -6, 3,  -6, 4,  -6,
        4,  -5, 5,  -5, 5,  -4, 6,  -4, 6,  -3, 6,  -2, 7,  -2, 7,  -1
    ],
    8 => [
        8,  0,  8,  1,  8,  2,  7,  2,  7,  3,  7,  4,  6,  4,  6,  5,
        6,  6,  5,  6,  4,  6,  4,  7,  3,  7,  2,  7,  2,  8,  1,  8,
        0,  8,  -1, 8,  -2, 8,  -2, 7,  -3, 7,  -4, 7,  -4, 6,  -5, 6,
        -6, 6,  -6, 5,  -6, 4,  -7, 4,  -7, 3,  -7, 2,  -8, 2,  -8, 1,
        -8, 0,  -8, -1, -8, -2, -7, -2, -7, -3, -7, -4, -6, -4, -6, -5,
        -6, -6, -5, -6, -4, -6, -4, -7, -3, -7, -2, -7, -2, -8, -1, -8,
        0,  -8, 1,  -8, 2,  -8, 2,  -7, 3,  -7, 4,  -7, 4,  -6, 5,  -6,
        6,  -6, 6,  -5, 6,  -4, 7,  -4, 7,  -3, 7,  -2, 8,  -2, 8,  -1
    ],
    9 => [
        9,  0,  9,  1,  9,  2,  9,  3,  8,  3,  8,  4,  8,  5,  7,  5,  7,  6,
        6,  6,  6,  7,  5,  7,  5,  8,  4,  8,  3,  8,  3,  9,  2,  9,  1,  9,
        0,  9,  -1, 9,  -2, 9,  -3, 9,  -3, 8,  -4, 8,  -5, 8,  -5, 7,  -6, 7,
        -6, 6,  -7, 6,  -7, 5,  -8, 5,  -8, 4,  -8, 3,  -9, 3,  -9, 2,  -9, 1,
        -9, 0,  -9, -1, -9, -2, -9, -3, -8, -3, -8, -4, -8, -5, -7, -5, -7, -6,
        -6, -6, -6, -7, -5, -7, -5, -8, -4, -8, -3, -8, -3, -9, -2, -9, -1, -9,
        0,  -9, 1,  -9, 2,  -9, 3,  -9, 3,  -8, 4,  -8, 5,  -8, 5,  -7, 6,  -7,
        6,  -6, 7,  -6, 7,  -5, 8,  -5, 8,  -4, 8,  -3, 9,  -3, 9,  -2, 9,  -1
    ],
    10 => [
        10,  0,   10,  1,   10,  2,   10,  3,   9,   3,   9,   4,   9,   5,
        8,   5,   8,   6,   7,   6,   7,   7,   6,   7,   6,   8,   5,   8,
        5,   9,   4,   9,   3,   9,   3,   10,  2,   10,  1,   10,  0,   10,
        -1,  10,  -2,  10,  -3,  10,  -3,  9,   -4,  9,   -5,  9,   -5,  8,
        -6,  8,   -6,  7,   -7,  7,   -7,  6,   -8,  6,   -8,  5,   -9,  5,
        -9,  4,   -9,  3,   -10, 3,   -10, 2,   -10, 1,   -10, 0,   -10, -1,
        -10, -2,  -10, -3,  -9,  -3,  -9,  -4,  -9,  -5,  -8,  -5,  -8,  -6,
        -7,  -6,  -7,  -7,  -6,  -7,  -6,  -8,  -5,  -8,  -5,  -9,  -4,  -9,
        -3,  -9,  -3,  -10, -2,  -10, -1,  -10, 0,   -10, 1,   -10, 2,   -10,
        3,   -10, 3,   -9,  4,   -9,  5,   -9,  5,   -8,  6,   -8,  6,   -7,
        7,   -7,  7,   -6,  8,   -6,  8,   -5,  9,   -5,  9,   -4,  9,   -3,
        10,  -3,  10,  -2,  10,  -1
    ],
    11 => [
        11,  0,   11,  1,   11,  2,   11,  3,   10,  3,   10,  4,   10,  5,
        9,   5,   9,   6,   9,   7,   8,   7,   8,   8,   7,   8,   7,   9,
        6,   9,   5,   9,   5,   10,  4,   10,  3,   10,  3,   11,  2,   11,
        1,   11,  0,   11,  -1,  11,  -2,  11,  -3,  11,  -3,  10,  -4,  10,
        -5,  10,  -5,  9,   -6,  9,   -7,  9,   -7,  8,   -8,  8,   -8,  7,
        -9,  7,   -9,  6,   -9,  5,   -10, 5,   -10, 4,   -10, 3,   -11, 3,
        -11, 2,   -11, 1,   -11, 0,   -11, -1,  -11, -2,  -11, -3,  -10, -3,
        -10, -4,  -10, -5,  -9,  -5,  -9,  -6,  -9,  -7,  -8,  -7,  -8,  -8,
        -7,  -8,  -7,  -9,  -6,  -9,  -5,  -9,  -5,  -10, -4,  -10, -3,  -10,
        -3,  -11, -2,  -11, -1,  -11, 0,   -11, 1,   -11, 2,   -11, 3,   -11,
        3,   -10, 4,   -10, 5,   -10, 5,   -9,  6,   -9,  7,   -9,  7,   -8,
        8,   -8,  8,   -7,  9,   -7,  9,   -6,  9,   -5,  10,  -5,  10,  -4,
        10,  -3,  11,  -3,  11,  -2,  11,  -1
    ]
);

# the lack of checks are for speed, use at your own risk
sub cached_circle (&$$$) {
    my ( $callback, $x, $y, $radius ) = @_;
    # process all the points on the assumption that the callback will
    # abort say line drawing should that wander outside a level map
    bypairall( sub { $callback->( $x + $_[0], $y + $_[1] ) },
        @{ $circle_points{$radius} } );
}

sub raycast {
    my ( $circle_cb, $line_cb, $x, $y, @rest ) = @_;
    $circle_cb->( sub { line( $line_cb, $x, $y, $_[0], $_[1] ) }, $x, $y, @rest );
}

# http://www.roguebasin.com/index.php?title=FOV_using_recursive_shadowcasting
# or in particular the Java and Ruby implementations
sub shadowcast {
    my ( $startx, $starty, $radius, $bcb, $lcb, $rcb ) = @_;
    $lcb->( $startx, $starty, 0, 0 );
    for my $mult (
        [ 1,  0,  0,  1 ],
        [ 0,  1,  1,  0 ],
        [ 0,  -1, 1,  0 ],
        [ -1, 0,  0,  1 ],
        [ -1, 0,  0,  -1 ],
        [ 0,  -1, -1, 0 ],
        [ 0,  1,  -1, 0 ],
        [ 1,  0,  0,  -1 ]
    ) {
        _shadowcast( $startx, $starty, $radius, $bcb, $lcb, $rcb, 1, 1.0, 0.0, @$mult );
    }
}

sub _shadowcast {
    my ( $startx, $starty, $radius, $bcb, $lcb, $rcb, $row, $light_start,
        $light_end, $xx, $xy, $yx, $yy )
      = @_;
    my $blocked   = 0;
    my $new_start = 0.0;
    for my $j ( $row .. $radius ) {
        my $dy = -$j;
        for my $dx ( $dy .. 0 ) {
            my $rslope = ( $dx + 0.5 ) / ( $dy - 0.5 );
            my $lslope = ( $dx - 0.5 ) / ( $dy + 0.5 );
            if    ( $light_start < $rslope ) { next }
            elsif ( $light_end > $lslope )   { last }
            my $curx = $startx + $dx * $xx + $dy * $xy;
            my $cury = $starty + $dx * $yx + $dy * $yy;
            $lcb->( $curx, $cury, $dx, $dy ) if $rcb->( $dx, $dy );
            if ($blocked) {
                if ( $bcb->( $curx, $cury, $dx, $dy ) ) {
                    $new_start = $rslope;
                    next;
                } else {
                    $blocked     = 0;
                    $light_start = $new_start;
                }
            } else {
                if ( $bcb->( $curx, $cury, $dx, $dy ) and $j < $radius ) {
                    $blocked = 1;
                    _shadowcast(
                        $startx, $starty, $radius,      $bcb,    $lcb,
                        $rcb,    $j + 1,  $light_start, $lslope, $xx,
                        $xy,     $yx,     $yy
                    ) unless $light_start < $lslope;
                    $new_start = $rslope;
                }
            }
        }
        last if $blocked;
    }
}

sub swing_circle(&$$$$) {
    push @_, 0, pi2;
    goto &sub_circle;
}

# for reference; converted to XS in version 2.02 with the following
# matching and updated code not being quite so stupid about rounding
# ints and thus not needing a plus 0.5 fudge factor
#sub swing_circle (&$$$$) {
#    my ( $callback, $x, $y, $radius, $swing ) = @_;
#    my $angle = 0;
#    my %seen;
#    while ( $angle < pi2 ) {
#        my $nx = $x + sprintf( "%.0f", $radius * cos $angle );
#        my $ny = $y + sprintf( "%.0f", $radius * sin $angle );
#        $callback->( $nx, $ny ) unless $seen{ $nx . ',' . $ny }++;
#        $angle += $swing;
#    }
#}

1;
__END__