view release on metacpan or  search on metacpan

lib/Math/Polygon/Clip.pm  view on Meta::CPAN

# This code is part of Perl distribution Math-Polygon version 2.00.
# The POD got stripped from this file by OODoc version 3.03.
# For contributors see file ChangeLog.

# This software is copyright (c) 2004-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

#oodist: *** DO NOT USE THIS VERSION FOR PRODUCTION ***
#oodist: This file contains OODoc-style documentation which will get stripped
#oodist: during its release in the distribution.  You can use this file for
#oodist: testing, however the code of this development version may be broken!

package Math::Polygon::Clip;{
our $VERSION = '2.00';
}

use parent 'Exporter';

use strict;
use warnings;

our @EXPORT = qw/
	polygon_line_clip
	polygon_fill_clip1
/;

use Log::Report  'math-polygon';
use List::Util    qw/min max/;

use Math::Polygon::Calc;

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 ];