File Coverage

blib/lib/Game/RaycastFOV.pm

Criterion	Covered	Total	%
statement	57	58	98.2
branch	17	18	94.4
condition	2	3	66.6
subroutine	11	11	100.0
pod	4	4	100.0
total	91	94	96.8

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

package Game::RaycastFOV;

our $VERSION = '2.00';

use strict;
use warnings;
use Exporter 'import';
use Math::Trig ':pi';
require XSLoader;

our @EXPORT_OK =
  qw(bypair bypairall cached_circle circle line raycast shadowcast 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
    ]
);

# shadowcast multipliers for transforming coordinates into other octants
our @mult = (
    [ 1, 0, 0,  -1, -1, 0,  0,  1 ],
    [ 0, 1, -1, 0,  0,  -1, 1,  0 ],
    [ 0, 1, 1,  0,  0,  -1, -1, 0 ],
    [ 1, 0, 0,  1,  -1, 0,  0,  -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 $octet (0 .. 7) {
        _shadowcast($startx, $starty, $bcb, $lcb, $rcb, 1, 1.0, 0.0, $radius,
            $mult[0][$octet], $mult[1][$octet], $mult[2][$octet], $mult[3][$octet]);
    }
}

sub _shadowcast {
    my ($startx, $starty, $bcb, $lcb, $rcb, $row, $light_start, $light_end,
        $radius, $xx, $xy, $yx, $yy)
      = @_;
    return if $light_start < $light_end;
    my $new_start = 0.0;
    my $blocked   = 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 }
            else {
                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)) {
                        $new_start = $rslope;
                        next;
                    } else {
                        $blocked     = 0;
                        $light_start = $new_start;
                    }
                } else {
                    if ($bcb->($curx, $cury) and $j < $radius) {
                        $blocked = 1;
                        _shadowcast(
                            $startx, $starty,      $bcb,    $lcb,    $rcb,
                            $j + 1,  $light_start, $lslope, $radius, $xx,
                            $xy,     $yx,          $yy
                        );
                        $new_start = $rslope;
                    }
                }
            }
        }
        last if $blocked;
    }
}

sub swing_circle (&$$$$) {
    my ($callback, $x, $y, $radius, $swing) = @_;
    my $angle = 0;
    my $rf    = 0.5 + int $radius;
    my %seen;
    while ($angle < pi2) {
        my $nx = $x + int($rf * cos $angle);
        my $ny = $y + int($rf * sin $angle);
        $callback->($nx, $ny) unless $seen{ $nx . ',' . $ny }++;
        $angle += $swing;
    }
}

1;
__END__