Math-Polygon-1.11/ 0000755 0001750 0000144 00000000000 15005156515 014473 5 ustar 00markov users 0000000 0000000 Math-Polygon-1.11/t/ 0000755 0001750 0000144 00000000000 15005156515 014736 5 ustar 00markov users 0000000 0000000 Math-Polygon-1.11/t/14inside.t 0000644 0001750 0000144 00000002632 15005156512 016543 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 19;
use lib '../lib';
use Math::Polygon::Calc;
my @p = ([0,0], [1,1], [-2,1], [-2,-2], [-1,-1], [0,-2], [1,-1], [0,0]);
ok( polygon_contains_point([-1,0], @p), '(-1,0)');
ok( polygon_contains_point([0,-1], @p), '(0,-1)');
ok(!polygon_contains_point([10,10], @p), '(10,10)');
ok(!polygon_contains_point([1,0], @p), '(1,0)');
ok(!polygon_contains_point([-1,-1.5], @p), '(-1,-1.5)');
# On the edge
ok( polygon_contains_point([0,0], @p), '(0,0)');
ok( polygon_contains_point([-1,-1], @p), '(-1,-1)');
@p = ([1,1],[1,3],[4,3],[4,1],[1,1]);
ok( polygon_contains_point([3,1], @p), '2nd (3,1)'); # on vertical edge
ok( polygon_contains_point([1,1], @p), '2nd (1,1)');
ok( polygon_contains_point([1,3], @p), '2nd (1,3)');
ok( polygon_contains_point([4,3], @p), '2nd (4,3)');
ok( polygon_contains_point([4,1], @p), '2nd (4,1)');
# rt.cpan.org#118030 On edge
@p = ([400, 0], [500, 0], [600, 100], [600, 900], [500, 1000],
[400, 1000], [400, 0]);
ok( polygon_contains_point([400, 400], @p), 'on edge 1');
ok( polygon_contains_point([550, 50], @p), 'on edge 2');
ok( polygon_contains_point([551, 51], @p), 'on edge 2b');
ok( polygon_contains_point([552, 52], @p), 'on edge 2c');
ok( polygon_contains_point([550, 950], @p), 'on edge 3');
ok( polygon_contains_point([600, 300], @p), 'on edge 4');
ok( polygon_contains_point([450,1000], @p), 'on edge 5');
Math-Polygon-1.11/t/91surface.t 0000644 0001750 0000144 00000001574 15005156512 016731 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 16;
use lib '../lib';
use Math::Polygon::Surface;
my @p = ([0,0],[1,1],[0,2],[0,0]);
my @q = ([1,1],[0,2],[0,0],[1,1]); # rotated left 1
# Instantiate from array
my $s = Math::Polygon::Surface->new(\@p);
ok(defined $s);
isa_ok($s, 'Math::Polygon::Surface');
my $p = $s->outer;
ok(defined $p);
isa_ok($p, 'Math::Polygon');
cmp_ok($p->nrPoints, '==', 4);
my @i = $s->inner;
cmp_ok(scalar(@i), '==', 0);
# With inner
my $s2 = Math::Polygon::Surface->new(\@p, \@q, \@q);
ok(defined $s2);
isa_ok($s2, 'Math::Polygon::Surface');
my $p2 = $s2->outer;
ok(defined $p2);
isa_ok($p2, 'Math::Polygon');
cmp_ok($p2->nrPoints, '==', 4);
my @i2 = $s2->inner;
cmp_ok(scalar(@i2), '==', 2);
isa_ok($i2[0], 'Math::Polygon');
cmp_ok($i2[0]->nrPoints, '==', 4);
isa_ok($i2[1], 'Math::Polygon');
cmp_ok($i2[1]->nrPoints, '==', 4);
Math-Polygon-1.11/t/50chainhull.t 0000644 0001750 0000144 00000000677 15005156512 017246 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
# test ::Convex::chainHull_2D;
use strict;
use warnings;
use Test::More tests => 2;
use Math::Polygon::Convex qw/chainHull_2D/;
use Math::Polygon;
# Correct results according to Jari Turkia
my @q = ( [9,7], [-1,1], [-6,7], [-8,7], [8,-7], [-3,2]
, [1,-5], [-10,3], [7,-8], [-10,8]);
my $p = chainHull_2D @q;
isa_ok($p, 'Math::Polygon');
is($p->string, "[-10,3], [1,-5], [7,-8], [8,-7], [9,7], [-10,8], [-10,3]");
Math-Polygon-1.11/t/12beauty.t 0000644 0001750 0000144 00000005105 15005156512 016555 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 24;
use lib '../lib', 'lib';
use Math::Polygon::Calc;
sub compare_poly($$$)
{ my ($got, $want, $text) = @_;
cmp_ok(scalar(@$got), '==', scalar(@$want), "nr points, $text");
return unless @$want;
my $gotp = polygon_string polygon_start_minxy @$got;
my $wantp = polygon_string polygon_start_minxy @$want;
is($gotp, $wantp);
}
#
# p0 is a single point, not a poly
#
my @p0 = ( [3,4] );
my @cp0a = polygon_beautify @p0;
compare_poly(\@cp0a, [], "single point");
#
# p1 is a line, also not a poly
#
my @p1 = ([1,2],[3,5],[1,2]);
my @cp1a = polygon_beautify @p1;
compare_poly(\@cp1a, [], "line");
#
# p2 is a triangle
#
my @p2 = ( [0,0],[1,2],[2,0],[0,0] );
my @cp2a = polygon_beautify @p2;
compare_poly(\@cp2a, \@p2, "triangle");
#
# p3 is traingle p2 with x-spike
#
my @p3 = ( [0,0],[1,2],[3,2],[1,2],[2,0],[0,0] );
my @cp3a = polygon_beautify @p3;
compare_poly(\@cp3a, \@p3, "triangle with spike, no despike");
my @cp3b = polygon_beautify {remove_spikes => 1}, @p3;
compare_poly(\@cp3b, \@p2, "triangle with spike");
#
# p4 is traingle p2 with y-spike
#
my @p4 = ( [0,0],[1,2],[1,4],[1,2],[2,0],[0,0] );
my @cp4a = polygon_beautify @p4;
compare_poly(\@cp4a, \@p4, "triangle with spike, no despike");
my @cp4b = polygon_beautify {remove_spikes => 1}, @p4;
compare_poly(\@cp4b, \@p2, "triangle with spike");
#
# p5 is traingle p2 with combined x+y-spike
#
my @p5 = ( [0,0],[1,2],[1,4],[3,4],[1,4],[1,2],[2,0],[0,0] );
my @cp5a = polygon_beautify @p5;
compare_poly(\@cp5a, \@p5, "triangle with spike, no despike");
my @cp5b = polygon_beautify {remove_spikes => 1}, @p5;
compare_poly(\@cp5b, \@p2, "triangle with spike");
#
# p6 is square c(2x2) with extra point at each side
#
my @c = ( [0,0],[0,2],[2,2],[2,0],[0,0] );
my @p6 = ( [0,0],[0,1],[0,2],[1,2],[2,2],[2,1],[2,0],[1,0],[0,0] );
my @cp6a = polygon_beautify @p6;
compare_poly(\@cp6a, \@c, "square with extra points");
#
# p7 has multiple points at one side
#
my @p7 = ( [0,0],[0,0.5],[0,1],[0,1.5],[0,2],[2,2],[2,0],[0,0] );
my @cp7a = polygon_beautify @p7;
compare_poly(\@cp7a, \@c, "square with many superfluous points");
#
# p8 has multiple points mixed in a side
#
my @p8 = ( [0,0],[0,1.5],[0,1],[0,0.5],[0,2],[2,2],[2,0],[0,0] );
my @cp8a = polygon_beautify @p8;
compare_poly(\@cp8a, \@c, "square with mixed superfluous points");
#
# p9 contains loads of doubles
#
my @p9 = ( [0,0], [0,0], [0,0], [1,2],[1,2], [3,2],[3,2], [0,0] );
my @cp9a = polygon_beautify @p9;
compare_poly(\@cp9a, [[0,0],[1,2],[3,2],[0,0]], "doubles");
Math-Polygon-1.11/t/13rot.t 0000644 0001750 0000144 00000000726 15005156512 016075 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 11;
use lib '../lib';
use Math::Polygon::Calc;
my @p = polygon_start_minxy [0,0], [1,1], [-2,1], [-2,-2], [0,0];
cmp_ok(scalar(@p),'==',5);
cmp_ok($p[0][0],'==',-2);
cmp_ok($p[0][1],'==',-2);
cmp_ok($p[1][0],'==',0);
cmp_ok($p[1][1],'==',0);
cmp_ok($p[2][0],'==',1);
cmp_ok($p[2][1],'==',1);
cmp_ok($p[3][0],'==',-2);
cmp_ok($p[3][1],'==',1);
cmp_ok($p[4][0],'==',-2);
cmp_ok($p[4][1],'==',-2);
Math-Polygon-1.11/t/43grid.t 0000644 0001750 0000144 00000001172 15005156512 016215 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 4;
use lib '../lib';
use Math::Polygon::Transform;
use Math::Polygon::Calc qw/polygon_string/;
my @p = ( [1,1], [2.45,2.55], [-1.45, -1.55] );
is( polygon_string(polygon_grid raster => 0, @p)
, "[1,1], [2.45,2.55], [-1.45,-1.55]"
, "identity"
);
is( polygon_string(polygon_grid @p)
, "[1,1], [2,3], [-1,-2]"
, "grid 1"
);
is( polygon_string(polygon_grid raster => 2.5, @p)
, "[0,0], [2.5,2.5], [-2.5,-2.5]"
, "grid 2.5"
);
is( polygon_string(polygon_grid raster => 0.25, @p)
, "[1,1], [2.5,2.5], [-1.5,-1.5]"
, "grid 0.5"
);
Math-Polygon-1.11/t/40resize.t 0000644 0001750 0000144 00000002072 15005156512 016566 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 7;
use lib '../lib';
use Math::Polygon::Transform;
use Math::Polygon::Calc qw/polygon_string/;
my @p = ([0,0], [1,1], [-2,1], [-2,-2], [0,0]);
is( polygon_string(polygon_resize @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity'
);
is( polygon_string(polygon_resize xscale => 3, @p)
, "[0,0], [3,1], [-6,1], [-6,-2], [0,0]"
, 'xscale 3'
);
is( polygon_string(polygon_resize yscale => 4, @p)
, "[0,0], [1,4], [-2,4], [-2,-8], [0,0]"
, 'yscale 4'
);
is( polygon_string(polygon_resize xscale=>3, yscale=>4, @p)
, "[0,0], [3,4], [-6,4], [-6,-8], [0,0]"
, 'x-yscale 3-4'
);
is( polygon_string(polygon_resize scale => 5, @p)
, "[0,0], [5,5], [-10,5], [-10,-10], [0,0]"
, 'scale 5'
);
is( polygon_string(polygon_resize center => [100,100], @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity with center'
);
is( polygon_string(polygon_resize center => [1,1], scale => 2, @p)
, "[-1,-1], [1,1], [-5,1], [-5,-5], [-1,-1]"
, 'scale 2 with center'
);
Math-Polygon-1.11/t/31clipl.t 0000644 0001750 0000144 00000004576 15005156512 016403 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 132;
use lib '../lib';
use Math::Polygon::Clip;
sub compare_clip($$$)
{ my ($got, $want, $text) = @_;
cmp_ok(scalar(@$got), '==', scalar(@$want), "nr fragments, $text");
for(my $i = 0; $i < @$got; $i++)
{ my $g = $got->[$i];
my $w = $want->[$i];
cmp_ok(scalar(@$g), '==', scalar(@$w), "points in fragment $i");
for(my $j=0; $j < @$g; $j++)
{ cmp_ok($g->[$j][0], '==', $w->[$j][0], "X $i,$j");
cmp_ok($g->[$j][1], '==', $w->[$j][1], "Y $i,$j");
}
}
}
#
# p0 is a single point
#
my @p0 = ( [3,4] );
my @cp0a = polygon_line_clip [0,0, 8,8], @p0;
compare_clip(\@cp0a, [ \@p0 ],"single point inside");
my @cp0b = polygon_line_clip [0,0, 1,1], @p0;
compare_clip(\@cp0b, [ ], "single point outside");
#
# p1 is an octagon, with center .5,.5, sides of 1
#
my @p1 = ( [0,2], [1,2], [2,1], [2,0], [1,-1], [0,-1], [-1,0], [-1,1], [0,2]);
my @cp1a = polygon_line_clip [-4,-4, 4,4], @p1;
compare_clip(\@cp1a, [ \@p1 ], "whole outside");
my @cp1b = polygon_line_clip [0,0, 1,1], @p1;
compare_clip(\@cp1b, [ ], "whole inside");
my @cp1c = polygon_line_clip [0,0,3,3], @p1;
compare_clip(\@cp1c, [ [[0,2],[1,2],[2,1],[2,0]] ], "one piece");
my @cp1d = polygon_line_clip [-4,-0.5, 4,1.5], @p1;
compare_clip(\@cp1d, [ [[1.5,1.5],[2,1],[2,0],[1.5,-0.5]]
, [[-0.5,-0.5],[-1,0],[-1,1],[-0.5,1.5]]
], "two pieces");
my @cp1e = polygon_line_clip [-4,-0.5, 4,1.5], reverse(@p1);
compare_clip(\@cp1e, [ [[-0.5,1.5],[-1,1],[-1,0],[-0.5,-0.5]]
, [[1.5,-0.5],[2,0],[2,1],[1.5,1.5]]
], "two pieces reverse");
my @cp1f = polygon_line_clip [-0.5,-1, 1.5,4], @p1;
compare_clip(\@cp1f, [ [[-0.5,1.5],[0,2],[1,2],[1.5,1.5]]
, [[1.5,-0.5],[1,-1],[0,-1],[-0.5,-0.5]]
], "two glued pieces");
my @cp1g = polygon_line_clip [-0.5,-4, 1.5,4], reverse(@p1);
compare_clip(\@cp1g, [ [[1.5,1.5],[1,2],[0,2],[-0.5,1.5]]
, [[-0.5,-0.5],[0,-1],[1,-1],[1.5,-0.5]]
], "two glued pieces reverse");
#
# p2 is a weird polygon
#
my @p2 = ( [0,1], [4,2], [3,1], [3,0], [2,1], [0,-3], [0,1] );
my @cp2a = polygon_line_clip [1.5,0.5, 3.5,2], @p2;
compare_clip(\@cp2a, [ [[1.5,1.375],[3.5,1.875]]
, [[3.5,1.5],[3,1],[3,0.5]]
, [[2.5,0.5],[2,1],[1.75,0.5]]
], "complex cut");
Math-Polygon-1.11/t/41move.t 0000644 0001750 0000144 00000001064 15005156512 016234 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 3;
use lib '../lib';
use Math::Polygon::Transform;
use Math::Polygon::Calc qw/polygon_string/;
my @p = ([0,0], [1,1], [-2,1], [-2,-2], [0,0]);
is( polygon_string(polygon_move @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity'
);
is( polygon_string(polygon_move dx => 0, dy => 0, @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity'
);
is( polygon_string(polygon_move dx => 1, dy => -1, @p)
, "[1,-1], [2,0], [-1,0], [-1,-3], [1,-1]"
, 'move 1,-1'
);
Math-Polygon-1.11/t/42rotate.t 0000644 0001750 0000144 00000002145 15005156512 016566 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 6;
use lib '../lib';
use Math::Polygon::Transform qw/polygon_rotate/;
use Math::Polygon::Calc qw/polygon_string polygon_format/;
my @p = ([0,0], [1,1], [-2,1], [-2,-2], [0,0]);
# format fights rounding errors
sub round($) { my $x = sprintf "%.4f", $_[0]; $x =~ s/\.?0+$//; $x }
sub rotate(@) { polygon_format \&round, polygon_rotate @_ }
is( polygon_string(rotate degrees => 0, @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity'
);
is( polygon_string(rotate radians => 0, @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity'
);
is( polygon_string(rotate degrees => 0, center => [0,0], @p)
, "[0,0], [1,1], [-2,1], [-2,-2], [0,0]"
, 'identity'
);
is( polygon_string(rotate degrees => +90, @p)
, "[0,0], [1,-1], [1,2], [-2,2], [0,0]"
, 'rotate +90'
);
is( polygon_string(rotate degrees => -90, @p)
, "[0,0], [-1,1], [-1,-2], [2,-2], [0,0]"
, 'rotate -90'
);
is( polygon_string(rotate degrees => -90, center => [3,4], @p)
, "[7,1], [6,2], [6,-1], [9,-1], [7,1]"
, 'rotate 90 around [3,4]'
);
Math-Polygon-1.11/t/30cross.t 0000644 0001750 0000144 00000006251 15005156512 016420 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 68;
use lib '../lib';
use Math::Polygon::Clip;
# crossing square (-1,-1)(2,2)
# name p[0-9]a is in the reverse direction of p[0-9]b
my $bb0 = [-1,-1,2,2];
# west
my @p0a = Math::Polygon::Clip::_cross_x(-1, [-2,1], [1,1]);
cmp_ok(@p0a, '==', 1);
cmp_ok($p0a[0][0], '==', -1);
cmp_ok($p0a[0][1], '==', 1);
my @p0b = Math::Polygon::Clip::_cross_x(-1, [1,1], [-2,1]);
cmp_ok(@p0b, '==', 1);
cmp_ok($p0b[0][0], '==', -1);
cmp_ok($p0b[0][1], '==', 1);
# north
my @p1a = Math::Polygon::Clip::_cross_y(2, [1,1], [1,3]);
cmp_ok(@p1a, '==', 1);
cmp_ok($p1a[0][0], '==', 1);
cmp_ok($p1a[0][1], '==', 2);
my @p1b = Math::Polygon::Clip::_cross_y(2, [1,3], [1,1]);
cmp_ok(@p1b, '==', 1);
cmp_ok($p1b[0][0], '==', 1);
cmp_ok($p1b[0][1], '==', 2);
# east
my @p2a = Math::Polygon::Clip::_cross_x(2, [1,0], [3,0]);
cmp_ok(@p2a, '==', 1);
cmp_ok($p2a[0][0], '==', 2);
cmp_ok($p2a[0][1], '==', 0);
my @p2b = Math::Polygon::Clip::_cross_x(2, [3,0], [1,0]);
cmp_ok(@p2b, '==', 1);
cmp_ok($p2b[0][0], '==', 2);
cmp_ok($p2b[0][1], '==', 0);
# south
my @p3a = Math::Polygon::Clip::_cross_y(-1, [1,0], [1,-2]);
cmp_ok(@p3a, '==', 1);
cmp_ok($p3a[0][0], '==', 1);
cmp_ok($p3a[0][1], '==', -1);
my @p3b = Math::Polygon::Clip::_cross_y(-1, [1,0], [1,-2]);
cmp_ok(@p3b, '==', 1);
cmp_ok($p3b[0][0], '==', 1);
cmp_ok($p3b[0][1], '==', -1);
# via _cross
my @p4a = Math::Polygon::Clip::_cross($bb0, [-2,1], [1,1]);
cmp_ok(@p4a, '==', 1);
cmp_ok($p4a[0][0], '==', -1);
cmp_ok($p4a[0][1], '==', 1);
my @p4b = Math::Polygon::Clip::_cross($bb0, [1,1], [-2,1]);
cmp_ok(@p4b, '==', 1);
cmp_ok($p4b[0][0], '==', -1);
cmp_ok($p4b[0][1], '==', 1);
#
# Cross 2 at once
#
# west-east
my @p5a = Math::Polygon::Clip::_cross($bb0, [-2,1], [3,1]);
cmp_ok(@p5a, '==', 2);
cmp_ok($p5a[0][0], '==', -1);
cmp_ok($p5a[0][1], '==', 1);
cmp_ok($p5a[1][0], '==', 2);
cmp_ok($p5a[1][1], '==', 1);
# east-west
my @p5b = Math::Polygon::Clip::_cross($bb0, [3,1], [-2,1]);
cmp_ok(@p5b, '==', 2);
cmp_ok($p5b[0][0], '==', 2);
cmp_ok($p5b[0][1], '==', 1);
cmp_ok($p5b[1][0], '==', -1);
cmp_ok($p5b[1][1], '==', 1);
# north-south
my @p6a = Math::Polygon::Clip::_cross($bb0, [-1,5], [2,-4]);
cmp_ok(@p6a, '==', 2);
cmp_ok($p6a[0][0], '==', 0);
cmp_ok($p6a[0][1], '==', 2);
cmp_ok($p6a[1][0], '==', 1);
cmp_ok($p6a[1][1], '==', -1);
# south-north
my @p6b = Math::Polygon::Clip::_cross($bb0, [2,-4], [-1,5]);
cmp_ok(@p6b, '==', 2);
cmp_ok($p6b[0][0], '==', 1);
cmp_ok($p6b[0][1], '==', -1);
cmp_ok($p6b[1][0], '==', 0);
cmp_ok($p6b[1][1], '==', 2);
# west-south
my @p7a = Math::Polygon::Clip::_cross($bb0, [-2,3], [8,-2]);
cmp_ok(@p7a, '==', 4);
cmp_ok($p7a[0][0], '==', -1);
cmp_ok($p7a[0][1], '==', 2.5);
cmp_ok($p7a[1][0], '==', 0);
cmp_ok($p7a[1][1], '==', 2);
cmp_ok($p7a[2][0], '==', 2);
cmp_ok($p7a[2][1], '==', 1);
cmp_ok($p7a[3][0], '==', 6);
cmp_ok($p7a[3][1], '==', -1);
# south-west
my @p7b = Math::Polygon::Clip::_cross($bb0, [8,-2], [-2,3]);
cmp_ok(@p7b, '==', 4);
cmp_ok($p7b[0][0], '==', 6);
cmp_ok($p7b[0][1], '==', -1);
cmp_ok($p7b[1][0], '==', 2);
cmp_ok($p7b[1][1], '==', 1);
cmp_ok($p7b[2][0], '==', 0);
cmp_ok($p7b[2][1], '==', 2);
cmp_ok($p7b[3][0], '==', -1);
cmp_ok($p7b[3][1], '==', 2.5);
Math-Polygon-1.11/t/44mirror.t 0000644 0001750 0000144 00000002173 15005156512 016605 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 8;
use lib '../lib';
use Math::Polygon::Transform;
use Math::Polygon::Calc qw/polygon_string/;
my @p = ([0,0], [1,1], [-2,1], [-2,-2], [0,0]);
is( polygon_string(polygon_mirror x => 1, @p)
, "[2,0], [1,1], [4,1], [4,-2], [2,0]"
, 'x=1'
);
is( polygon_string(polygon_mirror y => 1, @p)
, "[0,2], [1,1], [-2,1], [-2,4], [0,2]"
, 'y=1'
);
is( polygon_string(polygon_mirror rc => 1, @p)
, "[0,0], [1,1], [1,-2], [-2,-2], [0,0]"
, 'y=x'
);
is( polygon_string(polygon_mirror rc => undef, b => 1, @p)
, "[2,0], [1,1], [4,1], [4,-2], [2,0]"
, 'x=1'
);
is( polygon_string(polygon_mirror rc => -1, b => -1, @p)
, "[-1,-1], [-2,-2], [-2,1], [1,1], [-1,-1]"
, 'y=-x-1'
);
is( polygon_string(polygon_mirror line => [[0,0],[1,1]], @p)
, "[0,0], [1,1], [1,-2], [-2,-2], [0,0]"
, 'y=x'
);
is( polygon_string(polygon_mirror line => [[0,-1],[-3,2]], @p)
, "[-1,-1], [-2,-2], [-2,1], [1,1], [-1,-1]"
, 'y=-x-1'
);
is( polygon_string(polygon_mirror line => [[1,-3],[1,10]], @p)
, "[2,0], [1,1], [4,1], [4,-2], [2,0]"
, 'x=1'
);
Math-Polygon-1.11/t/45simple.t 0000644 0001750 0000144 00000003634 15005156512 016570 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 11;
use lib '../lib', 'lib';
use Math::Polygon::Transform;
use Math::Polygon::Calc qw/polygon_string/;
###
### SAME
###
my @p = ([0,0], [0,0], [1,1], [2,2], [2.1, 2.1], [1.9, 1.85], [0,0.1], [0,0]);
is( polygon_string(polygon_simplify @p)
, "[0,0], [1,1], [2,2], [2.1,2.1], [1.9,1.85], [0,0.1], [0,0]"
, 'default'
);
is( polygon_string(polygon_simplify same => 0.15, @p)
, "[0,0.05], [1,1], [2.05,2.05], [1.9,1.85], [0,0.05]"
, 'resolution 0.11'
);
is( polygon_string(polygon_simplify same => 0.25, @p)
, "[0,0.05], [1,1], [1.975,1.95], [0,0.05]"
, 'resolution 0.11'
);
pop @p; # @p now not a ring anymore
is( polygon_string(polygon_simplify @p)
, "[0,0], [1,1], [2,2], [2.1,2.1], [1.9,1.85], [0,0.1]"
, 'default no ring'
);
is( polygon_string(polygon_simplify same => 0.15, @p)
, "[0,0], [1,1], [2.05,2.05], [1.9,1.85], [0,0.1]"
, 'resolution 0.11 no ring'
);
is( polygon_string(polygon_simplify same => 0.25, @p)
, "[0,0], [1,1], [1.975,1.95], [0,0.1]"
, 'resolution 0.11 no ring'
);
###
### SLOPE
###
my @q = ( [0,1],[0,4],[4,5],[7,4],[7,1],[3,0],[0,1] );
is( polygon_string(polygon_simplify @q)
, "[0,1], [0,4], [4,5], [7,4], [7,1], [3,0], [0,1]"
, 'identity'
);
is( polygon_string(polygon_simplify slope => 1, @q)
, "[0,1], [0,4], [7,4], [7,1], [0,1]"
, 'identity'
);
###
### Z shape in slope
###
my @r = ( [1,1], [1,4], [1,2], [1,5] );
is( polygon_string(polygon_simplify slope => 0.001, @r)
, "[1,1], [1,5]"
, 'simple'
);
###
### Remove blunt angles
###
my @s = ( [0,0], [1,3], [4,3], [5,0], [4,-3], [1,-3], [0,0] );
is( polygon_string(polygon_simplify max_points => 4, @s)
, "[1,3], [4,3], [4,-3], [1,-3], [1,3]"
, 'max 4 (ring => 5 left)'
);
pop @s;
is( polygon_string(polygon_simplify max_points => 5, @s)
, "[0,0], [1,3], [4,3], [4,-3], [1,-3]"
, 'max 5 (no ring)'
);
Math-Polygon-1.11/t/10box.t 0000644 0001750 0000144 00000001002 15005156512 016042 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 2;
use lib '../lib';
use Math::Polygon::Calc;
sub compare_box($$)
{ my ($a, $b) = @_;
#warn "[@$a] == [@$b]\n";
$a->[0] == $b->[0]
&& $a->[1] == $b->[1]
&& $a->[2] == $b->[2]
&& $a->[3] == $b->[3]
}
my @bb1 = polygon_bbox [3,4];
ok(compare_box(\@bb1, [3,4,3,4]));
my @bb2 = polygon_bbox [0,2], [1,2], [2,1], [2,0], [1,-1]
, [0,-1], [-1,0], [-1,1], [0,2];
ok(compare_box(\@bb2, [-1,-1, 2,2]));
Math-Polygon-1.11/t/11size.t 0000644 0001750 0000144 00000001256 15005156512 016240 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 11;
use lib '../lib';
use Math::Polygon::Calc;
my @p0 = ( [3,4] );
cmp_ok(polygon_area(@p0), '==', 0);
ok(!polygon_is_clockwise @p0);
ok(!polygon_is_clockwise reverse @p0);
my @p1 = ( [0,2], [1,2], [2,1], [2,0], [1,-1], [0,-1], [-1,0], [-1,1], [0,2]);
cmp_ok(polygon_area(@p1), '==', 7);
cmp_ok(polygon_area(reverse @p1), '==', 7);
ok(polygon_is_clockwise(@p1));
ok(!polygon_is_clockwise(reverse @p1));
my @p2 = ( [0,1], [3,2], [3,1], [2,0], [1,1], [0,-2], [0,1] );
cmp_ok(polygon_area(@p2), '==', 4);
cmp_ok(polygon_area(@p2), '==', 4);
ok(polygon_is_clockwise(@p2));
ok(!polygon_is_clockwise(reverse @p2));
Math-Polygon-1.11/t/90polygon.t 0000644 0001750 0000144 00000003740 15005156512 016764 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 39;
use Math::Polygon;
my @p = ([0,0],[1,1],[0,2],[0,0]);
my @q = ([1,1],[0,2],[0,0],[1,1]); # rotated left 1
# Instantiate from array
my $p = Math::Polygon->new(@p);
ok(defined $p);
isa_ok($p, 'Math::Polygon');
cmp_ok($p->nrPoints, '==', scalar(@p));
cmp_ok($p->order, '==', 3); # triangle
cmp_ok($p->area, '==', 1);
ok(!$p->isClockwise); # computed
my $p02 = $p->point(2);
ok(defined $p02, "got point");
cmp_ok($p02->[0], '==', 0);
cmp_ok($p02->[1], '==', 2);
my @p02 = $p->point(2);
cmp_ok(scalar(@p02), '==', 1, "got one point");
cmp_ok($p02[0][0], '==', 0);
cmp_ok($p02[0][1], '==', 2);
# Instantiate by option
my $p2 = Math::Polygon->new(points => \@p, clockwise => 1);
ok(defined $p);
isa_ok($p2, 'Math::Polygon');
cmp_ok($p2->nrPoints, '==', scalar(@p));
ok($p2->isClockwise); # specified, incorrect ;-)
# Instantiate by instance call
my $p3 = $p2->new(@q);
isa_ok($p3, 'Math::Polygon');
cmp_ok($p3->nrPoints, '==', scalar(@q));
ok($p3->isClockwise); # specified, incorrect ;-)
my $p31 = $p3->point(1);
ok(defined $p31, "got point from q (not p)");
cmp_ok($p31->[0], '==', 0);
cmp_ok($p31->[1], '==', 2);
# Comparison
ok($p->equal(@p));
ok($p->same(@p));
ok(!$p->equal(@q));
ok($p->same(@q));
ok($p->startMinXY(@p));
my $q = Math::Polygon->new(@q);
ok($q->startMinXY(@p)->equal($p));
my @r = $p->lineClip(-1,-1,1,1);
cmp_ok(scalar(@r),'==',1);
my $r = shift @r;
cmp_ok(scalar(@$r),'==',3);
cmp_ok($r->[0][0],'==',0);
cmp_ok($r->[0][1],'==',1);
cmp_ok($r->[1][0],'==',0);
cmp_ok($r->[1][1],'==',0);
cmp_ok($r->[2][0],'==',1);
cmp_ok($r->[2][1],'==',1);
# String
is $p->string, '[0,0], [1,1], [0,2], [0,0]', 'string';
my $p4 = Math::Polygon->new([3.1415, 2.182], [1.414, 1.732]);
is $p4->string("%.2f"), '[3.14,2.18], [1.41,1.73]', 'string format';
use Data::Dumper;
is_deeply [ $p4->points('%.1f') ],
[ [ '3.1', '2.2' ], [ '1.4', '1.7' ] ], 'points format';
Math-Polygon-1.11/t/32clipf1.t 0000644 0001750 0000144 00000001653 15005156512 016450 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 3;
use lib '../lib';
use Math::Polygon::Clip;
use Math::Polygon::Calc;
sub compare_clip($$$)
{ my ($got, $want, $text) = @_;
cmp_ok(scalar(@$got), '==', scalar(@$want), "nr fragments, $text");
for(my $i = 0; $i < @$got; $i++)
{ my $g = $got->[$i];
my $w = $want->[$i];
cmp_ok(scalar(@$g), '==', scalar(@$w), "points in fragment $i");
for(my $j=0; $j < @$g; $j++)
{ cmp_ok($g->[$j][0], '==', $w->[$j][0], "X $i,$j");
cmp_ok($g->[$j][1], '==', $w->[$j][1], "Y $i,$j");
}
}
}
#
# p0 is square
#
my @p0 = ([1,1],[3,1],[3,3],[1,3],[1,1]);
my @q0 = polygon_fill_clip1 [0,0, 2,2], @p0;
cmp_ok(scalar(@q0),'==',5, 'overlapping squares');
is(polygon_string(@q0), '[1,1], [2,1], [2,2], [1,2], [1,1]');
my @q0b = polygon_fill_clip1 [0,0, 4,4], @p0;
is(polygon_string(@q0b), '[1,1], [3,1], [3,3], [1,3], [1,1]', 'take all');
Math-Polygon-1.11/t/33centroid.t 0000644 0001750 0000144 00000001531 15005156512 017075 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use lib '../lib';
use Math::Polygon::Calc 'polygon_centroid';
use warnings;
use strict;
use Test::More tests => 5;
sub compare_point($$)
{ my ($a, $b) = @_;
$a->[0] == $b->[0]
&& $a->[1] == $b->[1]
}
my $centroid1 = polygon_centroid [0,0], [0,10], [10,10], [10,0], [0,0];
ok(compare_point($centroid1, [5,5]));
my $centroid2 = polygon_centroid [6,2], [12,2], [12,8], [6,2];
ok(compare_point($centroid2, [10,4]));
my $centroid3 = polygon_centroid [1,2], [7,2], [13,8], [1,2];
ok(compare_point($centroid3, [7,4]));
my $centroid4 = polygon_centroid [3,2], [10,2], [12,8], [5,8], [3,2];
ok(compare_point($centroid4, [7.5,5]));
# line piece
my $c5 = polygon_centroid [1,2], [5,6], [1,2];
ok(compare_point($c5, [3,4]));
# longer line
#my $c6 = polygon_centroid [1,2], [5,6], [9,10], [1,2];
#ok(compare_point($c6, [5,6]));
Math-Polygon-1.11/t/15distance.t 0000644 0001750 0000144 00000001726 15005156512 017066 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
# Distance from point to closest point on polygon
use strict;
use warnings;
use Test::More tests => 15;
use lib '../lib';
use Math::Polygon::Calc;
my @p = ([1,1], [3,1], [3,3], [1,3], [1,1]);
is( polygon_distance([1,1], @p), 0);
is( polygon_distance([1,0], @p), 1);
is( polygon_distance([0,1], @p), 1);
is( polygon_distance([2,0], @p), 1);
is( polygon_distance([2,2], @p), 1);
is( polygon_distance([0,2], @p), 1);
is( polygon_distance([3,0], @p), 1);
is( polygon_distance([0,3], @p), 1);
is( polygon_distance([0,0], @p), polygon_distance([4,4], @p));
is( polygon_distance([4,0], @p), polygon_distance([0,4], @p));
@p = ([6,2],[7,1],[8,2],[7,3],[6,2]);
is( polygon_distance([5,1], @p), polygon_distance([5,3], @p));
is( polygon_distance([6,0], @p), polygon_distance([6,4], @p));
is( polygon_distance([7,2], @p), polygon_distance([8,3], @p));
# single points
is( polygon_distance([1,1], [4,5]), 5 );
# empty poly
ok( !defined polygon_distance([1,1]) );
Math-Polygon-1.11/README.md 0000644 0001750 0000144 00000004465 15005156512 015760 0 ustar 00markov users 0000000 0000000 # distribution Math-Polygon
* My extended documentation:
* Development via GitHub:
* Download from CPAN:
* Indexed from CPAN:
This module supports simple manipulation of 2D polygons, via two interfaces:
1. Object Oriented via Math::Polygon
This is the preferred interface: the simplest when you understand OO.
The polygon coordinates (ARRAY of points) are wrapped into an abstract
objects.
2. Function interface via Math::Polygon::Calc and friends
When you prefer to use plain functions and juggle with ARRAYs of ARRAYs
of coordinates.
## Development → Release
Important to know, is that I use an extension on POD to write the manuals.
The "raw" unprocessed version is visible on GitHub. It will run without
problems, but does not contain manual-pages.
Releases to CPAN are different: "raw" documentation gets removed from
the code and translated into real POD and clean HTML. This reformatting
is implemented with the OODoc distribution (A name I chose before OpenOffice
existed, sorry for the confusion)
Clone from github for the "raw" version. For instance, when you want
to contribute a new feature.
On github, you can find the processed version for each release. But the
better source is CPAN; to get it installed simply run:
```sh
cpan -i Math::Polygon
```
## Contributing
When you want to contribute to this module, you do not need to provide
a perfect patch... actually: it is nearly impossible to create a patch
which I will merge without modification. Usually, I need to adapt the
style of code and documentation to my own strict rules.
When you submit an extension, please contribute a set with
1. code
2. code documentation
3. regression tests in t/
**Please note:**
When you contribute in any way, you agree to transfer the copyrights to
Mark Overmeer (you will get the honors in the code and/or ChangeLog).
You also automatically agree that your contribution is released under
the same license as this project: licensed as perl itself.
## Copyright and License
This project is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See
Math-Polygon-1.11/lib/ 0000755 0001750 0000144 00000000000 15005156515 015241 5 ustar 00markov users 0000000 0000000 Math-Polygon-1.11/lib/Math/ 0000755 0001750 0000144 00000000000 15005156515 016132 5 ustar 00markov users 0000000 0000000 Math-Polygon-1.11/lib/Math/Polygon/ 0000755 0001750 0000144 00000000000 15005156515 017561 5 ustar 00markov users 0000000 0000000 Math-Polygon-1.11/lib/Math/Polygon/Calc.pm 0000644 0001750 0000144 00000023064 15005156512 020763 0 ustar 00markov users 0000000 0000000 # Copyrights 2004-2025 by [Mark Overmeer ].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Math-Polygon. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package Math::Polygon::Calc;{
our $VERSION = '1.11';
}
use base 'Exporter';
use strict;
use warnings;
our @EXPORT = qw/
polygon_area
polygon_bbox
polygon_beautify
polygon_centroid
polygon_clockwise
polygon_contains_point
polygon_counter_clockwise
polygon_distance
polygon_equal
polygon_is_clockwise
polygon_is_closed
polygon_perimeter
polygon_same
polygon_start_minxy
polygon_string
polygon_format
/;
use List::Util qw/min max/;
use Carp qw/croak/;
sub polygon_string(@) { join ', ', map "[$_->[0],$_->[1]]", @_ }
sub polygon_bbox(@)
{
( min( map $_->[0], @_ )
, min( map $_->[1], @_ )
, max( map $_->[0], @_ )
, max( map $_->[1], @_ )
);
}
sub polygon_area(@)
{ my $area = 0;
while(@_ >= 2)
{ $area += $_[0][0]*$_[1][1] - $_[0][1]*$_[1][0];
shift;
}
abs($area)/2;
}
sub polygon_is_clockwise(@)
{ my $area = 0;
polygon_is_closed(@_)
or croak "ERROR: polygon must be closed: begin==end";
while(@_ >= 2)
{ $area += $_[0][0]*$_[1][1] - $_[0][1]*$_[1][0];
shift;
}
$area < 0;
}
sub polygon_clockwise(@)
{ polygon_is_clockwise(@_) ? @_ : reverse @_;
}
sub polygon_counter_clockwise(@)
{ polygon_is_clockwise(@_) ? reverse(@_) : @_;
}
sub polygon_perimeter(@)
{ my $l = 0;
while(@_ >= 2)
{ $l += sqrt(($_[0][0]-$_[1][0])**2 + ($_[0][1]-$_[1][1])**2);
shift;
}
$l;
}
sub polygon_start_minxy(@)
{ return @_ if @_ <= 1;
my $ring = $_[0][0]==$_[-1][0] && $_[0][1]==$_[-1][1];
pop @_ if $ring;
my ($xmin, $ymin) = polygon_bbox @_;
my $rot = 0;
my $dmin_sq = ($_[0][0]-$xmin)**2 + ($_[0][1]-$ymin)**2;
for(my $i=1; $i<@_; $i++)
{ next if $_[$i][0] - $xmin > $dmin_sq;
my $d_sq = ($_[$i][0]-$xmin)**2 + ($_[$i][1]-$ymin)**2;
if($d_sq < $dmin_sq)
{ $dmin_sq = $d_sq;
$rot = $i;
}
}
$rot==0 ? (@_, ($ring ? $_[0] : ()))
: (@_[$rot..$#_], @_[0..$rot-1], ($ring ? $_[$rot] : ()));
}
sub polygon_beautify(@)
{ my %opts = ref $_[0] eq 'HASH' ? %{ (shift) } : ();
return () unless @_;
my $despike = exists $opts{remove_spikes} ? $opts{remove_spikes} : 0;
my @res = @_;
return () if @res < 4; # closed triangle = 4 points
pop @res; # cyclic: last is first
my $unchanged= 0;
while($unchanged < 2*@res)
{ return () if @res < 3; # closed triangle = 4 points
my $this = shift @res;
push @res, $this; # recycle
$unchanged++;
# remove doubles
my ($x, $y) = @$this;
while(@res && $res[0][0]==$x && $res[0][1]==$y)
{ $unchanged = 0;
shift @res;
}
# remove spike
if($despike && @res >= 2)
{ # any spike
if($res[1][0]==$x && $res[1][1]==$y)
{ $unchanged = 0;
shift @res;
}
# x-spike
if($y==$res[0][1] && $y==$res[1][1]
&& ( ($res[0][0] < $x && $x < $res[1][0])
|| ($res[0][0] > $x && $x > $res[1][0])))
{ $unchanged = 0;
shift @res;
}
# y-spike
if( $x==$res[0][0] && $x==$res[1][0]
&& ( ($res[0][1] < $y && $y < $res[1][1])
|| ($res[0][1] > $y && $y > $res[1][1])))
{ $unchanged = 0;
shift @res;
}
}
# remove intermediate
if( @res >= 2
&& $res[0][0]==$x && $res[1][0]==$x
&& ( ($y < $res[0][1] && $res[0][1] < $res[1][1])
|| ($y > $res[0][1] && $res[0][1] > $res[1][1])))
{ $unchanged = 0;
shift @res;
}
if( @res >= 2
&& $res[0][1]==$y && $res[1][1]==$y
&& ( ($x < $res[0][0] && $res[0][0] < $res[1][0])
|| ($x > $res[0][0] && $res[0][0] > $res[1][0])))
{ $unchanged = 0;
shift @res;
}
# remove 2 out-of order between two which stay
if(@res >= 3
&& $x==$res[0][0] && $x==$res[1][0] && $x==$res[2][0]
&& ($y < $res[0][1] && $y < $res[1][1]
&& $res[0][1] < $res[2][1] && $res[1][1] < $res[2][1]))
{ $unchanged = 0;
splice @res, 0, 2;
}
if(@res >= 3
&& $y==$res[0][1] && $y==$res[1][1] && $y==$res[2][1]
&& ($x < $res[0][0] && $x < $res[1][0]
&& $res[0][0] < $res[2][0] && $res[1][0] < $res[2][0]))
{ $unchanged = 0;
splice @res, 0, 2;
}
}
@res ? (@res, $res[0]) : ();
}
sub polygon_equal($$;$)
{ my ($f,$s, $tolerance) = @_;
return 0 if @$f != @$s;
my @f = @$f;
my @s = @$s;
if(defined $tolerance)
{ while(@f)
{ return 0 if abs($f[0][0]-$s[0][0]) > $tolerance
|| abs($f[0][1]-$s[0][1]) > $tolerance;
shift @f; shift @s;
}
return 1;
}
while(@f)
{ return 0 if $f[0][0] != $s[0][0] || $f[0][1] != $s[0][1];
shift @f; shift @s;
}
1;
}
sub polygon_same($$;$)
{ return 0 if @{$_[0]} != @{$_[1]};
my @f = polygon_start_minxy @{ (shift) };
my @s = polygon_start_minxy @{ (shift) };
polygon_equal \@f, \@s, $_[0];
}
# Algorithms can be found at
# http://www.eecs.umich.edu/courses/eecs380/HANDOUTS/PROJ2/InsidePoly.html
# p1 = polygon[0];
# for (i=1;i<=N;i++) {
# p2 = polygon[i % N];
# if (p.y > MIN(p1.y,p2.y)) {
# if (p.y <= MAX(p1.y,p2.y)) {
# if (p.x <= MAX(p1.x,p2.x)) {
# if (p1.y != p2.y) {
# xinters = (p.y-p1.y)*(p2.x-p1.x)/(p2.y-p1.y)+p1.x;
# if (p1.x == p2.x || p.x <= xinters)
# counter++;
# }
# }
# }
# }
# p1 = p2;
# }
# inside = counter % 2;
sub polygon_contains_point($@)
{ my $point = shift;
return 0 if @_ < 3;
my ($x, $y) = @$point;
my $inside = 0;
polygon_is_closed(@_)
or croak "ERROR: polygon must be closed: begin==end";
my ($px, $py) = @{ (shift) };
while(@_)
{ my ($nx, $ny) = @{ (shift) };
# Extra check for exactly on the edge when the axes are
# horizontal or vertical.
return 1 if $y==$py && $py==$ny
&& ($x >= $px || $x >= $nx)
&& ($x <= $px || $x <= $nx);
return 1 if $x==$px && $px==$nx
&& ($y >= $py || $y >= $ny)
&& ($y <= $py || $y <= $ny);
if( $py == $ny
|| ($y <= $py && $y <= $ny)
|| ($y > $py && $y > $ny)
|| ($x > $px && $x > $nx)
)
{
($px, $py) = ($nx, $ny);
next;
}
# side wrt diagonal
my $xinters = ($y-$py)*($nx-$px)/($ny-$py)+$px;
$inside = !$inside
if $px==$nx || $x <= $xinters;
($px, $py) = ($nx, $ny);
}
$inside;
}
sub polygon_centroid(@)
{
polygon_is_closed(@_)
or croak "ERROR: polygon must be closed: begin==end";
return [ ($_[0][0] + $_[1][0])/2, ($_[0][1] + $_[1][1])/2 ]
if @_==3; # line
my ($cx, $cy, $a) = (0, 0, 0);
foreach my $i (0..@_-2)
{ my $ap = $_[$i][0] * $_[$i+1][1] - $_[$i+1][0] * $_[$i][1];
$cx += ( $_[$i][0] + $_[$i+1][0]) * $ap;
$cy += ( $_[$i][1] + $_[$i+1][1]) * $ap;
$a += $ap;
}
$a != 0
or croak "ERROR: polygon points on a line, so no centroid";
my $c = 3*$a; # 6*$a/2;
[ $cx/$c, $cy/$c ];
}
sub polygon_is_closed(@)
{ @_ or croak "ERROR: empty polygon is neither closed nor open";
my ($first, $last) = @_[0,-1];
$first->[0]==$last->[0] && $first->[1]==$last->[1];
}
# Contributed by Andreas Koenig for 1.05
# http://stackoverflow.com/questions/10983872/distance-from-a-point-to-a-polygon#10984080
# with correction from
# http://stackoverflow.com/questions/849211/shortest-distance-between-a-point-and-a-line-segment
sub polygon_distance($%)
{ my $p = shift;
my ($x, $y) = @$p;
my $minDist;
@_ or return undef;
my ($x1, $y1) = @{ (shift) };
unless(@_)
{ my ($dx, $dy) = ($x1 - $x, $y1 - $y);
return sqrt($dx * $dx + $dy * $dy);
}
while(@_)
{ my ($x2, $y2) = @{ (shift) }; # closed poly!
my $A = $x - $x1;
my $B = $y - $y1;
my $C = $x2 - $x1;
my $D = $y2 - $y1;
# closest point to the line segment
my $dot = $A * $C + $B * $D;
my $len_sq = $C * $C + $D * $D;
my $angle = $len_sq==0 ? -1 : $dot / $len_sq;
my ($xx, $yy)
= $angle < 0 ? ($x1, $y1) # perpendicular line crosses off segment
: $angle > 1 ? ($x2, $y2)
: ($x1 + $angle * $C, $y1 + $angle * $D);
my $dx = $x - $xx;
my $dy = $y - $yy;
my $dist = sqrt($dx * $dx + $dy * $dy);
$minDist = $dist unless defined $minDist;
$minDist = $dist if $dist < $minDist;
($x1, $y1) = ($x2, $y2);
}
$minDist;
}
sub polygon_format($@)
{ my $format = shift;
my $call = ref $format eq 'CODE' ? $format
: sub { sprintf $format, $_[0] };
map [ $call->($_->[0]), $call->($_->[1]) ], @_;
}
1;
Math-Polygon-1.11/lib/Math/Polygon/Transform.pod 0000644 0001750 0000144 00000010113 15005156512 022231 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Math::Polygon::Transform - Polygon transformation
=head1 INHERITANCE
Math::Polygon::Transform
is an Exporter
=head1 SYNOPSIS
my @poly = ( [1,2], [2,4], [5,7], [1, 2] );
my $area = polygon_transform resize => 3.14, @poly;
=head1 DESCRIPTION
This package contains polygon transformation algorithms.
=head1 FUNCTIONS
=over 4
=item B(%options, @points)
Snap the polygon points to grid points, where artifacts are removed.
-Option--Default
raster 1.0
=over 2
=item raster => FLOAT
The raster size, which determines the points to round to. The origin
C<[0,0]> is always on a grid-point. When the raster value is zero,
no transformation will take place.
=back
=item B(%options, @points)
Mirror the polygon in a line. Only one of the options can be provided.
Some programs call this "flip" or "flop".
-Option--Default
b 0
line
rc undef
x undef
y undef
=over 2
=item b => FLOAT
Only used in combination with option C to describe a line.
=item line => [POINT, POINT]
Alternative way to specify the mirror line. The C and C are
computed from the two points of the line.
=item rc => FLOAT
Description of the line which is used to mirror in. The line is
C. The C equals C<-dy/dx>, the firing angle. If
C is explicitly specified then C is used as constant x: it's
a vertical mirror.
=item x => FLOAT
Mirror in the line C, which means that C stays unchanged.
=item y => FLOAT
Mirror in the line C, which means that C stays unchanged.
=back
=item B(%options, @points)
Returns a list of points which are moved over the indicated distance
-Option--Default
dx 0
dy 0
=over 2
=item dx => FLOAT
Displacement in the horizontal direction.
=item dy => FLOAT
Displacement in the vertical direction.
=back
=item B(%options, @points)
-Option--Default
center [0,0]
scale 1.0
xscale
yscale
=over 2
=item center => POINT
=item scale => FLOAT
Resize the polygon with the indicated factor. When the factor is larger
than 1, the resulting polygon with grow, when small it will be reduced in
size. The scale will be respective from the center.
=item xscale => FLOAT
Specific scaling factor in the horizontal direction.
=item yscale => FLOAT
Specific scaling factor in the vertical direction.
=back
=item B(%options, @points)
-Option --Default
center [0,0]
degrees 0
radians 0
=over 2
=item center => POINT
=item degrees => FLOAT
specify rotation angle in degrees (between -180 and 360).
=item radians => FLOAT
specify rotation angle in rads (between -pi and 2*pi)
=back
=item B(%options, @points)
-Option --Default
max_points undef
same 0.0001
slope undef
=over 2
=item max_points => INTEGER
First, C and C reduce the number of points. Then, if there
are still more than the specified number of points left, the points with
the widest angles will be removed until the specified maximum number is
reached.
=item same => FLOAT
The distance between two points to be considered "the same" point. The value
is used as radius of the circle.
=item slope => FLOAT
With three points X(n),X(n+1),X(n+2), the point X(n+1) will be removed if
the length of the path over all three points is less than C longer
than the direct path between X(n) and X(n+2).
The slope will not be removed around the starting point of the polygon.
Removing points will change the area of the polygon.
=back
=back
=head1 DIAGNOSTICS
=over 4
=item Error: you need to specify 'x', 'y', 'rc', or 'line'
=back
=head1 SEE ALSO
This module is part of Math-Polygon distribution version 1.11,
built on May 02, 2025. Website: F
=head1 LICENSE
Copyrights 2004-2025 by [Mark Overmeer ]. For other contributors see ChangeLog.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F
Math-Polygon-1.11/lib/Math/Polygon/Clip.pod 0000644 0001750 0000144 00000004002 15005156512 021145 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Math::Polygon::Clip - frame a polygon in a square
=head1 INHERITANCE
Math::Polygon::Clip
is an Exporter
=head1 SYNOPSIS
my @poly = ( [1,2], [2,4], [5,7], [1, 2] );
my @box = ( $xmin, $ymin, $xmax, $ymax );
my $boxed = polygon_clip \@box, @poly;
=head1 DESCRIPTION
Cut-off all parts of the polygon which are outside the box
=head1 FUNCTIONS
=over 4
=item B(\@box, @points)
Clipping a polygon into rectangles can be done in various ways.
With this algorithm (which I designed myself, but may not be new), the
parts of the polygon which are outside the @box are mapped on the borders.
The polygon stays in one piece.
Returned is one list of points, which is cleaned from double points,
spikes and superfluous intermediate points.
=item B(\@box, @points)
B. The polygon falls apart in fragments, which are not
connected: paths which are followed in two directions are removed.
This is required by some applications, like polygons used in geographical
context (country contours and such).
=item B( \@box, $out-$poly, [$in-$polys] )
B. A surrounding polygon, with possible
inclussions.
=item B(\@box, @points)
Returned is a list of ARRAYS (possibly 0 long) containing line pieces
from the input polygon (or line).
example:
my @points = ( [1,2], [2,3], [2,0], [1,-1], [1,2] );
my @bbox = ( 0, -2, 2, 2 );
my @l = polygon_line_clip \@bbox, @points;
print scalar @l; # 1, only one piece found
my @first = @{$l[0]}; # first is [2,0], [1,-1], [1,2]
=back
=head1 SEE ALSO
This module is part of Math-Polygon distribution version 1.11,
built on May 02, 2025. Website: F
=head1 LICENSE
Copyrights 2004-2025 by [Mark Overmeer ]. For other contributors see ChangeLog.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F
Math-Polygon-1.11/lib/Math/Polygon/Surface.pod 0000644 0001750 0000144 00000006051 15005156512 021654 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Math::Polygon::Surface - Polygon with exclusions
=head1 SYNOPSIS
my $outer = Math::Polygon->new( [1,2], [2,4], [5,7], [1,2] );
my $surface = Math::Polygon::Surface->new($outer);
=head1 DESCRIPTION
A surface is one polygon which represents the outer bounds of an
array, plus optionally a list of polygons which represent exclusions
from that outer polygon.
=head1 METHODS
=head2 Constructors
=over 4
=item $obj-EB( [%options], [@polygons], %options )
=item Math::Polygon::Surface-EB( [%options], [@polygons], %options )
You may merge %options with @polygons. You may also use
the "outer" and "inner" options.
Each polygon is a references to an ARRAY of points, each an ARRAY of X
and Y, but better pass L objects.
-Option--Default
inner []
outer undef
=over 2
=item inner => \@polygons
The inner polygons, zero or more L objects.
=item outer => $polygon
The outer polygon, a L.
=back
=back
=head2 Attributes
=over 4
=item $obj-EB()
Returns a list (often empty) of inner polygons.
=item $obj-EB()
Returns the outer polygon.
=back
=head2 Simple calculations
=over 4
=item B()
Returns the area enclosed by the outer polygon, minus the areas of the
inner polygons.
See method L.
=item $obj-EB()
Returns a list with four elements: (xmin, ymin, xmax, ymax), which describe
the bounding box of the surface, which is the bbox of the outer polygon.
See method L.
=item $obj-EB()
The length of the border: sums outer and inner perimeters.
See method L.
=back
=head2 Clipping
=over 4
=item $obj-EB($box)
Clipping a polygon into rectangles can be done in various ways.
With this algorithm, the parts of the polygon which are outside
the $box are mapped on the borders.
All polygons are treated separately.
=item $obj-EB($box)
Returned is a list of ARRAYS-OF-POINTS containing line pieces
from the input surface. Lines from outer and inner polygons are
undistinguishable.
See method L.
=item $obj-EB()
Translate the surface structure into some string. Use Geo::WKT if you
need a standardized format.
Returned is a single string possibly containing multiple lines. The first
line is the outer, the other lines represent the inner polygons.
=back
=head1 DIAGNOSTICS
=over 4
=item Error: surface requires outer polygon
=back
=head1 SEE ALSO
This module is part of Math-Polygon distribution version 1.11,
built on May 02, 2025. Website: F
=head1 LICENSE
Copyrights 2004-2025 by [Mark Overmeer ]. For other contributors see ChangeLog.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F
Math-Polygon-1.11/lib/Math/Polygon/Convex.pm 0000644 0001750 0000144 00000006231 15005156512 021360 0 ustar 00markov users 0000000 0000000 # Copyrights 2004-2025 by [Mark Overmeer ].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Math-Polygon. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
# Algorithm by Dan Sunday
# - http://geometryalgorithms.com/Archive/algorithm_0109/algorithm_0109.htm
# Original contributed implementation in Perl by Jari Turkia.
package Math::Polygon::Convex;{
our $VERSION = '1.11';
}
use base 'Exporter';
use strict;
use warnings;
use Math::Polygon;
our @EXPORT = qw/
chainHull_2D
/;
# is_left(): tests if a point is Left|On|Right of an infinite line.
# >0 for P2 left of the line through P0 and P1
# =0 for P2 on the line
# <0 for P2 right of the line
# See: the January 2001 Algorithm on Area of Triangles
# http://geometryalgorithms.com/Archive/algorithm_0101/algorithm_0101.htm
sub is_left($$$)
{ my ($P0, $P1, $P2) = @_;
($P1->[0] - $P0->[0]) * ($P2->[1] - $P0->[1])
- ($P2->[0] - $P0->[0]) * ($P1->[1] - $P0->[1]);
}
sub chainHull_2D(@)
{ my @P = sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] } @_;
my @H; # output poly
# Get the indices of points with min x-coord and min|max y-coord
my $xmin = $P[0][0];
my ($minmin, $minmax) = (0, 0);
$minmax++ while $minmax < @P-1 && $P[$minmax+1][0]==$xmin;
if($minmax == @P-1) # degenerate case: all x-coords == xmin
{ push @H, $P[$minmin];
push @H, $P[$minmax] if $P[$minmax][1] != $P[$minmin][1];
push @H, $P[$minmin];
return Math::Polygon->new(@H);
}
push @H, $P[$minmin];
# Get the indices of points with max x-coord and min|max y-coord
my $maxmin = my $maxmax = @P-1;
my $xmax = $P[$maxmax][0];
$maxmin-- while $maxmin >= 1 && $P[$maxmin-1][0]==$xmax;
# Compute the lower hull
for(my $i = $minmax+1; $i <= $maxmin; $i++)
{ # the lower line joins P[minmin] with P[maxmin]
# ignore P[i] above or on the lower line
next if $i < $maxmin
&& is_left($P[$minmin], $P[$maxmin], $P[$i]) >= 0;
pop @H
while @H >= 2 && is_left($H[-2], $H[-1], $P[$i]) < 0;
push @H, $P[$i];
}
push @H, $P[$maxmax]
if $maxmax != $maxmin;
# Next, compute the upper hull on the stack H above the bottom hull
my $bot = @H-1; # the bottom point of the upper hull stack
for(my $i = $maxmin-1; $i >= $minmax; --$i)
{ # the upper line joins P[maxmax] with P[minmax]
# ignore P[i] below or on the upper line
next if $i > $minmax
&& is_left($P[$maxmax], $P[$minmax], $P[$i]) >= 0;
pop @H
while @H-1 > $bot && is_left($H[-2], $H[-1], $P[$i]) < 0;
push @H, $P[$i];
}
push @H, $P[$minmin]
if $minmax != $minmin; # joining endpoint onto stack
# Remove duplicate points.
for(my $i = @H-1; $i > 1; $i--)
{ splice @H, $i, 1
while $H[$i][0]==$H[$i-1][0] && $H[$i][1]==$H[$i-1][1];
}
Math::Polygon->new(@H);
}
1;
Math-Polygon-1.11/lib/Math/Polygon/Calc.pod 0000644 0001750 0000144 00000010741 15005156512 021127 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Math::Polygon::Calc - Simple polygon calculations
=head1 INHERITANCE
Math::Polygon::Calc
is an Exporter
=head1 SYNOPSIS
my @poly = ( [1,2], [2,4], [5,7], [1, 2] );
my ($xmin, $ymin, $xmax, $ymax) = polygon_bbox @poly;
my $area = polygon_area @poly;
MY $L = polygon_perimeter @poly;
if(polygon_is_clockwise @poly) { ... };
my @rot = polygon_start_minxy @poly;
=head1 DESCRIPTION
This package contains a wide variaty of relatively easy polygon
calculations. More complex calculations are put in separate
packages.
=head1 FUNCTIONS
=over 4
=item B(@points)
Returns the area enclosed by the polygon. The last point of the list
must be the same as the first to produce a correct result.
The algorithm was found at L,
and sounds:
A = abs( 1/2 * (x1y2-x2y1 + x2y3-x3y2 ...)
=item B(@points)
Returns a list with four elements: (xmin, ymin, xmax, ymax), which describe
the bounding box of the polygon (all points of the polygon are within that
area.
=item B( [\%options], @points )
Polygons, certainly after some computations, can have a lot of
horrible artifacts: points which are double, spikes, etc.
The optional HASH contains the %options.
-Option --Default
remove_spikes
=over 2
=item remove_spikes => BOOLEAN
Spikes contain of three successive points, where the first is on the
line between the second and the third. The line goes from first to
second, but then back to get to the third point.
At the moment, only pure horizontal and pure vertical spikes are
removed.
=back
=item B(@points)
Returns the centroid location of the polygon.
The last point of the list must be the same as the first (must be
'closed') to produce a correct result. When the polygon is very flat,
it will not produce a stable result: minor changes in single coordinates
will move the centroid too far.
The algorithm was found at
F
=item B(@points)
Be sure the polygon points are in clockwise order.
=item B($point, @points)
Returns true if the point is inside the closed polygon. On an edge will
be flagged as 'inside'. But be warned of rounding issues, caused by
the floating-point calculations used by this algorithm.
=item B(@points)
Be sure the polygon points are in counter-clockwise order.
=item B($point, @polygon)
[1.05] calculate the shortest distance between a point and any vertex of
a closed polygon.
=item B( \@points1, \@points2, [$tolerance] )
Compare two polygons, on the level of points. When the polygons are
the same but rotated, this will return false. See L.
=item B($format, @points)
[1.07] Map the $format over all @points, both the X and Y coordinate. This
is especially useful to reduce the number of digits in the stringification.
For instance, when you want reproducible results in regression scripts.
The format is anything supported by printf(), for instance "%5.2f". Or,
you can pass a code reference which accepts a single value.
=item B(@points)
=item B(@points)
=item B(@points)
The length of the line of the polygon. This can also be used to compute
the length of any line: of the last point is not equal to the first, then
a line is presumed; for a polygon they must match.
This is simply Pythagoras.
$l = sqrt((x1-x0)^2 + (y1-y0)^2) + sqrt((x2-x1)^2+(y2-y1)^2) + ...
=item B( \@points1, \@points2, [$tolerance] )
Compare two polygons, where the polygons may be rotated wrt each
other. This is (much) slower than L, but some algorithms
will cause un unpredictable rotation in the result.
=item B(@points)
Returns the polygon, where the point which is closest to the left-bottom
corner of the bounding box is made first.
=item B(@points)
=back
=head1 SEE ALSO
This module is part of Math-Polygon distribution version 1.11,
built on May 02, 2025. Website: F
=head1 LICENSE
Copyrights 2004-2025 by [Mark Overmeer ]. For other contributors see ChangeLog.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F
Math-Polygon-1.11/lib/Math/Polygon/Transform.pm 0000644 0001750 0000144 00000017046 15005156512 022077 0 ustar 00markov users 0000000 0000000 # Copyrights 2004-2025 by [Mark Overmeer ].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Math-Polygon. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package Math::Polygon::Transform;{
our $VERSION = '1.11';
}
use base 'Exporter';
use strict;
use warnings;
use Math::Trig qw/deg2rad pi rad2deg/;
use POSIX qw/floor/;
use Carp qw/carp/;
our @EXPORT = qw/
polygon_resize
polygon_move
polygon_rotate
polygon_grid
polygon_mirror
polygon_simplify
/;
sub polygon_resize(@)
{ my %opts;
while(@_ && !ref $_[0])
{ my $key = shift;
$opts{$key} = shift;
}
my $sx = $opts{xscale} || $opts{scale} || 1.0;
my $sy = $opts{yscale} || $opts{scale} || 1.0;
return @_ if $sx==1.0 && $sy==1.0;
my ($cx, $cy) = defined $opts{center} ? @{$opts{center}} : (0,0);
return map { [ $_->[0]*$sx, $_->[1]*$sy ] } @_
unless $cx || $cy;
map { [ $cx + ($_->[0]-$cx)*$sx, $cy + ($_->[1]-$cy) * $sy ] } @_;
}
sub polygon_move(@)
{ my %opts;
while(@_ && !ref $_[0])
{ my $key = shift;
$opts{$key} = shift;
}
my ($dx, $dy) = ($opts{dx}||0, $opts{dy}||0);
return @_ if $dx==0 && $dy==0;
map { [ $_->[0] +$dx, $_->[1] +$dy ] } @_;
}
sub polygon_rotate(@)
{ my %opts;
while(@_ && !ref $_[0])
{ my $key = shift;
$opts{$key} = shift;
}
my $angle
= exists $opts{radians} ? $opts{radians}
: exists $opts{degrees} ? deg2rad($opts{degrees})
: 0;
return @_ unless $angle;
my $sina = sin($angle);
my $cosa = cos($angle);
my ($cx, $cy) = defined $opts{center} ? @{$opts{center}} : (0,0);
unless($cx || $cy)
{ return map { [ $cosa * $_->[0] + $sina * $_->[1]
, -$sina * $_->[0] + $cosa * $_->[1]
] } @_;
}
map { [ $cx + $cosa * ($_->[0]-$cx) + $sina * ($_->[1]-$cy)
, $cy + -$sina * ($_->[0]-$cx) + $cosa * ($_->[1]-$cy)
] } @_;
}
sub polygon_grid(@)
{ my %opts;
while(@_ && !ref $_[0])
{ my $key = shift;
$opts{$key} = shift;
}
my $raster = exists $opts{raster} ? $opts{raster} : 1;
return @_ if $raster == 0;
# use fast "int" for gridsize 1
return map { [ floor($_->[0] + 0.5), floor($_->[1] + 0.5) ] } @_
if $raster > 0.99999 && $raster < 1.00001;
map { [ $raster * floor($_->[0]/$raster + 0.5)
, $raster * floor($_->[1]/$raster + 0.5)
] } @_;
}
sub polygon_mirror(@)
{ my %opts;
while(@_ && !ref $_[0])
{ my $key = shift;
$opts{$key} = shift;
}
if(defined $opts{x})
{ my $x2 = 2* $opts{x};
return map { [ $x2 - $_->[0], $_->[1] ] } @_;
}
if(defined $opts{y})
{ my $y2 = 2* $opts{y};
return map { [ $_->[0], $y2 - $_->[1] ] } @_;
}
# Mirror in line
my ($rc, $b);
if(exists $opts{rc} )
{ $rc = $opts{rc};
$b = $opts{b} || 0;
}
elsif(my $through = $opts{line})
{ my ($p0, $p1) = @$through;
if($p0->[0]==$p1->[0])
{ $b = $p0->[0]; # vertikal mirror
}
else
{ $rc = ($p1->[1] - $p0->[1]) / ($p1->[0] - $p0->[0]);
$b = $p0->[1] - $p0->[0] * $rc;
}
}
else
{ carp "ERROR: you need to specify 'x', 'y', 'rc', or 'line'";
}
unless(defined $rc) # vertical
{ my $x2 = 2* $b;
return map { [ $x2 - $_->[0], $_->[1] ] } @_;
}
# mirror is y=x*rc+b, y=-x/rc+c through mirrored point
my $yf = 2/($rc*$rc +1);
my $xf = $yf * $rc;
map { my $c = $_->[1] + $_->[0]/$rc;
[ $xf*($c-$b) - $_->[0], $yf*($b-$c) + 2*$c - $_->[1] ] } @_;
}
sub _angle($$$)
{ my ($p0, $p1, $p2) = @_;
my $a0 = atan2($p0->[1] - $p1->[1], $p0->[0] - $p1->[0]);
my $a1 = atan2($p2->[1] - $p1->[1], $p2->[0] - $p1->[0]);
my $a = abs($a0 - $a1);
$a = 2*pi - $a if $a > pi;
$a;
}
sub polygon_simplify(@)
{ my %opts;
while(@_ && !ref $_[0])
{ my $key = shift;
$opts{$key} = shift;
}
return unless @_;
my $is_ring = $_[0][0]==$_[-1][0] && $_[0][1]==$_[-1][1];
my $same = $opts{same} || 0.0001;
my $slope = $opts{slope};
my $changes = 1;
while($changes && @_)
{
$changes = 0;
my @new;
my $p = shift;
while(@_)
{ my ($x, $y) = @$p;
my ($nx, $ny) = @{$_[0]};
my $d01 = sqrt(($nx-$x)*($nx-$x) + ($ny-$y)*($ny-$y));
if($d01 < $same)
{ $changes++;
# point within threshold: middle, unless we are at the
# start of the polygo description: that one has a slight
# preference, to avoid an endless loop.
push @new, !@new ? [ ($x,$y) ] : [ ($x+$nx)/2, ($y+$ny)/2 ];
shift; # remove next
$p = shift; # 2nd as new current
next;
}
unless(@_ >= 2 && defined $slope)
{ push @new, $p; # keep this
$p = shift; # check next
next;
}
my ($sx,$sy) = @{$_[1]};
my $d12 = sqrt(($sx-$nx)*($sx-$nx) + ($sy-$ny)*($sy-$ny));
my $d02 = sqrt(($sx-$x) *($sx-$x) + ($sy-$y) *($sy-$y) );
if($d01 + $d12 <= $d02 + $slope)
{ # three points nearly on a line, remove middle
$changes++;
push @new, $p, $_[1];
shift; shift;
$p = shift; # jump over next
next;
}
if(@_ > 2 && abs($d01-$d12-$d02) < $slope)
{ # check possibly a Z shape
my ($tx,$ty) = @{$_[2]};
my $d03 = sqrt(($tx-$x) *($tx-$x) + ($ty-$y) *($ty-$y));
my $d13 = sqrt(($tx-$nx)*($tx-$nx) + ($ty-$ny)*($ty-$ny));
if($d01 - $d13 <= $d03 + $slope)
{ $changes++;
push @new, $p, $_[2]; # accept 1st and 4th
splice @_, 0, 3; # jump over handled three!
$p = shift;
next;
}
}
push @new, $p; # nothing for this one.
$p = shift;
}
push @new, $p if defined $p;
unshift @new, $new[-1] # be sure to keep ring closed
if $is_ring && ($new[0][0]!=$new[-1][0] || $new[0][1]!=$new[-1][1]);
@_ = @new;
}
exists $opts{max_points}
or return @_;
#
# Reduce the number of points to $max
#
# Collect all angles
my $max_angles = $opts{max_points};
my @angles;
if($is_ring)
{ return @_ if @_ <= $max_angles;
pop @_;
push @angles, [0, _angle($_[-1], $_[0], $_[1])]
, [$#_, _angle($_[-2], $_[-1], $_[0])];
}
else
{ return @_ if @_ <= $max_angles;
$max_angles -= 2;
}
foreach (my $i=1; $i<@_-1; $i++)
{ push @angles, [$i, _angle($_[$i-1], $_[$i], $_[$i+1]) ];
}
# Strip widest angles
@angles = sort { $b->[1] <=> $a->[1] } @angles;
while(@angles > $max_angles)
{ my $point = shift @angles;
$_[$point->[0]] = undef;
}
# Return left-over points
@_ = grep defined, @_;
push @_, $_[0] if $is_ring;
@_;
}
1;
Math-Polygon-1.11/lib/Math/Polygon/Clip.pm 0000644 0001750 0000144 00000011314 15005156512 021003 0 ustar 00markov users 0000000 0000000 # Copyrights 2004-2025 by [Mark Overmeer ].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Math-Polygon. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package Math::Polygon::Clip;{
our $VERSION = '1.11';
}
use base 'Exporter';
use strict;
use warnings;
our @EXPORT = qw/
polygon_line_clip
polygon_fill_clip1
/;
use Math::Polygon::Calc;
use List::Util qw/min max/;
sub _inside($$);
sub _cross($$$);
sub _cross_inside($$$);
sub _cross_x($$$);
sub _cross_y($$$);
sub _remove_doubles(@);
sub polygon_fill_clip1($@)
{ my $bbox = shift;
my ($xmin, $ymin, $xmax, $ymax) = @$bbox;
@_ or return (); # empty list of points
# Collect all crosspoints with axes, plus the original points
my $next = shift;
my @poly = $next;
while(@_)
{ $next = shift;
push @poly, _cross($bbox, $poly[-1], $next), $next;
}
# crop them to the borders: outside is projected on the sides
my @cropped;
foreach (@poly)
{ my ($x,$y) = @$_;
$x = $xmin if $x < $xmin;
$x = $xmax if $x > $xmax;
$y = $ymin if $y < $ymin;
$y = $ymax if $y > $ymax;
push @cropped, [$x, $y];
}
polygon_beautify {despike => 1}, @cropped;
}
sub polygon_line_clip($@)
{ my $bbox = shift;
my ($xmin, $ymin, $xmax, $ymax) = @$bbox;
my @frags;
my $from = shift;
my $fromin = _inside $bbox, $from;
push @frags, [ $from ] if $fromin;
while(@_)
{ my $next = shift;
my $nextin = _inside $bbox, $next;
if($fromin && $nextin) # stay within
{ push @{$frags[-1]}, $next;
}
elsif($fromin && !$nextin) # leaving
{ push @{$frags[-1]}, _cross_inside $bbox, $from, $next;
}
elsif($nextin) # entering
{ my @cross = _cross_inside $bbox, $from, $next;
push @frags, [ @cross, $next ];
}
else # pass thru bbox?
{ my @cross = _cross_inside $bbox, $from, $next;
push @frags, \@cross if @cross;
}
($from, $fromin) = ($next, $nextin);
}
# Glue last to first?
if( @frags >= 2
&& $frags[0][0][0] == $frags[-1][-1][0] # X
&& $frags[0][0][1] == $frags[-1][-1][1] # Y
)
{ my $last = pop @frags;
pop @$last;
unshift @{$frags[0]}, @$last;
}
@frags;
}
#
### Some helper functions
#
sub _inside($$)
{ my ($bbox, $point) = @_;
$bbox->[0] <= $point->[0]+0.00001
&& $point->[0] <= $bbox->[2]+0.00001 # X
&& $bbox->[1] <= $point->[1]+0.00001
&& $point->[1] <= $bbox->[3]+0.00001; # Y
}
sub _sector($$) # left-top 678,345,012 right-bottom
{ my ($bbox, $point) = @_;
my $xsector = $point->[0] < $bbox->[0] ? 0
: $point->[0] < $bbox->[2] ? 1
: 2;
my $ysector = $point->[1] < $bbox->[1] ? 0
: $point->[1] < $bbox->[3] ? 1
: 2;
$ysector * 3 + $xsector;
}
sub _cross($$$)
{ my ($bbox, $from, $to) = @_;
my ($xmin, $ymin, $xmax, $ymax) = @$bbox;
my @cross =
( _cross_x($xmin, $from, $to)
, _cross_x($xmax, $from, $to)
, _cross_y($ymin, $from, $to)
, _cross_y($ymax, $from, $to)
);
# order the results
$from->[0] < $to->[0] ? sort({$a->[0] <=> $b->[0]} @cross)
: $from->[0] > $to->[0] ? sort({$b->[0] <=> $a->[0]} @cross)
: $from->[1] < $to->[1] ? sort({$a->[1] <=> $b->[1]} @cross)
: sort({$b->[1] <=> $a->[1]} @cross);
}
sub _cross_inside($$$)
{ my ($bbox, $from, $to) = @_;
grep _inside($bbox, $_), _cross($bbox, $from, $to);
}
sub _remove_doubles(@)
{ my $this = shift or return ();
my @ret = $this;
while(@_)
{ my $this = shift;
next if $this->[0]==$ret[-1][0] && $this->[1]==$ret[-1][1];
push @ret, $this;
}
@ret;
}
sub _cross_x($$$)
{ my ($x, $from, $to) = @_;
my ($fx, $fy) = @$from;
my ($tx, $ty) = @$to;
return () unless $fx < $x && $x < $tx || $tx < $x && $x < $fx;
my $y = $fy + ($x - $fx)/($tx - $fx) * ($ty - $fy);
(($fy <= $y && $y <= $ty) || ($ty <= $y && $y <= $fy)) ? [$x,$y] : ();
}
sub _cross_y($$$)
{ my ($y, $from, $to) = @_;
my ($fx, $fy) = @$from;
my ($tx, $ty) = @$to;
return () unless $fy < $y && $y < $ty || $ty < $y && $y < $fy;
my $x = $fx + ($y - $fy)/($ty - $fy) * ($tx - $fx);
(($fx <= $x && $x <= $tx) || ($tx <= $x && $x <= $fx)) ? [$x,$y] : ();
}
1;
Math-Polygon-1.11/lib/Math/Polygon/Surface.pm 0000644 0001750 0000144 00000004555 15005156512 021515 0 ustar 00markov users 0000000 0000000 # Copyrights 2004-2025 by [Mark Overmeer ].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Math-Polygon. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package Math::Polygon::Surface;{
our $VERSION = '1.11';
}
use Math::Polygon;
use strict;
use warnings;
sub new(@)
{ my $thing = shift;
my $class = ref $thing || $thing;
my @poly;
my %options;
while(@_)
{ if(!ref $_[0]) { my $k = shift; $options{$k} = shift }
elsif(ref $_[0] eq 'ARRAY') {push @poly, shift}
elsif($_[0]->isa('Math::Polygon')) {push @poly, shift}
else { die "Illegal argument $_[0]" }
}
$options{_poly} = \@poly if @poly;
(bless {}, $class)->init(\%options);
}
sub init($$)
{ my ($self, $args) = @_;
my ($outer, @inner);
if($args->{_poly})
{ ($outer, @inner) = @{$args->{_poly}};
}
else
{ $outer = $args->{outer}
or die "ERROR: surface requires outer polygon\n";
@inner = @{$args->{inner}} if defined $args->{inner};
}
foreach ($outer, @inner)
{ next unless ref $_ eq 'ARRAY';
$_ = Math::Polygon->new(points => $_);
}
$self->{MS_outer} = $outer;
$self->{MS_inner} = \@inner;
$self;
}
#------------
sub outer() { shift->{MS_outer} }
sub inner() { @{shift->{MS_inner}} }
#------------
sub bbox() { shift->outer->bbox }
sub area()
{ my $self = shift;
my $area = $self->outer->area;
$area -= $_->area for $self->inner;
$area;
}
sub perimeter()
{ my $self = shift;
my $per = $self->outer->perimeter;
$per += $_->perimeter for $self->inner;
$per;
}
#------------
sub lineClip($$$$)
{ my ($self, @bbox) = @_;
map { $_->lineClip(@bbox) } $self->outer, $self->inner;
}
sub fillClip1($$$$)
{ my ($self, @bbox) = @_;
my $outer = $self->outer->fillClip1(@bbox);
return () unless defined $outer;
$self->new
( outer => $outer
, inner => [ map {$_->fillClip1(@bbox)} $self->inner ]
);
}
sub string()
{ my $self = shift;
"["
. join( "]\n-["
, $self->outer->string
, map {$_->string } $self->inner)
. "]";
}
1;
Math-Polygon-1.11/lib/Math/Polygon/Convex.pod 0000644 0001750 0000144 00000002367 15005156512 021534 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Math::Polygon::Convex - Collection of convex algorithms
=head1 INHERITANCE
Math::Polygon::Convex
is an Exporter
=head1 SYNOPSIS
use Math::Polygon::Convex qw/chainHull_2D/;
my @points = ( [1,2], [2,4], [5,7], [1,2] );
my $poly = chainHull_2D @points;
=head1 DESCRIPTION
The "convex polygon" around a set of points, is the polygon with a minimal
size which contains all points.
This package contains one convex calculation algorithm, but may be extended
with alternative implementations in the future.
=head1 FUNCTIONS
=over 4
=item B(@points)
Each POINT is an ARRAY of two elements: the X and Y coordinate of a point.
Returned is the enclosing convex L object.
Algorithm by Dan Sunday,
F
=back
=head1 SEE ALSO
This module is part of Math-Polygon distribution version 1.11,
built on May 02, 2025. Website: F
=head1 LICENSE
Copyrights 2004-2025 by [Mark Overmeer ]. For other contributors see ChangeLog.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F
Math-Polygon-1.11/lib/Math/Polygon.pod 0000644 0001750 0000144 00000031274 15005156512 020271 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Math::Polygon - Class for maintaining polygon data
=head1 SYNOPSIS
my $poly = Math::Polygon->new( [1,2], [2,4], [5,7], [1,2] );
print $poly->nrPoints;
my @p = $poly->points;
my ($xmin, $ymin, $xmax, $ymax) = $poly->bbox;
my $area = $poly->area;
my $l = $poly->perimeter;
if($poly->isClockwise) { ... };
my $rot = $poly->startMinXY;
my $center = $poly->centroid;
if($poly->contains($point)) { ... };
my $boxed = $poly->lineClip($xmin, $xmax, $ymin, $ymax);
=head1 DESCRIPTION
This class provides an Object Oriented interface around
L, L, and other. Together,
these modules provide basic transformations on 2D polygons in pure perl.
B these computations may show platform dependent rounding
differences. These may also originate from compilation options of
the Perl version you installed.
=head1 METHODS
=head2 Constructors
=over 4
=item $obj-EB(%options, [@points], %options)
=item Math::Polygon-EB(%options, [@points], %options)
You may add %options before and/or after the @points. You may also use
the "points" option to set the points. Each point in @points is
(a references) to an ARRAY with two elements: an X and a Y coordinate.
When C is called as instance method, it is believed that the
new polygon is derived from the callee, and therefore some facts
(like clockwise or anti-clockwise direction) will get copied unless
overruled.
-Option --Default
bbox undef
clockwise undef
points undef
=over 2
=item bbox => [$xmin,$ymin, $xmax,$ymax]
Usually computed from the shape automatically, but can also be
overruled. See L.
=item clockwise => BOOLEAN
Is not specified, it will be computed by the L method
on demand.
=item points => \@points
See L and L.
=back
example: creation of new polygon
my $p = Math::Polygon->new([1,0],[1,1],[0,1],[0,0],[1,0]);
my @p = ([1,0],[1,1],[0,1],[0,0],[1,0]);
my $p = Math::Polygon->new(points => \@p);
=back
=head2 Attributes
=over 4
=item $obj-EB()
Returns the number of points,
=item $obj-EB()
Returns the number of (unique?) points: one less than L.
=item $obj-EB( $index, [$index,...] )
Returns the point with the specified $index or INDEXES. In SCALAR context,
only the first $index is used.
example:
my $point = $poly->point(2);
my ($first, $last) = $poly->point(0, -1);
=item $obj-EB( [FORMAT] )
In LIST context, the points are returned as list, otherwise as
reference to an ARRAY of points.
[1.09] When a FORMAT is given, each coordinate will get processed.
This may be useful to hide platform specific rounding errors. FORMAT
may be a CODE reference or a C alike string.
See L.
example:
my @points = $poly->points;
my $first = $points[0];
my $x0 = $points[0][0]; # == $first->[0] --> X
my $y0 = $points[0][1]; # == $first->[1] --> Y
my @points = $poly->points("%.2f");
=back
=head2 Geometry
=over 4
=item $obj-EB()
Returns the area enclosed by the polygon. The last point of the list
must be the same as the first to produce a correct result. The computed
result is cached.
Function L.
example:
my $area = $poly->area;
print "$area $poly_units ^2\n";
=item $obj-EB()
Returns a list with four elements: (xmin, ymin, xmax, ymax), which describe
the bounding box of the polygon (all points of the polygon are inside that
area). The computation is expensive, and therefore, the results are
cached.
Function L.
example:
my ($xmin, $ymin, $xmax, $ymax) = $poly->bbox;
=item $obj-EB(%options)
Returns a new, beautified version of this polygon.
Function L.
Polygons, certainly after some computations, can have a lot of horrible
artifacts: points which are double, spikes, etc. This functions provided
by this module beautify them. A new polygon is returned.
-Option --Default
remove_spikes
=over 2
=item remove_spikes => BOOLEAN
=back
=item $obj-EB()
Returns the centroid location of the polygon. The last point of the list
must be the same as the first to produce a correct result. The computed
result is cached. Function L.
example:
my $center = $poly->centroid;
my ($cx, $cy) = @$center;
=item $obj-EB()
Make sure the points are in clockwise order.
example:
$poly->clockwise;
=item $obj-EB($point)
Returns a truth value indicating whether the point is inside the polygon
or not. On the edge is inside.
=item $obj-EB()
Make sure the points are in counter-clockwise order.
example:
$poly->counterClockwise
=item $obj-EB($point)
[1.05] Returns the distance of the point to the closest point on the border of
the polygon, zero if the point is on an edge.
=item $obj-EB( <$other | \@points,[$tolerance]> | $points )
Compare two polygons, on the level of points. When the polygons are
the same but rotated, this will return false. See L.
Function L.
example:
if($poly->equal($other_poly, 0.1)) ...
if($poly->equal(\@points, 0.1)) ...
if($poly->equal(@points)) ...
=item $obj-EB()
The points are (in majority) orded in the direction of the hands of the clock.
This calculation is quite expensive (same effort as calculating the area of
the polygon), and the result is therefore cached.
example:
if($poly->isClockwise) ...
=item $obj-EB()
Returns true if the first point of the poly definition is the same
as the last point.
=item $obj-EB()
The length of the line of the polygon. This can also be used to compute
the length of any line: of the last point is not equal to the first, then
a line is presumed; for a polygon they must match.
Function L.
example:
my $fence = $poly->perimeter;
print "fence length: $fence $poly_units\n"
=item $obj-EB( <$other_polygon | \@points, [$tolerance]> | @points )
Compare two polygons, where the polygons may be rotated wrt each
other. This is (much) slower than L, but some algorithms
will cause un unpredictable rotation in the result.
Function L.
example:
if($poly->same($other_poly, 0.1)) ...
if($poly->same(\@points, 0.1)) ...
if($poly->same(@points)) ...
=item $obj-EB()
Returns a new polygon object, where the points are rotated in such a way
that the point which is losest to the left-bottom point of the bounding
box has become the first.
Function L.
=back
=head2 Transformations
Implemented in L: changes on the structure of
the polygon except clipping. All functions return a new polygon object
or undef.
=over 4
=item $obj-EB(%options)
Returns a polygon object with the points snapped to grid points.
See L.
-Option--Default
raster 1.0
=over 2
=item raster => FLOAT
The raster size, which determines the points to round to. The origin
C<[0,0]> is always on a grid-point. When the raster value is zero,
no transformation will take place.
=back
=item $obj-EB(%options)
Mirror the polygon in a line. Only one of the options can be provided.
Some programs call this "flip" or "flop".
-Option--Default
b 0
line
rc undef
x undef
y undef
=over 2
=item b => FLOAT
Only used in combination with option C to describe a line.
=item line => [POINT, POINT]
Alternative way to specify the mirror line. The C and C are
computed from the two points of the line.
=item rc => FLOAT
Description of the line which is used to mirror in. The line is
C. The C equals C<-dy/dx>, the firing angle. If
C is explicitly specified then C is used as constant x: it's
a vertical mirror.
=item x => FLOAT
Mirror in the line C, which means that C stays unchanged.
=item y => FLOAT
Mirror in the line C, which means that C stays unchanged.
=back
=item $obj-EB(%options)
Returns a moved polygon object: all point are moved over the
indicated distance. See L.
-Option--Default
dx 0
dy 0
=over 2
=item dx => FLOAT
Displacement in the horizontal direction.
=item dy => FLOAT
Displacement in the vertical direction.
=back
=item $obj-EB(%options)
Returns a resized polygon object.
See L.
-Option--Default
center [0,0]
scale 1.0
xscale
yscale
=over 2
=item center => $point
=item scale => FLOAT
Resize the polygon with the indicated factor. When the factor is larger
than 1, the resulting polygon with grow, when small it will be reduced in
size. The scale will be respective from the center.
=item xscale => FLOAT
Specific scaling factor in the horizontal direction.
=item yscale => FLOAT
Specific scaling factor in the vertical direction.
=back
=item $obj-EB(%options)
Returns a rotated polygon object: all point are moved over the
indicated distance. See L.
-Option --Default
center [0,0]
degrees 0
radians 0
=over 2
=item center => POINT
=item degrees => FLOAT
specify rotation angle in degrees (between -180 and 360).
=item radians => FLOAT
specify rotation angle in rads (between -pi and 2*pi)
=back
=item $obj-EB(%options)
Returns a polygon object where points are removed.
See L.
-Option --Default
max_points undef
same 0.0001
slope undef
=over 2
=item max_points => INTEGER
First, C and C reduce the number of points. Then, if there
are still more than the specified number of points left, the points with
the widest angles will be removed until the specified maximum number is
reached.
=item same => FLOAT
The distance between two points to be considered "the same" point. The value
is used as radius of the circle.
=item slope => FLOAT
With three points X(n),X(n+1),X(n+2), the point X(n+1) will be removed if
the length of the path over all three points is less than C longer
than the direct path between X(n) and X(n+2).
The slope will not be removed around the starting point of the polygon.
Removing points will change the area of the polygon.
=back
=back
=head2 Clipping
=over 4
=item $obj-EB($box)
Clipping a polygon into rectangles can be done in various ways.
With this algorithm, the parts of the polygon which are outside
the $box are mapped on the borders. The polygon stays in one piece,
but may have vertices which are followed in two directions.
Returned is one polygon, which is cleaned from double points,
spikes and superfluous intermediate points, or C when
no polygon is outside the $box.
Function L.
=item $obj-EB($box)
Returned is a list of ARRAYS-OF-POINTS containing line pieces
from the input polygon.
Function L.
=back
=head2 Display
=over 4
=item $obj-EB( [FORMAT] )
Print the polygon.
[1.09] When a FORMAT is specified, all coordinates will get formatted
first. This may hide platform dependent rounding differences.
=back
=head1 SEE ALSO
This module is part of Math-Polygon distribution version 1.11,
built on May 02, 2025. Website: F
=head1 LICENSE
Copyrights 2004-2025 by [Mark Overmeer ]. For other contributors see ChangeLog.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See F
Math-Polygon-1.11/lib/Math/Polygon.pm 0000644 0001750 0000144 00000013444 15005156512 020122 0 ustar 00markov users 0000000 0000000 # Copyrights 2004-2025 by [Mark Overmeer ].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Math-Polygon. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md
# Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
package Math::Polygon;{
our $VERSION = '1.11';
}
use strict;
use warnings;
use Math::Polygon::Calc;
use Math::Polygon::Clip;
use Math::Polygon::Transform;
sub new(@)
{ my $thing = shift;
my $class = ref $thing || $thing;
my @points;
my %options;
if(ref $thing)
{ $options{clockwise} = $thing->{MP_clockwise};
}
while(@_)
{ if(ref $_[0] eq 'ARRAY') {push @points, shift}
else { my $k = shift; $options{$k} = shift }
}
$options{_points} = \@points;
(bless {}, $class)->init(\%options);
}
sub init($$)
{ my ($self, $args) = @_;
$self->{MP_points} = $args->{points} || $args->{_points};
$self->{MP_clockwise} = $args->{clockwise};
$self->{MP_bbox} = $args->{bbox};
$self;
}
#------------------
sub nrPoints() { scalar @{shift->{MP_points}} }
sub order() { @{shift->{MP_points}} -1 }
sub points(;$)
{ my ($self, $format) = @_;
my $points = $self->{MP_points};
$points = [ polygon_format $format, @$points ] if $format;
wantarray ? @$points : $points;
}
sub point(@)
{ my $points = shift->{MP_points};
wantarray ? @{$points}[@_] : $points->[shift];
}
#------------------
sub bbox()
{ my $self = shift;
return @{$self->{MP_bbox}} if $self->{MP_bbox};
my @bbox = polygon_bbox $self->points;
$self->{MP_bbox} = \@bbox;
@bbox;
}
sub area()
{ my $self = shift;
return $self->{MP_area} if defined $self->{MP_area};
$self->{MP_area} = polygon_area $self->points;
}
sub centroid()
{ my $self = shift;
return $self->{MP_centroid} if $self->{MP_centroid};
$self->{MP_centroid} = polygon_centroid $self->points;
}
sub isClockwise()
{ my $self = shift;
return $self->{MP_clockwise} if defined $self->{MP_clockwise};
$self->{MP_clockwise} = polygon_is_clockwise $self->points;
}
sub clockwise()
{ my $self = shift;
return $self if $self->isClockwise;
$self->{MP_points} = [ reverse $self->points ];
$self->{MP_clockwise} = 1;
$self;
}
sub counterClockwise()
{ my $self = shift;
return $self unless $self->isClockwise;
$self->{MP_points} = [ reverse $self->points ];
$self->{MP_clockwise} = 0;
$self;
}
sub perimeter() { polygon_perimeter shift->points }
sub startMinXY()
{ my $self = shift;
$self->new(polygon_start_minxy $self->points);
}
sub beautify(@)
{ my ($self, %opts) = @_;
my @beauty = polygon_beautify \%opts, $self->points;
@beauty > 2 ? $self->new(points => \@beauty) : ();
}
sub equal($;@)
{ my $self = shift;
my ($other, $tolerance);
if(@_ > 2 || ref $_[1] eq 'ARRAY') { $other = \@_ }
else
{ $other = ref $_[0] eq 'ARRAY' ? shift : shift->points;
$tolerance = shift;
}
polygon_equal scalar($self->points), $other, $tolerance;
}
sub same($;@)
{ my $self = shift;
my ($other, $tolerance);
if(@_ > 2 || ref $_[1] eq 'ARRAY') { $other = \@_ }
else
{ $other = ref $_[0] eq 'ARRAY' ? shift : shift->points;
$tolerance = shift;
}
polygon_same scalar($self->points), $other, $tolerance;
}
sub contains($)
{ my ($self, $point) = @_;
polygon_contains_point($point, $self->points);
}
sub distance($)
{ my ($self, $point) = @_;
polygon_distance($point, $self->points);
}
sub isClosed() { polygon_is_closed(shift->points) }
#------------------
sub resize(@)
{ my $self = shift;
my $clockwise = $self->{MP_clockwise};
if(defined $clockwise)
{ my %args = @_;
my $xscale = $args{xscale} || $args{scale} || 1;
my $yscale = $args{yscale} || $args{scale} || 1;
$clockwise = not $clockwise if $xscale * $yscale < 0;
}
(ref $self)->new
( points => [ polygon_resize @_, $self->points ]
, clockwise => $clockwise
# we could save the bbox calculation as well
);
}
sub move(@)
{ my $self = shift;
(ref $self)->new
( points => [ polygon_move @_, $self->points ]
, clockwise => $self->{MP_clockwise}
, bbox => $self->{MP_bbox}
);
}
sub rotate(@)
{ my $self = shift;
(ref $self)->new
( points => [ polygon_rotate @_, $self->points ]
, clockwise => $self->{MP_clockwise}
# we could save the bbox calculation as well
);
}
sub grid(@)
{ my $self = shift;
(ref $self)->new
( points => [ polygon_grid @_, $self->points ]
, clockwise => $self->{MP_clockwise} # probably
# we could save the bbox calculation as well
);
}
sub mirror(@)
{ my $self = shift;
my $clockwise = $self->{MP_clockwise};
$clockwise = not $clockwise if defined $clockwise;
(ref $self)->new
( points => [ polygon_mirror @_, $self->points ]
, clockwise => $clockwise
# we could save the bbox calculation as well
);
}
sub simplify(@)
{ my $self = shift;
(ref $self)->new
( points => [ polygon_simplify @_, $self->points ]
, clockwise => $self->{MP_clockwise} # probably
, bbox => $self->{MP_bbox} # protect bounds
);
}
#------------------
sub lineClip($$$$)
{ my ($self, @bbox) = @_;
polygon_line_clip \@bbox, $self->points;
}
sub fillClip1($$$$)
{ my ($self, @bbox) = @_;
my @clip = polygon_fill_clip1 \@bbox, $self->points;
@clip or return undef;
$self->new(points => \@clip);
}
#-------------
sub string(;$)
{ my ($self, $format) = @_;
polygon_string($self->points($format));
}
1;
Math-Polygon-1.11/MANIFEST 0000644 0001750 0000144 00000001421 15005156515 015622 0 ustar 00markov users 0000000 0000000 ChangeLog
MANIFEST
Makefile.PL
README
README.md
lib/Math/Polygon.pm
lib/Math/Polygon.pod
lib/Math/Polygon/Calc.pm
lib/Math/Polygon/Calc.pod
lib/Math/Polygon/Clip.pm
lib/Math/Polygon/Clip.pod
lib/Math/Polygon/Convex.pm
lib/Math/Polygon/Convex.pod
lib/Math/Polygon/Surface.pm
lib/Math/Polygon/Surface.pod
lib/Math/Polygon/Transform.pm
lib/Math/Polygon/Transform.pod
t/10box.t
t/11size.t
t/12beauty.t
t/13rot.t
t/14inside.t
t/15distance.t
t/30cross.t
t/31clipl.t
t/32clipf1.t
t/33centroid.t
t/40resize.t
t/41move.t
t/42rotate.t
t/43grid.t
t/44mirror.t
t/45simple.t
t/50chainhull.t
t/90polygon.t
t/91surface.t
xt/99pod.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
Math-Polygon-1.11/README 0000644 0001750 0000144 00000001440 15005156512 015347 0 ustar 00markov users 0000000 0000000 === README for Math-Polygon version 1.11
= Generated on Fri May 2 16:57:14 2025 by OODoc 2.03
There are various ways to install this module:
(1) if you have a command-line, you can do:
perl -MCPAN -e 'install '
(2) if you use Windows, have a look at http://ppm.activestate.com/
(3) if you have downloaded this module manually (as root/administrator)
gzip -d Math-Polygon-1.11.tar.gz
tar -xf Math-Polygon-1.11.tar
cd Math-Polygon-1.11
perl Makefile.PL
make # optional
make test # optional
make install
For usage, see the included manual-pages or
http://search.cpan.org/dist/Math-Polygon-1.11/
Please report problems to
http://rt.cpan.org/Dist/Display.html?Queue=Math-Polygon
Math-Polygon-1.11/xt/ 0000755 0001750 0000144 00000000000 15005156515 015126 5 ustar 00markov users 0000000 0000000 Math-Polygon-1.11/xt/99pod.t 0000644 0001750 0000144 00000000416 15005156512 016255 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use warnings;
use strict;
use Test::More;
BEGIN
{ eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
plan skip_all => "devel home uses OODoc"
if $ENV{MARKOV_DEVEL};
}
all_pod_files_ok();
Math-Polygon-1.11/Makefile.PL 0000644 0001750 0000144 00000002157 15005156512 016447 0 ustar 00markov users 0000000 0000000 use ExtUtils::MakeMaker;
require 5.010;
WriteMakefile
( NAME => 'Math::Polygon'
, VERSION => '1.11'
, PREREQ_PM =>
{ Test::More => 0.47
, Scalar::Util => 1.13
, Math::Trig => 0
}
, AUTHOR => 'Mark Overmeer '
, ABSTRACT => 'basic polygon calculations'
, LICENSE => 'perl_5'
, META_MERGE =>
{ 'meta-spec' => { version => 2 }
, resources =>
{ repository =>
{ type => 'git'
, url => 'https://github.com/markov2/perl5-Math-Polygon.git'
, web => 'https://github.com/markov2/perl5-Math-Polygon'
}
, homepage => 'http://perl.overmeer.net/CPAN/'
, license => [ 'http://dev.perl.org/licenses/' ]
}
}
);
### used by oodist during production of distribution
sub MY::postamble { <<'__POSTAMBLE' }
# for DIST
RAWDIR = ../public_html/math-polygon/raw
DISTDIR = ../public_html/math-polygon/source
# for POD
FIRST_YEAR = 2004
EMAIL = markov@cpan.org
WEBSITE = http://perl.overmeer.net/CPAN/
__POSTAMBLE
Math-Polygon-1.11/ChangeLog 0000644 0001750 0000144 00000011516 15005156512 016246 0 ustar 00markov users 0000000 0000000 == Revision history for Perl extension Math::Polygon
All changes are made by Mark Overmeer unless
explicitly stated differently.
20070425 Request by Christian Sauer: polygon intersection
paper with nice algorithm: http://citeseer.ist.psu.edu/cache/papers/cs/25021/http:zSzzSzfractal.dam.fmph.uniba.skzSz~sccgzSzproceedingszSz1998zSzZalik.pdf/zalik98quick.pdf
20121024 Request by Rick Rutgers: widening polygon contour
version 1.11: Fri 2 May 16:57:09 CEST 2025
Fixes:
- fix metadata [Mohammad S Anwar]
- polygon_same broken tolerance parameter [Graham Knop]
Improvements:
- link to github distributions in meta-data.
- centroid of line will result in middle. For longer flat polys, it
will produce a clean error i.s.o "divide by zero". [Alex Sudakov]
- add .gitignore
version 1.10: Wed 3 Jan 11:04:43 CET 2018
Another release, to test releasing to github.
Changes:
- require perl 5.10
Improvements:
- documentation improvements
version 1.09: Wed 3 Jan 10:56:42 CET 2018
Another release, to test releasing to github.
Improvements:
- format option to object string() and points()
version 1.08: Tue 2 Jan 12:01:29 CET 2018
Improvements:
- convert to GIT
- move to GitHub
- documentation improvements
- indentation tabs should be blanks.
version 1.07: Wed 27 Dec 11:14:00 CET 2017
Fixes:
- float rounding issue in Perl >= 5.27 breaks tests [cpan_testers]
Improvements:
- new ::Calc::polygon_format()
version 1.06: Sun 16 Jul 13:04:43 CEST 2017
Fixes:
- missed a spelling fix. rt.cpan.org#118297 [Gregor Herrmann]
- fix $obj->mirror rt.cpan.org#122487 [Michael Scott]
Improvements:
- remove dependency to Test::Pod
version 1.05: Wed Dec 28 12:55:41 CET 2016
Fixes:
- spelling fix. rt.cpan.org#118297 [Angel Abad]
Improvements:
- add distance to polygon calculation [Andreas Koenig]
- use Perl from PATH when running in tests stand-alone.
version 1.04: Fri 23 Sep 16:03:17 CEST 2016
Fixes:
- contains on vertical edge
rt.cpan.org#118030 [Marcus Robst]
Improvements:
- remove duplicate points in chainHull_2D
reported by [Michael R. Davis]
version 1.03: Tue Jan 21 14:33:07 CET 2014
Improvements:
- add example to centroid, suggested by [Michael R. Davis]
- change documentation style.
version 1.02: Mon Sep 19 12:06:32 CEST 2011
Improvements:
- Added centroid functions, implemented by [Fred Zellinger]
version 1.01: Mon May 25 14:35:26 CEST 2009
Improvements:
- Added Math::Polygon::Convex with chainHull_2D implementation by
[Jari Turkia] with many improvements. Tests in t/50chainhull.t
- do not run t/pod.t in devel environment.
version 1.00: Fri Feb 1 15:32:20 CET 2008
- ::Calc::polygon_is_open() will die on empty polygon
- correct ::Calc::polygon_contains_point() for point on vertical
edge. Spotted by [Rino Ingenito]
version 0.99: Fri Jun 8 16:31:33 CEST 2007
- fillClip1() did not handle empty result connectly, neither
did ::Clip::polygon_fill_clip1(). Reported by [Christian Sauer]
- added t/pod.t
version 0.98: Tue Apr 3 09:38:57 CEST 2007
- missing export of polygon_is_closed [Christian Sauer]
version 0.97: Thu Mar 29 08:48:14 CEST 2007
- fix prototype of polygon_rotate, to fix method rotate()
[Christian Sauer]
version 0.96: Fri Mar 9 14:19:41 CET 2007
- refer to webpage http://perl.overmeer.net/geo
- email address geo@overmeer.net
- removed stuff to create own manual-pages.
- all error messages should start with lower-case
version 0.95: Mon Feb 26 11:23:44 CET 2007
- polygon_contains_point() only work if poly is closed: croak
otherwise. [Dennis Hartigan-O'Connor]
- polygon_is_clockwise() will also croak when the poly is not
closed.
- new polygon_is_closed() and $poly->isClosed.
- use oodist to generate manuals, not own scripts.
- bumped version number to indicate that the module interface
is stable: no major changes expected before 1.00
version 0.004: Fri Jul 21 10:17:44 CEST 2006
- simplify() could get in an endless loop.
- doc updates to fit into Geo::Point doc-set.
- ring detection failed in Calc::polygon_start_minxy(), reported
by [mtworek]
version 0.003: Fri Dec 3 13:20:37 CET 2004
- simplify will average close points. Before, points could get
removed one after the other, until points over a long distance
were stripped. That will not happen anymore.
- polygon_start_minxy/Math::Polygon::startMinXY now returns the
point most close to (xmin,ymin) of the bounding box first. Was
the point with the smallest x.
- new method Math::Polygon::contains(point) and function
Math::Polygon::Calc::polygon_contains_point(point, @poly)
with tests in t/14contains.t
version 0.002: Fri Nov 12 16:05:18 CET 2004
- Created Math::Polygon::Transform, and added loads of test for it
- Math::Polygon added interface to transform routines
version 0.001: Wed Sep 1 17:45:51 CEST 2004
- Initial version
Math-Polygon-1.11/META.yml 0000644 0001750 0000144 00000001364 15005156515 015750 0 ustar 00markov users 0000000 0000000 ---
abstract: 'basic polygon calculations'
author:
- 'Mark Overmeer '
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: Math-Polygon
no_index:
directory:
- t
- inc
requires:
Math::Trig: '0'
Scalar::Util: '1.13'
Test::More: '0.47'
resources:
homepage: http://perl.overmeer.net/CPAN/
license: http://dev.perl.org/licenses/
repository: https://github.com/markov2/perl5-Math-Polygon.git
version: '1.11'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
Math-Polygon-1.11/META.json 0000644 0001750 0000144 00000002472 15005156515 016121 0 ustar 00markov users 0000000 0000000 {
"abstract" : "basic polygon calculations",
"author" : [
"Mark Overmeer "
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : 2
},
"name" : "Math-Polygon",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Math::Trig" : "0",
"Scalar::Util" : "1.13",
"Test::More" : "0.47"
}
}
},
"release_status" : "stable",
"resources" : {
"homepage" : "http://perl.overmeer.net/CPAN/",
"license" : [
"http://dev.perl.org/licenses/"
],
"repository" : {
"type" : "git",
"url" : "https://github.com/markov2/perl5-Math-Polygon.git",
"web" : "https://github.com/markov2/perl5-Math-Polygon"
}
},
"version" : "1.11",
"x_serialization_backend" : "JSON::PP version 4.16"
}