use Test::More tests => 3*(2*6 + 1);

use strict;
use warnings;

local $" = ',';

# Slope 1
{
    my $matcher = path_matcher({
        p1 => [0,0],
        p2 => [100,100],
    });
    # Points on edge of tolerance
    for ([0,20], [20,0], [40,60], [60,40], [80,100], [100,80]) {
        ok($matcher->(@$_), "slope 1: match [@$_]");
    }
    # Out of bounds
    for ([0,21], [21,0], [40,61], [61,40], [80,101], [101,80], [-1,20]
+) {
        ok(!$matcher->(@$_), "slope 1: not match [@$_]");
    }
}

# Slope 0
{
    my $matcher = path_matcher({
        p1 => [0,50],
        p2 => [100,50],
    });
    # Boundary cases
    for ([0,60], [0,40], [50,60], [50,40], [100,60], [100,40]) {
        ok($matcher->(@$_), "slope 0: match [@$_]");
    }
    # Out of bounds
    for ([0,61], [0,39], [50,61], [50,39], [100,61], [100,39], [-1,60]
+) {
        ok(!$matcher->(@$_), "slope 0: not match [@$_]");
    }
}

# Slope INF
{
    my $matcher = path_matcher({
        p1 => [50,0],
        p2 => [50,100],
    });
    # Boundary cases
    for ([40,0], [60,0], [40,50], [60,50], [40,100], [60,100]) {
        ok($matcher->(@$_), "slope INF: match [@$_]");
    }
    # Out of bounds
    for ([39,0], [61,0], [39,50], [61,50], [39,100], [61,100], [40,-1]
+) {
        ok(!$matcher->(@$_), "slope INF: not match [@$_]");
    }
}

###
### Begin Actual functionality

sub path_matcher {
    my ($args_ref) = @_;
    my $p1 = delete $args_ref->{p1} || [delete @$args_ref{qw(x1 y1)}];
    my $p2 = delete $args_ref->{p2} || [delete @$args_ref{qw(x2 y2)}];
    my $sigma = delete $args_ref->{sigma} // '10%';
    
    die "Unknown parameters" if keys %$args_ref;
    die "Points must be defined" if grep {! defined} (@$p1, @$p2);
    
    # Order by x and y
    ($p1, $p2) = sort {$a->[0] <=> $b->[0] || $a->[1] <=> $b->[1]} ($p
+1, $p2);

    my ($x1, $y1) = @$p1;
    my ($x2, $y2) = @$p2;

    # Solve y = m x + b
    my $dX = $x2 - $x1;
    my $dY = $y2 - $y1;
    my $m = $dX == 0 ? undef : $dY / $dX;
    my $b = $dX == 0 ? undef : $y1 - $m * $x1;
    
    # Sigma as a percentage of segment length
    if ($sigma =~ s/%//) {
        my $length = sqrt($dX ** 2 + $dY ** 2);
        $sigma *= $length / 100;
    }
    
    # Perpendicular M
    # M = -1 / m;
    # Y = M x + B
    my $M = ! defined $m ? 0 : $m == 0 ? undef : -1 / $m;
    
    # Anonymous sub to match multiple points.
    return sub {
        my ($x, $y) = @_;
        
        # Calculate [X,Y]: closest point on segment to [x,y]
        my ($X, $Y);
        
        # Vertical Line (constant x)
        if (! defined $m) {
            $X = $x1;
            $Y = $y;
            $Y = $y1 if $Y < $y1;
            $Y = $y2 if $Y > $y2;
        # Horizontal Line (constant y)
        } elsif ($m == 0) {
            $X = $x;
            $X = $x1 if $X < $x1;
            $X = $x2 if $X > $x2;
            $Y = $y1;
        # Regular line
        } else {
            my $B = $y - $M * $x;
            $X = ($B - $b) / ($m - $M);
            $Y = $m * $X + $b;
            ($X,$Y) = ($x1, $y1) if $X < $x1;
            ($X,$Y) = ($x2, $y2) if $X > $x2;
        }
        
        my $dist = sqrt(($x-$X) ** 2 + ($y-$Y) ** 2);
        
        return $dist <= $sigma;
    };
}
[download]