#*** Cut.pm ***#
# Copyright (C) 2006 by Torsten Knorr
# create-soft@tiscali.de
# All rights reserved!
#-------------------------------------------------
 package Tk::Image::Cut;
#-------------------------------------------------
 use strict;
 use warnings;
 use Tk;
 use Tk::Frame;
 use Tk::FileSelect;
 use Tk::JPEG;
 use Tk::PNG;
 use Tk::Image::Calculation;
#-------------------------------------------------
 @Tk::Image::Cut::ISA = qw(Tk::Frame Tk::Image::Calculation);
 $Tk::Image::Cut::VERSION = '0.07';
 Construct Tk::Widget "Cut";
#-------------------------------------------------
 sub Populate
 	{
 	require Tk::Button;
 	require Tk::BrowseEntry;
 	require Tk::Entry;
 	require Tk::Label;
 	require Tk::Canvas;
 	my ($cut, $args) = @_;
#-------------------------------------------------
 	my @grid = qw(
 		-column	0
 		-row	0
 		-sticky	nswe
 		); 	
 	$cut->{ap_x1} = $cut->{ap_x2} = $cut->{ap_y1} = $cut->{ap_y2} = 1;
#-------------------------------------------------
# 	-aperturecolor
# 	-aperturewidth
# 	-shape	=> rectangle, oval, circle, polygon
# 	-zoom
# 	-shrink
#-------------------------------------------------
 	$cut->{_aperturecolor} = (defined($args->{-aperturecolor}))	?
 		delete($args->{-aperturecolor})	:	"#00FF00";
 	$cut->{_aperturewidth} = (defined($args->{-aperturewidth}))	?
 		delete($args->{-aperturewidth})	:	4;
 	$cut->{_shape} = (defined($args->{-shape}))			?
 		delete($args->{-shape})		:	"rectangle";
 	$cut->{_zoom_out} = (defined($args->{-zoom}))			?
 		delete($args->{-zoom})		:		1;
 	$cut->{_shrink_out} = (defined($args->{-shrink}))			?
 		delete($args->{-shrink})		:		1;
 	$cut->SUPER::Populate($args);
#-------------------------------------------------
 	$cut->{button_select_image} = $cut->Button(
 		-text		=> "Select Image",
 		-command	=> [\&SelectImage, $cut],
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_shape} = $cut->Label(
 		-text		=> "Shape ->",
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{bentry_shape} = $cut->BrowseEntry(
 		-variable		=> \$cut->{_shape},
 		-browsecmd	=> [\&SetShape, $cut]
 		)->grid(
 		@grid,
 		);
 	$cut->{bentry_shape}->insert(qw/
 		end
 		rectangle
 		oval
 		circle
 		polygon
 		/);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_color} = $cut->Button(
 		-text		=> "Select Color",
 		-command	=> [\&SelectColor, $cut],
 		)->grid(
 		@grid
 		);
 	if($cut->{_shape} eq "rectangle")
 		{
 		$cut->{button_color}->configure(
 			-state		=> "disabled",
 			);
 		}
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_width_out} = $cut->Label(
 		-text		=> "Width ->",
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{entry_width_out} = $cut->Entry(
 		-textvariable	=> \$cut->{_new_image_width},
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_height_out} = $cut->Label(
 		-text		=> "Height ->",
 		)->grid(
 		@grid,
 		);
#------------------------------------------------
 	$grid[1]++;
 	$cut->{entry_height_out} = $cut->Entry(
 		-textvariable	=> \$cut->{_new_image_height},
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_increase} = $cut->Button(
 		-text		=> '+',
 		-command	=> [\&ImageIncrease, $cut]
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_reduce} = $cut->Button(
 		-text		=> '-',
 		-command	=> [\&ImageReduce, $cut],
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{label_name_out} = $cut->Label(
 		-text		=> "New Image Name ->",
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{entry_name_out} = $cut->Entry(
 		-textvariable	=> \$cut->{_new_image_name},
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{button_cut} = $cut->Button(
 		-text		=> "Cut",
 		-command	=> [\&ImageCut, $cut],
 		)->grid(
 		@grid,
 		);
#-------------------------------------------------
 	$grid[1]++;
 	$cut->{canvas} = $cut->Scrolled(
 		"Canvas",
 		)->grid(
 		-column		=> 0,
 		-row		=> 1,
 		-columnspan	=> $grid[1],
 		-sticky		=> "nswe",
 		);
#-------------------------------------------------
 	$cut->{childs} = {
 		"ButtonSelectImage"		=> $cut->{button_select_image},
 		"LabelShape"			=> $cut->{label_shape},
 		"bEntryShape"			=> $cut->{bentry_shape},
 		"ButtonColor"			=> $cut->{button_color},
 		"LabelWidthOut"			=> $cut->{label_width_out},
 		"EntryWidthOut"			=> $cut->{entry_width_out},
 		"LabelHeightOut"		=> $cut->{label_height_out},
 		"EntryHeightOut"		=> $cut->{entry_height_out},
 		"ButtonIncrease"			=> $cut->{button_increase},
 		"ButtonReduce"			=> $cut->{button_reduce},
 		"LabelNameOut"			=> $cut->{label_name_out},
 		"EntryNameOut"			=> $cut->{entry_name_out},
 		"ButtonCut"			=> $cut->{button_cut},
 		"Canvas"			=> $cut->{canvas},
 		};
 	$cut->Advertise($_, $cut->{childs}{$_}) for(keys(%{$cut->{childs}}));
 	$cut->Delegates(DEFAULT	=> $cut->{canvas});
 	$cut->ConfigSpecs(DEFAULT	=> ["ADVERTISED"]);
 	}
#-------------------------------------------------
 sub SelectImage
 	{
 	my ($self) = @_;
 	$self->{_zoom_out} = 1;
 	$self->{_shrink_out} = 1;
 	if($self->{file_in} = $self->FileSelect()->Show())
 		{
 		 $self->{canvas}->delete("all");
# GIF, XBM, XPM, BMP, JPEG, PNG, PPM, PGM
 		if($self->{file_in} =~ m/.+?\.(?:jpg|jpeg)$/i)
 			{
 			$self->{image_format} = "JPEG";
 			}
 		elsif($self->{file_in} =~ m/.+?\.([a-zA-Z]{3})$/)
 			{
 			$self->{image_format} = uc($1);
 			}
 		else
 			{
 			print("error in extracting image format at Tk::Image::Cut::SelectImage()\n");
 			$self->{canvas}->createText(10, 10,
 				-text	=> "error in extracting image format",
 				-anchor	=> "nw",
 				);
 			return;
 			} 
 		$self->{image_in} = $self->Photo(
 			-file		=> $self->{file_in},
 			-format		=> $self->{image_format},
 			);
 		$self->{image_in_width} = $self->{image_in}->width();
 		$self->{image_in_height} = $self->{image_in}->height();
 		$self->{canvas}->configure(
 			-scrollregion	=> [0, 0, $self->{image_in_width}, $self->{image_in_height}],
 			); 
 		$self->{canvas}->createImage(0, 0,
 			-image		=> $self->{image_in},
 			-anchor		=> "nw",
 			-tags		=> "image"
 			);
 		if(($self->{canvas}->width() < $self->{image_in_width}) or
 		($self->{canvas}->height() < $self->{image_in_height}))
 			{
 			$self->{canvas}->bind("image", "<Leave>", [\&Scroll, $self, Ev('x'), Ev('y')]);
 			}
 		else
 			{
 			$self->{canvas}->bind("image", "<Leave>", sub { });
 			}
 		$self->CreateAperture();
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub ImageIncrease
 	{
 	my ($self) = @_;
 	if($self->{_shrink_out} > 1) { $self->{_shrink_out}--; }
 	else { $self->{_zoom_out}++; }
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	return 1;
 	}
#-------------------------------------------------
 sub ImageReduce
 	{
 	my ($self) = @_;
 	if($self->{_zoom_out} > 1) { $self->{_zoom_out}--; }
 	else { $self->{_shrink_out}++; }
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	return 1;
 	}
#-------------------------------------------------
 sub ImageCut
 	{
 	my ($self) = @_;
 	my $temp_image = $self->Photo(
 		-file		=> $self->{file_in},
 		-format		=> $self->{image_format}
 		);
 	my $ref_p_out;
 	if($self->{_shape} eq "rectangle")
 		{
 		$ref_p_out = [];
 		}
 	elsif($self->{_shape} eq "oval")
 		{
		$ref_p_out = $self->GetPointsOutOval(
 			$self->{ap_x1}, 
 			$self->{ap_y1}, 
 			$self->{ap_x2}, 
 			$self->{ap_y2}
 			);
 		}
 	elsif($self->{_shape} eq "circle")
 		{
 		$ref_p_out = $self->GetPointsOutCircle(
 			$self->{ap_x1}, 
			$self->{ap_y1}, 
 			$self->{ap_x2}, 
 			$self->{ap_y2}
 			);
 		}	
 	elsif($self->{_shape} eq "polygon")
 		{
 		$ref_p_out = $self->GetPointsOutPolygon(@{$self->{_points_polygon}});
 		}
 	else
 		{
 		warn("unknown picture shape\n");
 		return;
 		}
 	if(defined($self->{_color}))
 		{
 		$temp_image->put($self->{_color}, -to => $_->[0], $_->[1]) for(@{$ref_p_out});
 		}
 	else
 		{
 		$temp_image->transparencySet($_->[0], $_->[1], 1) for(@{$ref_p_out});
 		}	
	$self->{image_out} = $self->Photo(
 		-format	=> $self->{image_format},
 		-width	=> $self->{_new_image_width},
 		-height	=> $self->{_new_image_height}
 		);
 	$self->{image_out}->copy($temp_image,
 		-zoom	=> $self->{_zoom_out},
 		-subsample => $self->{_shrink_out},
 		-from	=> $self->{ap_x1}, $self->{ap_y1}, $self->{ap_x2}, $self->{ap_y2},
 		-to	=> 0, 0, $self->{_new_image_width}, $self->{_new_image_height},
 		);
 	$self->{image_out}->write(
 		$self->{_new_image_name},
 		-format	=> $self->{image_format},
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub CreateAperture
 	{
 	my ($self) = @_;
 	return if(!(defined($self->{image_in})));
 	$self->DeleteBindings();
 	SWITCH:
 		{
#-------------------------------------------------
 ($self->{_shape}eq "rectangle")	&& do
 	{
 	$self->{ap_x1} = int($self->{image_in_width} / 5);
 	$self->{ap_y1} = int($self->{image_in_height} / 5);
 	$self->{ap_x2} = int($self->{image_in_width} * 0.8);
 	$self->{ap_y2} = int($self->{image_in_height} * 0.8);
 	$self->{canvas}->delete("aperture");
 	$self->{canvas}->delete("points_out");
 	$self->{aperture} = $self->{canvas}->createRectangle(
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2},
 		-outline		=> $self->{_aperturecolor},
 		-width		=> $self->{_aperturewidth},
 		-tags		=> "aperture",
 		);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	$self->{canvas}->bind("aperture", "<Motion>", [\&ShowCursor, $self, Ev('x'), Ev('y')]);
 	$self->{canvas}->bind(
 		"aperture", 
 		"<Enter>",
 		sub {  
 		$self->{canvas}->itemconfigure(
 			"aperture",
 			-outline	=> "#FF0000",
 			);
 		}
 		); 
 	$self->{canvas}->bind(
 		"aperture",
 		"<Leave>",
 		sub { $self->{canvas}->itemconfigure(
 			"aperture",
 			-outline	=> $self->{_aperturecolor},
 			);
 		$self->{canvas}->configure( 
 			-cursor		=> "arrow",
 			);
 		});
 	$self->{canvas}->bind("aperture", "<ButtonPress-1>", [\&StartMove, $self, Ev('x'), Ev('y')]);
 	$self->{canvas}->bind("aperture", "<ButtonRelease-1>", [\&EndMove, $self]);
 	last(SWITCH);
 	};
#-------------------------------------------------
 ($self->{_shape} eq "oval")		&& do
 	{
 	for(qw/image aperture points_out/)
 		{
 		$self->{canvas}->bind($_, "<ButtonPress-1>", [\&DrawOval, $self, Ev('x'), Ev('y')]);
 		}
 	last(SWITCH);
 	};
#-------------------------------------------------
 ($self->{_shape} eq "circle")	&& do
 	{
 	for(qw/image aperture points_out/)
 		{
 		$self->{canvas}->bind($_, "<ButtonPress-1>", [\&DrawCircle, $self, Ev('x'), Ev('y')]);
 		}
 	last(SWITCH);
 	};
#-------------------------------------------------
 ($self->{_shape} eq "polygon")	&& do
 	{
 	for(qw/image aperture points_out/)
 		{
 		$self->{canvas}->bind($_, "<ButtonPress-1>", [\&DrawPolygon, $self, Ev('x'), Ev('y')]);
 		}
 	last(SWITCH);
 	};
#-------------------------------------------------
 warn("unknown picture shape\n");
 	}
 	return 1;
 	}
#-------------------------------------------------
 sub DeleteBindings
 	{
 	my ($self) = @_;
 	for my $tag (qw/
 		image 
 		aperture 
 		templine 
 		points_out/)
 		{
 		for my $event (qw/
 			<ButtonPress-1> 
 			<ButtonPress-3>
 			<ButtonRelease-1>
 			<Motion>
 			/)
 			{
 			$self->{canvas}->bind($tag, $event, sub { });
 			}
 		}
 	for(qw/<Enter> <Leave>/)
 		{
 		$self->{canvas}->bind("aperture", $_, sub { });
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub StartDraw
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->{canvas}->delete("aperture");
 	$self->{canvas}->delete("points_out");
 	$canvas->createOval(
 		$self->{ap_x1}, $self->{ap_y1}, $self->{ap_x1}, $self->{ap_y1},
 		-outline		=> $self->{_aperturecolor},
 		-width		=> $self->{_aperturewidth},
 		-tags		=> "aperture"
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub DrawPolygon
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	$self->{canvas}->delete("aperture");
 	$self->{canvas}->delete("points_out");
 	$self->{_point_start_templine} = $self->{_points_polygon} = [$x, $y];
 	$self->{ap_x1} = $self->{ap_x2} = $x;
 	$self->{ap_y1} = $self->{ap_y2} = $y;
 	$canvas->createLine(
 		$x, $y, $x, $y,
 		-tags		=> "templine",
 		-fill		=> "#FF0000",
 		-width		=> $self->{_aperturewidth},
 		);
 	 $canvas->createPolygon(
 			0, 0, 0, 0, 0, 0,
 			-outline		=> $self->{_aperturecolor},
 			-width		=> $self->{_aperturewidth},
 			-fill		=> "#FFFFFF",
 			-stipple		=> "gray25",
 			-tags		=> "aperture",
 			);
 	for(qw/image templine aperture/)
 		{
 		$canvas->bind($_, "<ButtonPress-1>", [\&MovePolygon, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "<ButtonPress-3>", [\&EndDrawPolygon, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "<Motion>", [\&MoveTempLine, $self, Ev('x'), Ev('y')]);
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub MovePolygon
 	{
	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	push(@{$self->{_points_polygon}}, ($x, $y));
 	if($#{$self->{_points_polygon}} >= 5)
 		{
 		$canvas->coords("aperture", @{$self->{_points_polygon}});
 		}
 	else
 		{
 		$canvas->createLine(
 			@{$self->{_point_start_templine}}, $x, $y,
 			-fill		=> $self->{_aperturecolor},
 			-width		=> $self->{_aperturewidth},
 			-tags		=> "start_line",
 			);
 		}
 	$self->{_point_start_templine} = [$x, $y];
 	$canvas->coords(
 		"templine",
 		$x, $y, $x, $y
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub EndDrawPolygon
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	MovePolygon(@_);
 	for(my $i = 0; $i < $#{$self->{_points_polygon}}; $i += 2)
 		{
 		$self->{ap_x1} = $self->{_points_polygon}[$i] if($self->{_points_polygon}[$i] < $self->{ap_x1});
 		$self->{ap_y1} = $self->{_points_polygon}[$i + 1] if($self->{_points_polygon}[$i + 1] < $self->{ap_y1});
 		$self->{ap_x2} = $self->{_points_polygon}[$i] if($self->{_points_polygon}[$i] > $self->{ap_x2});
 		$self->{ap_y2} = $self->{_points_polygon}[$i + 1] if($self->{_points_polygon}[$i + 1] > $self->{ap_y2});
 		}
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->SetImageOutName();
 	my $ref_l_out = $self->GetLinesOutPolygon(@{$self->{_points_polygon}});
	for(@{$ref_l_out})
 		{
 		$canvas->createLine(
 			$_->[0], $_->[1], $_->[2], $_->[3],
 			-width		=> 1,
 			-fill		=> $self->{_color} || "#FFFFFF",
 			-tags		=> "points_out"
 			);
 		}
 	$canvas->delete("start_line");
 	$self->CreateAperture();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveTempLine
 	{
 	my ($canvas, $self, $x, $y) = @_;
	$canvas->coords(
 		"templine",
 		@{$self->{_point_start_templine}}, 
 		$canvas->canvasx($x),
 		$canvas->canvasy($y)
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub DrawCircle
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	StartDraw(@_);
 	for(qw/image aperture/)
 		{
 		$canvas->bind($_, "<Motion>", [\&MoveCircle, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "<ButtonRelease-1>", [\&EndDrawCircle, $self, Ev('x'), Ev('y')]);
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub MoveCircle
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	my $diff_x = ($x - $self->{ap_x1});
 	my $diff_y = ($y - $self->{ap_y1});
 	my $diff_max = (abs($diff_x) < abs($diff_y)) ? abs($diff_y) : abs($diff_x);
	if($diff_x < 0)
 		{
  		$self->{ap_x2} =  ($self->{ap_x1} - $diff_max);
 		}
 	else
 		{
 		$self->{ap_x2} = ($self->{ap_x1} + $diff_max);
 		}
 	if($diff_y < 0)
 		{
 		$self->{ap_y2} =  ($self->{ap_y1} - $diff_max);
 		}
 	else
 		{
 		$self->{ap_y2} =  ($self->{ap_y1} + $diff_max);
 		}
 	$canvas->coords(
 		"aperture",
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2},
 		);
 	$self->SetImageOutHeight();
 	$self->SetImageOutWidth();
 	return 1;
 	}
#-------------------------------------------------
 sub EndDrawCircle
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	MoveCircle(@_);
 	$self->SetImageOutName();
 	my ($ref_l_out) = $self->GetLinesOutCircle(
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2}
 		);
 	for(@{$ref_l_out})
 		{
 		$canvas->createLine(
 			$_->[0], $_->[1], $_->[2], $_->[3],
 			-width		=> 1,
 			-fill		=> $self->{_color} || "#FFFFFF",
 			-tags		=> "points_out"
 			);
 		}
 	$self->CreateAperture();
 	return 1;
 	}
#-------------------------------------------------
 sub DrawOval
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	StartDraw(@_);
 	for(qw/image aperture/)
 		{
 		$canvas->bind($_, "<Motion>", [\&MoveOval, $self, Ev('x'), Ev('y')]);
 		$canvas->bind($_, "<ButtonRelease-1>", [\&EndDrawOval, $self, Ev('x'), Ev('y')]);
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub MoveOval
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$canvas->coords(
 		"aperture",
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2}
 		);
 	$self->SetImageOutHeight();
 	$self->SetImageOutWidth();
 	return 1;
 	} 
#-------------------------------------------------
 sub EndDrawOval
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	MoveOval(@_);
 	$self->SetImageOutName();
 	my ($ref_l_out) = $self->GetLinesOutOval(
 		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2}
 		);
 	for(@{$ref_l_out})
 		{
 		$canvas->createLine(
 			$_->[0], $_->[1], $_->[2], $_->[3],
 			-width		=> 1,
 			-fill		=> $self->{_color} || "#FFFFFF",
 			-tags		=> "points_out"
 			);
 		}
 	$self->CreateAperture();
 	return 1;
 	}
#-------------------------------------------------
 sub Scroll
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	my ($part_x1, $part_x2) = $canvas->xview();
 	my ($part_y1, $part_y2) = $canvas->yview();
 	my $pos_x1 = ($self->{image_in_width} * $part_x1);
 	my $pos_x2 = ($self->{image_in_width} * $part_x2);
 	my $pos_y1 = ($self->{image_in_height} * $part_y1);
 	my $pos_y2 = ($self->{image_in_height} * $part_y2);
 	SWITCH:
 		{
 		(($x > $pos_x2) && ($y < $pos_y2))		&& do
 			{ 
 			$canvas->xviewScroll(1, "units");
 			last(SWITCH);
 			};
 		(($x < $pos_x1) && ($y < $pos_y2))		&& do
 			{
 			$canvas->xviewScroll(-1, "units");
 			last(SWITCH);
 			};
 		(($y > $pos_y2) && ($x < $pos_x2))		&& do
 			{
 			$canvas->yviewScroll(1, "units");
 			last(SWITCH);
 			};
 		(($y < $pos_y1) && ($x < $pos_x2))		&& do
 			{
 			$canvas->yviewScroll(-1, "units");
 			last(SWITCH);
 			};
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub ShowCursor
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	SWITCH:
 	{
 	(($x > ($self->{ap_x1} + 10))	&& 
 	($x < ($self->{ap_x2} - 10))	&&
 	($y > ($self->{ap_y1} - 4))	&&
 	($y < ($self->{ap_y1} + 4)))	&& do
 		{
 		$self->{cursor_style} = "top_side";
 		last SWITCH;
 		};
 	(($x > ($self->{ap_x1} + 10))	&&
 	($x < ($self->{ap_x2} - 10))	&&
 	($y > ($self->{ap_y2} - 4))	&&
 	($y < ($self->{ap_y2} + 4)))	&& do
 		{
 		$self->{cursor_style} = "bottom_side",
 		last SWITCH;
 		};
 	(($y > ($self->{ap_y1} + 10))	&&
 	($y < ($self->{ap_y2} - 10))	&&
 	($x > ($self->{ap_x1} - 4))	&&
 	($x < ($self->{ap_x1} +4)))	&& do
 		{
 		$self->{cursor_style} = "left_side";
 		last SWITCH;
 		};
 	(($y > ($self->{ap_y1} + 10))	&&
 	($y < ($self->{ap_y2} - 10))	&&
 	($x > ($self->{ap_x2} - 4))	&&
 	($x < ($self->{ap_x2} + 4)))	&& do
 		{
 		$self->{cursor_style} = "right_side";
 		last SWITCH;
 		};
 	((($x >= $self->{ap_x1})		&&
 	($x <= ($self->{ap_x1} + 10))	&&
 	($y >= ($self->{ap_y1} - 4))		&&
 	($y <= ($self->{ap_y1} + 4)))	||
 	(($y >= $self->{ap_y1})		&&
 	($y <= ($self->{ap_y1} + 10))	&&
 	($x >= ($self->{ap_x1} - 4))		&&
 	($x <= ($self->{ap_x1} + 4))))	&& do
 		{
 		$self->{cursor_style} = "top_left_corner";
 		last SWITCH;
 		};
 	((($x <= $self->{ap_x2})		&&
 	($x >= ($self->{ap_x2} - 10))		&&
 	($y <= ($self->{ap_y1} + 4))		&&
 	($y >= ($self->{ap_y1} - 4)))		||
 	(($y >= $self->{ap_y1})		&&
 	($y <= ($self->{ap_y1} + 10))	&&
 	($x <= ($self->{ap_x2} + 4))		&&
 	($x >= ($self->{ap_x2} - 4))))	&& do
 		{
 		$self->{cursor_style} = "top_right_corner";
 		last SWITCH;
 		};
 	((($y >= ($self->{ap_y2} - 10))	&&
 	($y <= $self->{ap_y2})		&&
 	($x <= ($self->{ap_x1} + 4))		&&
 	($x >= ($self->{ap_x1} - 4)))		||
 	(($x >= $self->{ap_x1})		&&
 	($x <= ($self->{ap_x1} + 10))	&&
 	($y <= ($self->{ap_y2} + 4))		&&
 	($y >= ($self->{ap_y2} - 4))))	&& do
 		{
 		$self->{cursor_style} = "bottom_left_corner";
 		last SWITCH;
 		};
 	((($x <= $self->{ap_x2})		&&
 	($x >= ($self->{ap_x2} - 10))		&&
 	($y <= ($self->{ap_y2} + 4))		&&
 	($y >= ($self->{ap_y2} - 4)))		||
 	(($y <= $self->{ap_y2})		&&
 	($y >= ($self->{ap_y2} - 10))		&&
 	($x <= ($self->{ap_x2} + 4))		&&
 	($x >= ($self->{ap_x2} - 4))))	&& do
 		{
 		$self->{cursor_style} = "bottom_right_corner";
 		last SWITCH;
 		};
 	$self->{cursor_style} = "arrow";
 	}
 	$self->{canvas}->configure(
 		-cursor		=> $self->{cursor_style},
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub StartMove
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$x = $canvas->canvasx($x);
 	$y = $canvas->canvasy($y);
 	SWITCH:
 	{
 	($self->{cursor_style} eq "top_side")		&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveUpperLine, $self, Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "bottom_side")		&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveUnderLine, $self, Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "left_side")			&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveLeftLine, $self, Ev('x')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "right_side")		&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveRightLine, $self, Ev('x')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "top_left_corner")		&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveUpperLeftCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "top_right_corner")		&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveUpperRightCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "bottom_left_corner")	&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveUnderLeftCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	($self->{cursor_style} eq "bottom_right_corner")	&& do
 		{
 		$canvas->bind("aperture", "<Motion>", [\&MoveUnderRightCorner, $self, Ev('x'), Ev('y')]);
 		last SWITCH;
 		};
 	$canvas->bind("aperture", "<Motion>", sub { });
 	}
 	return 1;
 	}
#-------------------------------------------------
 sub EndMove
 	{
 	my ($canvas, $self) = @_;
 	$canvas->bind("aperture", "<Motion>", [\&ShowCursor, $self, Ev('x'), Ev('y')]);
 	$self->SetImageOutName();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUpperLine
 	{
 	my ($canvas, $self, $y) = @_;
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUnderLine
 	{
 	my ($canvas, $self, $y) = @_;
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveLeftLine
 	{
 	my($canvas, $self, $x) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->SetImageOutWidth();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveRightLine
 	{
 	my ($canvas, $self, $x) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->SetImageOutWidth();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUpperLeftCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUpperRightCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->{ap_y1} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#--------------------------------------------------
 sub MoveUnderLeftCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x1} = $canvas->canvasx($x);
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight(); 
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub MoveUnderRightCorner
 	{
 	my ($canvas, $self, $x, $y) = @_;
 	$self->{ap_x2} = $canvas->canvasx($x);
 	$self->{ap_y2} = $canvas->canvasy($y);
 	$self->SetImageOutWidth();
 	$self->SetImageOutHeight();
 	$self->Move();
 	return 1;
 	}
#-------------------------------------------------
 sub Move
 	{
 	my ($self) = @_;
 	 $self->{canvas}->coords(
 		"aperture", 
		$self->{ap_x1},
 		$self->{ap_y1},
 		$self->{ap_x2},
 		$self->{ap_y2},
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub SetImageOutWidth
 	{
 	my ($self) = @_;
 	($self->{ap_x1}, $self->{ap_x2}) = ($self->{ap_x2}, $self->{ap_x1}) if($self->{ap_x1} > $self->{ap_x2});
 	($self->{ap_y1}, $self->{ap_y2}) = ($self->{ap_y2}, $self->{ap_y1}) if($self->{ap_y1} > $self->{ap_y2});
 	$self->{_new_image_width} = 
 		int(
 		($self->{ap_x2} - $self->{ap_x1} + 1) *
 		($self->{_zoom_out} / $self->{_shrink_out})
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub SetImageOutHeight
 	{
 	my ($self) = @_;
 	($self->{ap_x1}, $self->{ap_x2}) = ($self->{ap_x2}, $self->{ap_x1}) if($self->{ap_x1} > $self->{ap_x2});
 	($self->{ap_y1}, $self->{ap_y2}) = ($self->{ap_y2}, $self->{ap_y1}) if($self->{ap_y1} > $self->{ap_y2});
 	$self->{_new_image_height} =
 		int(
 		($self->{ap_y2} - $self->{ap_y1} + 1) *
 		($self->{_zoom_out} / $self->{_shrink_out})
 		);
 	return 1;
 	}
#-------------------------------------------------
 sub SetImageOutName
 	{
 	my ($self) = @_;
 	$self->{file_in} =~ m/(.+?)(\.\w{3,4})$/;
 	$self->{_new_image_name} = $1 . '_' . $self->{_new_image_width} . 'X' . $self->{_new_image_height} . $2; 
 	return 1;
 	}
#-------------------------------------------------
 sub SetShape
 	{
 	my ($self) = @_;
 	SWITCH:
 		{
 		($self->{_shape} eq "rectangle")	&& do
 			{
 			$self->{button_color}->configure(
 				-state		=> "disabled"
 				);
 			$self->CreateAperture();
 			last(SWITCH);
 			};
 		(($self->{_shape} eq "oval") or
 		($self->{_shape} eq "circle") or	
 		($self->{_shape} eq "polygon"))	&& do
 			{
 			$self->{canvas}->delete("aperture");
 			$self->{canvas}->delete("points_out");
 			$self->{button_color}->configure(
 				-state		=> "normal"
 				);
 			$self->CreateAperture();
 			last(SWITCH);
 			};
 		}
 	return 1;
 	}
#-------------------------------------------------
 sub SelectColor
 	{
 	my ($self) = @_;
 	$self->{_color} = undef;
 	$self->{_color} = $self->chooseColor();
 	$self->{canvas}->itemconfigure(
 		"points_out",
 		-fill		=> $self->{_color} || "#FFFFFF"
 		);
 	return 1;
 	}
#-------------------------------------------------
1;
#-------------------------------------------------
__END__

=head1 NAME

Tk::Image::Cut - Perl extension for a graphic user interface to cut pictures.

=for category Derived Widgets

=head1 SYNOPSIS

 use Tk::Image::Cut;
 my $mw = MainWindow->new();
 $mw->title("Picture-Cutter");
 $mw->geometry("+5+5");
 my $cut = $mw->Cut()->grid();
 $mw->Button(
 	-text		=> "Exit",
 	-command	=> sub { exit(); },
 	)->grid();
 for(qw/
 	ButtonSelectImage
 	LabelShape
 	bEntryShape
 	ButtonColor
 	LabelWidthOut
 	EntryWidthOut
 	LabelHeightOut
 	EntryHeightOut
 	ButtonIncrease
 	ButtonReduce
 	LabelNameOut
 	EntryNameOut
 	ButtonCut
 	/)
 	{
 	$cut->Subwidget($_)->configure(
 		-font		=> "{Times New Roman} 10 {bold}",
 		);
 	}
 for(qw/
 	bEntryShape
 	EntryWidthOut
 	EntryHeightOut
 	EntryNameOut
 	Canvas
 	/)
 	{
 	$cut->Subwidget($_)->configure(
 		-background	=> "#FFFFFF",
 		);
 	}
 for(qw/
 	bEntryShape
 	EntryWidthOut
 	EntryHeightOut
 	/)
 	{
 	$cut->Subwidget($_)->configure(
 		-width		=> 6,
 		);
 	}
 $cut->Subwidget("EntryNameOut")->configure(
 		-width		=> 40,
 		);
 $cut->Subwidget("Canvas")->configure(
 	-width		=> 1000,
 	-height		=> 800,
 	);
 MainLoop();

=head1 DESCRIPTION

 Perl extension for a graphic user interface to cut pictures.
 The module is a mixed widget from Buttons, Labels, BrowseEntry, Entrys and Canvas widgets.
 I hope the graphic user interface is simple enough to be understood without great declarations.
 It can be used as an independent application or just like how any other widget. 
 Try out the test.pl program.You can select between four cutting forms.
 "rectangle", "oval", "circle" or "polygon"
 In order to cut out pictures in circular form or ovally click
 with the left mouse button onto the upper left corner and hold the
 button pressed while the mouse is moved.
 In order to cut pictures in polygon form you click with the left mouse button 
 on the first point and draw the mouse to the next point. If you have drawn 
 the last point you click with the right mouse button.

 You can use all standard widget options.

=head1 CONSTRUCTOR AND INITIALIZATION

 use Tk;
 use Tk::Image::Cut;
 my $mw = MainWidow->new();
 my $cut = $mw->Cut(
 	-aperturewidth	=> 2,
 	-aperturecolor	=> "#0000FF",
 	-shape		=> "oval",
 	-zoom		=> 2,
 	-shrink		=> 1
 	)->pack();
 $cut->Subwidget("Canvas")->configure(
 	-width		=> 1000,
 	-height		=> 800,
 	);
 MainLoop();

=head1 WIDGET SPECIFIC OPTINOS

=item	-aperturecolor

The margin color of the aperture. default: "#00FF00" (green)

=item 	-aperturewidth

The border of the aperture. default: 4

=item 	-shape

The shape of the aperture "rectangle", "oval", "circle" or "polygon". default: "rectangle"

=item	-zoom

default: 1

=item 	-shrink

default: 1

=head1 INSERTED WIDGETS

=item <ButtonSelectImage>

Selecting the picture to be worked on.

=item <LabelShape>

=item <bEntryShape>

You can select between three cutting forms.
 "rectangle", "oval", "circle" or "polygon" default: "rectangle"

=item <ButtonColor>

Define the background color for the picture.
Is no color indicated then transparent is used.

=item <LabelWidthOut>

=item <EntryWidthOut>

Shows the width of the new picture.

=item <LabelHeightOut>

=item <EntryHeightOut>

Shows the height of the new picture.

=item <ButtonIncrease>

Extend the new picture.

=item <ButtonReduce>

Reduce the new picture.

=item <LabelNameOut>

=item <EntryNameOut>

Shows the name of the new picture.
Of course this can be changed any.

=item <ButtonCut>

Creates the new picture.

=item <Canvas>

Shows the picture.
	
=head2 EXPORT

None by default.

=head1 SEE ALSO

 Tk::Image
 Tk::Photo
 Tk::Image::Calculation
 http://www.planet-interkom.de/t.knorr/index.html

=head1 KEYWORDS

image, photo, cut, picture, widget

=head1 	BUGS

 Maybe you'll find some. Please let me know.

=head1 AUTHOR

Torsten Knorr, E<lt>torstenknorr@tiscali.deE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Torsten Knorr

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.9.2 or,
at your option, any later version of Perl 5 you may have available.

=cut