#!/usr/bin/perl
# $Id$
# this simple sample has been developped by C. Mertz mertz@cena.fr

use Tk;
use Tk::Zinc;
use strict;
use Tk::Checkbutton;

package clipping;

use vars qw( $VERSION );
($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/);

my $defaultfont = '-adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-*';
my $mw = MainWindow->new();
my $zinc = $mw->Zinc(-width => 700, -height => 600,
		     -font => "10x20", # usually fonts are sets in resources
		                       # but for this example it is set in the code!
		     -borderwidth => 3, -relief => 'sunken',
		     )->pack;

my $display_clipping_item_background = 0;
my $clip = 1;

$zinc->add('text', 1,
	   -font => $defaultfont,
	   -text => "You can drag and drop the objects.\n".
	   "There are two groups of objects, a \"tan group\" and a \"blue group\".\n".
	   "Try to move them and discover the clipping area which is a curve.\n".
	   "with two contours",
	   -anchor => 'nw',
	   -position => [10, 10]);


my $clipped_group = $zinc->add('group', 1, -visible => 1);

my $clipping_item = $zinc->add('curve', $clipped_group,
			       [10,100, 690,100, 690,590, 520,350,
				350,590, 180,350, 10,590],
			       -closed => 1,
			       -priority => 1,
			       -fillcolor => "tan2",
			       -linewidth => 0,
			       -filled => $display_clipping_item_background);
$zinc->contour($clipping_item, "add", +1, [200,200, 500,200, 500,250, 200,250]);

############### creating the tan_group objects ################
# the tan_group is atomic, that is is makes all children as a single object
# and sensitive to tan_group callbacks
my $tan_group = $zinc->add('group', $clipped_group,
			   -visible => 1,
			   -atomic => 1,
			   -sensitive => 1,
			   );

$zinc->add('arc', $tan_group,
	   [200, 220, 280, 300],
	   -filled => 1,  -linewidth => 1,
	   -startangle => 45, -extent => 270,
	   -pieslice => 1, -closed => 1,
	   -fillcolor => "tan",
	   );

$zinc->add('curve', $tan_group,
	   [400,400, 440,450,  400,500, 500,500, 460,450, 500,400],
	   -filled => 1,  -fillcolor => "tan",
	   -linecolor => "tan",
	   );

############### creating the blue_group objects ################
# the blue_group is atomic too, that is is makes all children as a single object
# and sensitive to blue_group callbacks
my $blue_group = $zinc->add('group', $clipped_group,
			    -visible => 1,
			    -atomic => 1,
			    -sensitive => 1,
			    );

$zinc->add('rectangle', $blue_group,
	   [570,180,  470,280],
	   -filled => 1,  -linewidth => 1,
	   -fillcolor => "blue2",
	   );

$zinc->add('curve', $blue_group,
	   [200,400, 200,500, 300,500, 300,400, 300,300],
	   -filled => 1,  -fillcolor => "blue",
	   -linewidth => 0,
	   );


$zinc->itemconfigure($clipped_group, -clip => $clipping_item);


###################### drag and drop callbacks ############
# for both tan_group and blue_group
$zinc->bind($tan_group, '<ButtonPress-1>' => [\&press, $tan_group, \&motion]);
$zinc->bind($tan_group, '<ButtonRelease-1>' => \&release);
$zinc->bind($blue_group, '<ButtonPress-1>' => [\&press, $blue_group, \&motion]);
$zinc->bind($blue_group, '<ButtonRelease-1>' => \&release);

my ($x_orig, $y_orig);
sub press {
    my ($zinc, $group, $action) = @_;
    my $ev = $zinc->XEvent();
    $x_orig = $ev->x;
    $y_orig = $ev->y;
    $zinc->Tk::bind('<Motion>', [$action, $group]);
}

sub motion {
    my ($zinc, $group) = @_;
    my $ev = $zinc->XEvent();
    my $x = $ev->x;
    my $y = $ev->y;

    $zinc->translate($group, $x-$x_orig, $y-$y_orig);
    $x_orig = $x;
    $y_orig = $y;
}

sub release {
    my ($zinc) = @_;
    $zinc->Tk::bind('<Motion>', '');
}
###################### toggle buttons at the bottom #######
my $row = $mw->Frame()->pack();
$row->Checkbutton(-text => 'Show clipping item',
		 -variable => \$display_clipping_item_background,
		 -command => \&display_clipping_area)->pack;	   

$row->Checkbutton(-text => 'Clip',
		 -variable => \$clip,
		 -command => \&clip)->pack;	   

sub display_clipping_area {
    $zinc->itemconfigure($clipping_item, -filled => $display_clipping_item_background);
}

sub clip {
    if ($clip) {
	$zinc->itemconfigure($clipped_group, -clip => $clipping_item);
    }
    else {
	$zinc->itemconfigure($clipped_group, -clip => undef);
    }
}

Tk::MainLoop;