1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
#!/usr/bin/perl
# $Id: clipping.pl 1420 2004-04-30 11:35:18Z lecoanet $
# 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: 1420 $ =~ /(\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;
|
