Math-Polygon-1.02/0000755000175000001440000000000011635612066013176 5ustar markovusersMath-Polygon-1.02/Makefile.PL0000644000175000001440000000132311635215752015150 0ustar markovusersuse ExtUtils::MakeMaker; require 5.006; WriteMakefile ( NAME => 'Math::Polygon' , VERSION => '1.02' , PREREQ_PM => { Test::More => 0.47 , Scalar::Util => 1.13 , Math::Trig => 0 , Test::Pod => 1.00 } , AUTHOR => 'Mark Overmeer' , ABSTRACT => 'Polygon calculations' , LICENSE => 'perl' ); ### used by oodist during production of distribution sub MY::postamble { <<'__POSTAMBLE' } # for DIST RAWDIR = ../public_html/polygon/raw DISTDIR = ../public_html/polygon/source LICENSE = artistic # for POD FIRST_YEAR = 2004,2006 EMAIL = perl@overmeer.net WEBSITE = http://perl.overmeer.net/geo/ __POSTAMBLE Math-Polygon-1.02/t/0000755000175000001440000000000011635612066013441 5ustar markovusersMath-Polygon-1.02/t/50chainhull.t0000644000175000001440000000067311635215752015751 0ustar markovusers#!/usr/bin/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.02/t/11size.t0000644000175000001440000000125211635215752014743 0ustar markovusers#!/usr/bin/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.02/t/44mirror.t0000644000175000001440000000216711635215752015317 0ustar markovusers#!/usr/bin/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.02/t/40resize.t0000644000175000001440000000206611635215752015300 0ustar markovusers#!/usr/bin/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.02/t/31clipl.t0000644000175000001440000000457211635215752015106 0ustar markovusers#!/usr/bin/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.02/t/13rot.t0000644000175000001440000000072211635215752014600 0ustar markovusers#!/usr/bin/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.02/t/42rotate.t0000644000175000001440000000171411635215752015276 0ustar markovusers#!/usr/bin/perl use strict; use warnings; use Test::More tests => 6; 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_rotate degrees => 0, @p) , "[0,0], [1,1], [-2,1], [-2,-2], [0,0]" , 'identity' ); is( polygon_string(polygon_rotate radians => 0, @p) , "[0,0], [1,1], [-2,1], [-2,-2], [0,0]" , 'identity' ); is( polygon_string(polygon_rotate degrees => 0, center => [0,0], @p) , "[0,0], [1,1], [-2,1], [-2,-2], [0,0]" , 'identity' ); is( polygon_string(polygon_rotate degrees => +90, @p) , "[0,0], [1,-1], [1,2], [-2,2], [0,0]" , 'rotate +90' ); is( polygon_string(polygon_rotate degrees => -90, @p) , "[0,0], [-1,1], [-1,-2], [2,-2], [0,0]" , 'rotate -90' ); is( polygon_string(polygon_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.02/t/30cross.t0000644000175000001440000000624511635215752015132 0ustar markovusers#!/usr/bin/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.02/t/33centroid.t0000644000175000001440000000122311635215752015602 0ustar markovusers#!/usr/bin/perl use lib '../lib'; use Math::Polygon::Calc 'polygon_centroid'; use warnings; use strict; use Test::More tests => 4; 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])); Math-Polygon-1.02/t/14inside.t0000644000175000001440000000160111635215752015245 0ustar markovusers#!/usr/bin/perl use strict; use warnings; use Test::More tests => 12; 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)'); Math-Polygon-1.02/t/32clipf1.t0000644000175000001440000000164711635215752015162 0ustar markovusers#!/usr/bin/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.02/t/12beauty.t0000644000175000001440000000510111635215752015260 0ustar markovusers#!/usr/bin/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.02/t/41move.t0000644000175000001440000000106011635215752014737 0ustar markovusers#!/usr/bin/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.02/t/43grid.t0000644000175000001440000000116611635215752014727 0ustar markovusers#!/usr/bin/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.02/t/90polygon.t0000644000175000001440000000325711635215752015476 0ustar markovusers#!/usr/bin/perl use strict; use warnings; use Test::More tests => 36; use lib '../lib'; 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); Math-Polygon-1.02/t/99pod.t0000644000175000001440000000041211635215752014570 0ustar markovusers#!/usr/bin/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.02/t/45simple.t0000644000175000001440000000363011635215752015273 0ustar markovusers#!/usr/bin/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.02/t/10box.t0000644000175000001440000000077611635215752014572 0ustar markovusers#!/usr/bin/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.02/t/91surface.t0000644000175000001440000000157011635215752015434 0ustar markovusers#!/usr/bin/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.02/ChangeLog0000644000175000001440000000554111635612063014752 0ustar markovusersRevision history for Perl extension Math::Polygon 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 version 1.02: Mon Sep 19 12:06:32 CEST 2011 - Added centroid functions, implemented by [Fred Zellinger] version 1.01: Mon May 25 14:35:26 CEST 2009 - 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.02/META.yml0000644000175000001440000000111411635612066014444 0ustar markovusers--- #YAML:1.0 name: Math-Polygon version: 1.02 abstract: Polygon calculations author: - Mark Overmeer license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Math::Trig: 0 Scalar::Util: 1.13 Test::More: 0.47 Test::Pod: 1 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Math-Polygon-1.02/lib/0000755000175000001440000000000011635612066013744 5ustar markovusersMath-Polygon-1.02/lib/Math/0000755000175000001440000000000011635612066014635 5ustar markovusersMath-Polygon-1.02/lib/Math/Polygon/0000755000175000001440000000000011635612066016264 5ustar markovusersMath-Polygon-1.02/lib/Math/Polygon/Convex.pod0000644000175000001440000000235111635612064020231 0ustar markovusers=head1 NAME Math::Polygon::Convex - Collection of convex algorithms =head1 INHERITANCE Math::Polygon::Convex is a 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.02, built on September 19, 2011. Website: F =head1 LICENSE Copyrights 2004,2006-2011 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.02/lib/Math/Polygon/Clip.pod0000644000175000001440000000401511635612064017655 0ustar markovusers=head1 NAME Math::Polygon::Clip - frame a polygon in a square =head1 INHERITANCE Math::Polygon::Clip is a 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(ARRAY-BOX, LIST-OF-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(ARRAY-BOX, LIST-OF-POINTS) To be implemented. 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(ARRAY-BOX, OUT-POLY, [IN-POLYS]) To be implemented. A surrounding polygon, with possible inclussions. =item B(ARRAY-BOX, LIST-OF-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.02, built on September 19, 2011. Website: F =head1 LICENSE Copyrights 2004,2006-2011 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.02/lib/Math/Polygon/Calc.pm0000644000175000001440000001615311635612063017467 0ustar markovusers# Copyrights 2004,2006-2011 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.00. use strict; use warnings; package Math::Polygon::Calc; use vars '$VERSION'; $VERSION = '1.02'; use base 'Exporter'; our @EXPORT = qw/ polygon_area polygon_bbox polygon_beautify polygon_equal polygon_is_clockwise polygon_is_closed polygon_clockwise polygon_counter_clockwise polygon_perimeter polygon_same polygon_start_minxy polygon_string polygon_contains_point polygon_centroid /; 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 $interpol = exists $opts{remove_between} ? $opts{remove_between} : 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, @_; } # Algorithms can be found at # http://astronomy.swin.edu.au/~pbourke/geometry/insidepoly/ # 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) }; return 1 if $y==$py && $py==$ny && ($x >= $px || $x >= $nx) && ($x <= $px || $x <= $nx); if( $py == $ny || ($y <= $py && $y <= $ny) || ($y > $py && $y > $ny) || ($x > $px && $x > $nx) ) { ($px, $py) = ($nx, $ny); next; } $inside = !$inside if $px==$nx || $x <= ($y-$py)*($nx-$px)/($ny-$py)+$px; ($px, $py) = ($nx, $ny); } $inside; } sub polygon_centroid(@) { polygon_is_closed(@_) or croak "ERROR: polygon must be closed: begin==end"; 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; } 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]; } 1; Math-Polygon-1.02/lib/Math/Polygon/Clip.pm0000644000175000001440000001107411635612063017511 0ustar markovusers# Copyrights 2004,2006-2011 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.00. use strict; use warnings; package Math::Polygon::Clip; use vars '$VERSION'; $VERSION = '1.02'; use base 'Exporter'; 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); #warn "X: $x,$y <-- $fx,$fy $tx,$ty\n"; (($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); #warn "Y: $x,$y <-- $fx,$fy $tx,$ty\n"; (($fx <= $x && $x <= $tx) || ($tx <= $x && $x <= $fx)) ? [$x,$y] : (); } 1; Math-Polygon-1.02/lib/Math/Polygon/Calc.pod0000644000175000001440000000750511635612064017637 0ustar markovusers=head1 NAME Math::Polygon::Calc - Simple polygon calculations =head1 INHERITANCE Math::Polygon::Calc is a 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(LIST-OF-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(LIST-OF-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([HASH], LIST-OF-POINTS) 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 The optional HASH contains the OPTIONS: -Option --Default remove_between remove_spikes =over 2 =item remove_between => BOOLEAN Simple points in-between are always removed, but more complex points are not: when the line is not parallel to one of the axes, more intensive calculations must take place. This will only be done when this flags is set. NOT IMPLEMENTED YET =item remove_spikes => BOOLEAN =back =item B(LIST-OF-POINTS) 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 algorithm was found at F =item B(LIST-OF-POINTS) Be sure the polygon points are in clockwise order. =item B(POINT, LIST-OF-POINTS) Returns true if the point is unside the closed polygon. =item B(LIST-OF-POINTS) Be sure the polygon points are in counter-clockwise order. =item B(ARRAY-OF-POINTS, ARRAY-OF-POINTS, [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(LIST-OF-POINTS) =item B(POINTS) =item B(LIST-OF-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(ARRAY-OF-POINTS, ARRAY-OF-POINTS, [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(LIST-OF-POINTS) Returns the polygon, where the point which is closest to the left-bottom corner of the bounding box is made first. =item B(LIST-OF-POINTS) =back =head1 SEE ALSO This module is part of Math-Polygon distribution version 1.02, built on September 19, 2011. Website: F =head1 LICENSE Copyrights 2004,2006-2011 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.02/lib/Math/Polygon/Transform.pod0000644000175000001440000001014211635612064020737 0ustar markovusers=head1 NAME Math::Polygon::Transform - Polygon transformation =head1 INHERITANCE Math::Polygon::Transform is a 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, LIST-OF-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, LIST-OF-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, LIST-OF-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, LIST-OF-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, LIST-OF-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, LIST-OF-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.02, built on September 19, 2011. Website: F =head1 LICENSE Copyrights 2004,2006-2011 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.02/lib/Math/Polygon/Surface.pod0000644000175000001440000000603611635612064020363 0ustar markovusers=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 add OPTIONS after and/or before the POLYGONS. You may also use the "outer" and "inner" options. POLYGONS are references to ARRAYs of points, each an ARRAY of X and Y, but better instantiated L objects. -Option--Default inner [] outer undef =over 2 =item inner => ARRAY-OF-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.02, built on September 19, 2011. Website: F =head1 LICENSE Copyrights 2004,2006-2011 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.02/lib/Math/Polygon/Surface.pm0000644000175000001440000000416211635612063020212 0ustar markovusers# Copyrights 2004,2006-2011 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.00. use strict; use warnings; package Math::Polygon::Surface; use vars '$VERSION'; $VERSION = '1.02'; use Math::Polygon; 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.02/lib/Math/Polygon/Transform.pm0000644000175000001440000001653111635612063020600 0ustar markovusers# Copyrights 2004,2006-2011 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.00. use strict; use warnings; package Math::Polygon::Transform; use vars '$VERSION'; $VERSION = '1.02'; use base 'Exporter'; 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; } return @_ unless exists $opts{max_points}; # # 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.02/lib/Math/Polygon/Convex.pm0000644000175000001440000000543011635612063020063 0ustar markovusers# Copyrights 2004,2006-2011 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.00. # Algorithm by Dan Sunday # - http://geometryalgorithms.com/Archive/algorithm_0109/algorithm_0109.htm # Original implementation in Perl by Jari Turkia. use strict; use warnings; package Math::Polygon::Convex; use vars '$VERSION'; $VERSION = '1.02'; use base 'Exporter'; 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 Math::Polygon->new(@H); } 1; Math-Polygon-1.02/lib/Math/Polygon.pod0000644000175000001440000002536111635612064016775 0ustar markovusers=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 OO interface around L and L. =head1 METHODS =head2 Constructors =over 4 =item $obj-EB([OPTIONS], [POINTS], [OPTIONS]) =item Math::Polygon-EB([OPTIONS], [POINTS], [OPTIONS]) You may add OPTIONS after and/or before the POINTS. You may also use the "points" options to get the points listed. POINTS are references to an ARRAY of X and Y. 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 => ARRAY Usually computed from the figure automatically, but can also be specified as [xmin,ymin,xmax, ymax]. See L. =item clockwise => BOOLEAN Is not specified, it will be computed by the L method on demand. =item points => ARRAY-OF-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 uniqe 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. =item $obj-EB In LIST context, the points are returned as list, otherwise as reference to an ARRAY. =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. =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. =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 -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. =item $obj-EB Make sure the points are in clockwise order. =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. =item $obj-EB((OTHER|ARRAY, [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. =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. =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. =item $obj-EB((OTHER|ARRAY, [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. =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 bouding 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 =back =head1 SEE ALSO This module is part of Math-Polygon distribution version 1.02, built on September 19, 2011. Website: F =head1 LICENSE Copyrights 2004,2006-2011 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.02/lib/Math/Polygon.pm0000644000175000001440000001240711635612063016623 0ustar markovusers# Copyrights 2004,2006-2011 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.00. use strict; use warnings; package Math::Polygon; use vars '$VERSION'; $VERSION = '1.02'; 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() { wantarray ? @{shift->{MP_points}} : shift->{MP_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 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_grid @_, $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() { polygon_string(shift->points) } 1; Math-Polygon-1.02/MANIFEST0000644000175000001440000000113011635612064014320 0ustar markovusersChangeLog MANIFEST META.yml Makefile.PL README 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/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 t/99pod.t Math-Polygon-1.02/README0000644000175000001440000000144011635215752014056 0ustar markovusers=== README for Math-Polygon version 1.02 = Generated on Sun Sep 18 00:15:06 2011 by OODoc 2.00 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.02.tar.gz tar -xf Math-Polygon-1.02.tar cd Math-Polygon-1.02 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.02/ Please report problems to http://rt.cpan.org/Dist/Display.html?Queue=Math-Polygon