diff options
Diffstat (limited to 'Perl/demos/Tk/demos/zinc_lib/clipping.pl')
| -rw-r--r-- | Perl/demos/Tk/demos/zinc_lib/clipping.pl | 150 |
1 files changed, 0 insertions, 150 deletions
diff --git a/Perl/demos/Tk/demos/zinc_lib/clipping.pl b/Perl/demos/Tk/demos/zinc_lib/clipping.pl deleted file mode 100644 index 4a320e0..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/clipping.pl +++ /dev/null @@ -1,150 +0,0 @@ -#!/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; |