File Coverage

blib/lib/Math/Polygon/Clip.pm
Criterion Covered Total %
statement 82 95 86.3
branch 33 50 66.0
condition 38 45 84.4
subroutine 13 15 86.6
pod 2 2 100.0
total 168 207 81.1


line stmt bran cond sub pod time code
1             # Copyrights 2004-2018 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Math::Polygon. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Math::Polygon::Clip;
10 6     6   177137 use vars '$VERSION';
  6         38  
  6         302  
11             $VERSION = '1.10';
12              
13 6     6   34 use base 'Exporter';
  6         9  
  6         605  
14              
15 6     6   35 use strict;
  6         12  
  6         115  
16 6     6   24 use warnings;
  6         8  
  6         264  
17              
18             our @EXPORT = qw/
19             polygon_line_clip
20             polygon_fill_clip1
21             /;
22              
23 6     6   1265 use Math::Polygon::Calc;
  6         17  
  6         501  
24 6     6   40 use List::Util qw/min max/;
  6         10  
  6         6171  
25              
26             sub _inside($$);
27             sub _cross($$$);
28             sub _cross_inside($$$);
29             sub _cross_x($$$);
30             sub _cross_y($$$);
31             sub _remove_doubles(@);
32              
33              
34             sub polygon_fill_clip1($@)
35 2     2 1 69 { my $bbox = shift;
36 2         5 my ($xmin, $ymin, $xmax, $ymax) = @$bbox;
37 2 50       5 @_ or return (); # empty list of points
38              
39             # Collect all crosspoints with axes, plus the original points
40 2         3 my $next = shift;
41 2         4 my @poly = $next;
42 2         4 while(@_)
43 8         10 { $next = shift;
44 8         11 push @poly, _cross($bbox, $poly[-1], $next), $next;
45             }
46              
47             # crop them to the borders: outside is projected on the sides
48 2         2 my @cropped;
49 2         4 foreach (@poly)
50 14         18 { my ($x,$y) = @$_;
51 14 50       18 $x = $xmin if $x < $xmin;
52 14 100       17 $x = $xmax if $x > $xmax;
53 14 50       18 $y = $ymin if $y < $ymin;
54 14 100       19 $y = $ymax if $y > $ymax;
55 14         29 push @cropped, [$x, $y];
56             }
57              
58 2         9 polygon_beautify {despike => 1}, @cropped;
59             }
60              
61              
62             sub polygon_line_clip($@)
63 11     11 1 38798 { my $bbox = shift;
64 11         22 my ($xmin, $ymin, $xmax, $ymax) = @$bbox;
65              
66 11         13 my @frags;
67 11         12 my $from = shift;
68 11         16 my $fromin = _inside $bbox, $from;
69 11 100       26 push @frags, [ $from ] if $fromin;
70              
71 11         21 while(@_)
72 65         70 { my $next = shift;
73 65         90 my $nextin = _inside $bbox, $next;
74              
75 65 100 100     203 if($fromin && $nextin) # stay within
    100 66        
    100          
76 20         21 { push @{$frags[-1]}, $next;
  20         31  
77             }
78             elsif($fromin && !$nextin) # leaving
79 12         12 { push @{$frags[-1]}, _cross_inside $bbox, $from, $next;
  12         19  
80             }
81             elsif($nextin) # entering
82 12         18 { my @cross = _cross_inside $bbox, $from, $next;
83 12         24 push @frags, [ @cross, $next ];
84             }
85             else # pass thru bbox?
86 21         32 { my @cross = _cross_inside $bbox, $from, $next;
87 21 100       31 push @frags, \@cross if @cross;
88             }
89              
90 65         132 ($from, $fromin) = ($next, $nextin);
91             }
92              
93             # Glue last to first?
94 11 100 100     47 if( @frags >= 2
      66        
95             && $frags[0][0][0] == $frags[-1][-1][0] # X
96             && $frags[0][0][1] == $frags[-1][-1][1] # Y
97             )
98 4         7 { my $last = pop @frags;
99 4         6 pop @$last;
100 4         6 unshift @{$frags[0]}, @$last;
  4         10  
101             }
102              
103 11         33 @frags;
104             }
105              
106             #
107             ### Some helper functions
108             #
109              
110             sub _inside($$)
111 101     101   126 { my ($bbox, $point) = @_;
112              
113 101 100 100     469 $bbox->[0] <= $point->[0]+0.00001
      100        
114             && $point->[0] <= $bbox->[2]+0.00001 # X
115             && $bbox->[1] <= $point->[1]+0.00001
116             && $point->[1] <= $bbox->[3]+0.00001; # Y
117             }
118              
119             sub _sector($$) # left-top 678,345,012 right-bottom
120 0     0   0 { my ($bbox, $point) = @_;
121 0 0       0 my $xsector = $point->[0] < $bbox->[0] ? 0
    0          
122             : $point->[0] < $bbox->[2] ? 1
123             : 2;
124 0 0       0 my $ysector = $point->[1] < $bbox->[1] ? 0
    0          
125             : $point->[1] < $bbox->[3] ? 1
126             : 2;
127 0         0 $ysector * 3 + $xsector;
128             }
129              
130             sub _cross($$$)
131 61     61   12905 { my ($bbox, $from, $to) = @_;
132 61         82 my ($xmin, $ymin, $xmax, $ymax) = @$bbox;
133              
134 61         87 my @cross =
135             ( _cross_x($xmin, $from, $to)
136             , _cross_x($xmax, $from, $to)
137             , _cross_y($ymin, $from, $to)
138             , _cross_y($ymax, $from, $to)
139             );
140              
141             # order the results
142 8         23 $from->[0] < $to->[0] ? sort({$a->[0] <=> $b->[0]} @cross)
143 8         18 : $from->[0] > $to->[0] ? sort({$b->[0] <=> $a->[0]} @cross)
144 0         0 : $from->[1] < $to->[1] ? sort({$a->[1] <=> $b->[1]} @cross)
145 61 100       205 : sort({$b->[1] <=> $a->[1]} @cross);
  0 100       0  
    100          
146             }
147              
148             sub _cross_inside($$$)
149 45     45   61 { my ($bbox, $from, $to) = @_;
150 45         54 grep _inside($bbox, $_), _cross($bbox, $from, $to);
151             }
152              
153             sub _remove_doubles(@)
154 0 0   0   0 { my $this = shift or return ();
155 0         0 my @ret = $this;
156 0         0 while(@_)
157 0         0 { my $this = shift;
158 0 0 0     0 next if $this->[0]==$ret[-1][0] && $this->[1]==$ret[-1][1];
159 0         0 push @ret, $this;
160             }
161 0         0 @ret;
162             }
163              
164             sub _cross_x($$$)
165 126     126   3618 { my ($x, $from, $to) = @_;
166 126         155 my ($fx, $fy) = @$from;
167 126         140 my ($tx, $ty) = @$to;
168 126 100 100     462 return () unless $fx < $x && $x < $tx || $tx < $x && $x < $fx;
      100        
      100        
169 28         61 my $y = $fy + ($x - $fx)/($tx - $fx) * ($ty - $fy);
170 28 50 66     131 (($fy <= $y && $y <= $ty) || ($ty <= $y && $y <= $fy)) ? [$x,$y] : ();
171             }
172              
173             sub _cross_y($$$)
174 126     126   4614 { my ($y, $from, $to) = @_;
175 126         143 my ($fx, $fy) = @$from;
176 126         160 my ($tx, $ty) = @$to;
177 126 100 100     449 return () unless $fy < $y && $y < $ty || $ty < $y && $y < $fy;
      100        
      100        
178 27         52 my $x = $fx + ($y - $fy)/($ty - $fy) * ($tx - $fx);
179 27 50 66     119 (($fx <= $x && $x <= $tx) || ($tx <= $x && $x <= $fx)) ? [$x,$y] : ();
180             }
181              
182              
183              
184             1;