← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to demos/demos/widget_lib/mkItems.pl

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
demos/demos/widget_lib/mkItems.pl
1
 
 
2
 
 
3
 
# Utility procedures for highlighting the item under the pointer:
4
 
 
5
 
 
6
 
sub itemEnter {
7
 
 
8
 
    my($c) = @_;
9
 
 
10
 
    $mkItems::restoreCmd = '';
11
 
 
12
 
    if ($mkItems->depth == 1) {
13
 
        $mkItems::restoreCmd = '';
14
 
        return;
15
 
    }
16
 
    my $type = $c->type('current');
17
 
    if ($type eq 'window') {
18
 
        $mkItems::restoreCmd = '';
19
 
        return;
20
 
    }
21
 
 
22
 
    if ($type eq 'bitmap') {
23
 
        my $bg = ($c->itemconfigure('current', -background))[4];
24
 
        if (defined $bg) {
25
 
            $mkItems::restoreCmd = "\$c->itemconfigure('current', -background => '$bg');";
26
 
        } else {
27
 
            $mkItems::restoreCmd = "\$c->itemconfigure('current', -background => undef);";
28
 
        }
29
 
        $c->itemconfigure('current', -background => 'SteelBlue2');
30
 
        return;
31
 
    }
32
 
    my $fill = ($c->itemconfigure('current', -fill))[4];
33
 
    if (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc') and not defined $fill) {
34
 
        my $outline = ($c->itemconfigure('current', -outline))[4];
35
 
        $mkItems::restoreCmd = "\$c->itemconfigure('current', -outline => '$outline')";
36
 
        $c->itemconfigure('current', -outline => 'SteelBlue2');
37
 
    } else {
38
 
        $mkItems::restoreCmd = "\$c->itemconfigure('current', -fill => '$fill')";
39
 
        $c->itemconfigure('current', -fill => 'SteelBlue2');
40
 
    }
41
 
 
42
 
} # end itemEnter
43
 
 
44
 
 
45
 
sub itemLeave {
46
 
 
47
 
    local ($c) = @_;
48
 
 
49
 
    eval $mkItems::restoreCmd;
50
 
 
51
 
} # end itemLeave
52
 
 
53
 
 
54
 
# Utility procedures to support dragging of items.
55
 
 
56
 
 
57
 
sub itemStartDrag {
58
 
 
59
 
    my($c, $x, $y) = @_;
60
 
 
61
 
    $mkItems::lastX = $c->canvasx($x);
62
 
    $mkItems::lastY = $c->canvasy($y);
63
 
 
64
 
} # end itemStartDrag
65
 
 
66
 
 
67
 
sub itemDrag {
68
 
 
69
 
    my($c, $x, $y) = @_;
70
 
 
71
 
    $x = $c->canvasx($x);
72
 
    $y = $c->canvasy($y);
73
 
    $c->move('current', $x-$mkItems::lastX, $y-$mkItems::lastY);
74
 
    $mkItems::lastX = $x;
75
 
    $mkItems::lastY = $y;
76
 
 
77
 
} # end itemDrag
78
 
 
79
 
 
80
 
# Utility procedures for stroking out a rectangle and printing what's underneath the rectangle's area.
81
 
 
82
 
 
83
 
$mkItems::areaX1 = 0;
84
 
$mkItems::areaY1 = 0;
85
 
$mkItems::areaX2 = 0;
86
 
$mkItems::areaY2 = 0;
87
 
 
88
 
 
89
 
sub itemMark {
90
 
 
91
 
    my($c, $x, $y) = @_;
92
 
 
93
 
    $mkItems::areaX1 = $c->canvasx($x);
94
 
    $mkItems::areaY1 = $c->canvasy($y);
95
 
    $c->delete('area');
96
 
 
97
 
} # end itemMark
98
 
 
99
 
 
100
 
sub itemStroke {
101
 
 
102
 
    my($c, $x, $y) = @_;
103
 
 
104
 
    $x = $c->canvasx($x);
105
 
    $y = $c->canvasy($y);
106
 
    if (($mkItems::areaX1 != $x) and ($mkItems::areaY1 != $y)) {
107
 
        $c->delete('area');
108
 
        $c->addtag('area', 'withtag', $c->create('rectangle', $mkItems::areaX1, $mkItems::areaY1, $x, $y, -outline => 'black'));
109
 
        $mkItems::areaX2 = $x;
110
 
        $mkItems::areaY2 = $y;
111
 
    }
112
 
 
113
 
} # end itemStroke
114
 
 
115
 
 
116
 
sub itemsUnderArea {
117
 
 
118
 
    my($c) = @_;
119
 
 
120
 
    my $area = $c->find('withtag', 'area');
121
 
    my @items  = ();
122
 
    my $i;
123
 
    foreach $i ($c->find('enclosed', $mkItems::areaX1, $mkItems::areaY1, $mkItems::areaX2, $mkItems::areaY2)) {
124
 
        my @tags = $c->gettags($i); 
125
 
        if (defined($tags[0]) and grep $_ eq 'item', @tags) {
126
 
            push @items, $i;
127
 
        }
128
 
    }
129
 
    @items = 'None' unless @items;
130
 
    print STDOUT 'Items enclosed by area:  ', join(' ', @items), ".\n";
131
 
    @items = ();
132
 
    foreach $i ($c->find('overlapping', $mkItems::areaX1, $mkItems::areaY1, $mkItems::areaX2, $mkItems::areaY2)) {
133
 
        my @tags = $c->gettags($i); 
134
 
        if (defined($tags[0]) and grep $_ eq 'item', @tags) {
135
 
            push @items, $i;
136
 
        }
137
 
    }
138
 
    @items = 'None' unless @items;
139
 
    print STDOUT 'Items overlapping area:  ', join(' ', @items), ".\n";
140
 
 
141
 
} # end itemsUnderArea
142
 
 
143
 
 
144
 
sub butPress {
145
 
 
146
 
    # Procedure that's invoked when the button embedded in the canvas is invoked.
147
 
 
148
 
    my($w, $color) = @_;
149
 
 
150
 
    my $i = $w->create(qw(text 25c 18.1c -anchor n), -text => 'Ouch!!', -fill => $color);
151
 
    $w->after(500, sub { $w->delete($i) });
152
 
 
153
 
} # end butPress
154
 
 
155
 
 
156
 
sub mkItems {
157
 
 
158
 
    # Create a top-level window containing a canvas that displays the various item types and allows them to be selected and
159
 
    # moved.  This demo can be used to test out the point-hit and rectangle-hit code for items.
160
 
 
161
 
    $mkItems->destroy if Exists($mkItems);
162
 
    $mkItems = $top->Toplevel();
163
 
    my $w = $mkItems;
164
 
    dpos $w;
165
 
    $w->title('Canvas Item Demonstration');
166
 
    $w->iconname('Items');
167
 
    $w->minsize(100, 100);
168
 
 
169
 
 
170
 
    my $w_msg = $w->Label(-font => '-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*', -wraplength => '5i',
171
 
                           -justify => 'left', -text => "This window contains a canvas widget with examples of the various " .
172
 
                           "kinds of items supported by canvases.  The following operations are supported:\n  Button-1 " .
173
 
                           "drag:\tmoves item under pointer.\n  Button-2 drag:\trepositions view.\n  Button-3 drag:\t" .
174
 
                           "strokes out area.\n Ctrl+f:\t\tdisplays items under area.");
175
 
    my $w_frame2 = $w->Frame();
176
 
    my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);
177
 
    $w_msg->pack(-side => 'top', -fill => 'x');
178
 
    $w_frame2->pack(-side => 'top', -fill => 'both', -expand => 'yes');
179
 
    $w_ok->pack(-side => 'bottom', -pady => '5', -anchor => 'center');
180
 
 
181
 
    my $c = $w_frame2->Canvas(-scrollregion => ['0c', '0c', '30c', '24c'], -width => '15c', -height => '10c',
182
 
                        -relief => 'sunken', -bd => 2);
183
 
    my $w_frame2_vscroll = $w_frame2->Scrollbar(-command => ['yview', $c]);
184
 
    my $w_frame2_hscroll = $w_frame2->Scrollbar(-orient => 'horiz', -command => ['xview', $c]);
185
 
    $c->configure(-xscrollcommand => ['set', $w_frame2_hscroll]);
186
 
    $c->configure(-yscrollcommand => ['set', $w_frame2_vscroll]);
187
 
    $w_frame2_hscroll->pack(-side => 'bottom', -fill => 'x');
188
 
    $w_frame2_vscroll->pack(-side => 'right', -fill => 'y');
189
 
    $c->pack(-expand => 'yes', -fill => 'both');
190
 
    
191
 
    # Display a 3x3 rectangular grid.
192
 
 
193
 
    $c->create(qw(rect 0c 0c 30c 24c -width 2));
194
 
    $c->create(qw(line 0c 8c 30c 8c -width 2));
195
 
    $c->create(qw(line 0c 16c 30c 16c -width 2));
196
 
    $c->create(qw(line 10c 0c 10c 24c -width 2));
197
 
    $c->create(qw(line 20c 0c 20c 24c -width 2));
198
 
 
199
 
    $font1 = '-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*';
200
 
    $font2 = '-Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*';
201
 
    if ($mkItems->depth > 1) {
202
 
        $blue = 'DeepSkyBlue3';
203
 
        $red = 'red';
204
 
        $bisque = 'bisque3';
205
 
        $green = 'SeaGreen3';
206
 
    } else {
207
 
        $blue = 'black';
208
 
        $red = 'black';
209
 
        $bisque = 'black';
210
 
        $green = 'black';
211
 
    }
212
 
 
213
 
    # Set up demos within each of the areas of the grid.
214
 
 
215
 
    $c->create(qw(text 5c .2c -text Lines -anchor n));
216
 
    $c->create(qw(line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m), -fill => $blue, qw(-cap butt -join miter -tags item));
217
 
    $c->create(qw(line 4.67c 1c 4.67c 4c -arrow last -tags item));
218
 
    $c->create(qw(line 6.33c 1c 6.33c 4c -arrow both -tags item));
219
 
    $c->create(qw(line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c
220
 
                  8.4c 4.4c -width 3), -fill => $red, qw(-tags item));
221
 
    $c->create(qw(line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c), -stipple => '@'.Tk->findINC('demos/images/grey.25'),
222
 
               qw(-arrow both), -arrowshape => [15, 15, 7], qw(-tags item));
223
 
    $c->create(qw(line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c -cap round -join round -tags item));
224
 
 
225
 
    $c->create(qw(text 15c .2c), -text => 'Curves (smoothed lines)', qw(-anchor n));
226
 
    $c->create(qw(line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on), -fill =>$blue, qw(-tags item));
227
 
    $c->create(qw(line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on -arrow both -width 3 -tags item));
228
 
    $c->create(qw(line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round),
229
 
               -stipple => '@'.Tk->findINC('demos/images/grey.25'), -fill => $red, qw(-tags item));
230
 
 
231
 
    $c->create(qw(text 25c .2c -text Polygons -anchor n));
232
 
    $c->create(qw(polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c),
233
 
               -fill => $green, qw( -tags item));
234
 
    $c->create(qw(polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c 29c 4c 29c 4c), -fill => $red,
235
 
               qw(-smooth on -tags item));
236
 
    $c->create(qw(polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c),
237
 
               -stipple => '@'.Tk->findINC('demos/images/grey.25'), qw( -tags item));
238
 
 
239
 
    $c->create(qw(text 5c 8.2c -text Rectangles -anchor n));
240
 
    $c->create(qw(rectangle 1c 9.5c 4c 12.5c), -outline => $red, qw(-width 3m -tags item));
241
 
    $c->create(qw(rectangle 0.5c 13.5c 4.5c 15.5c), -fill => $green, qw(-tags item));
242
 
    $c->create(qw(rectangle 6c 10c 9c 15c), -outline => undef, -stipple => '@'.Tk->findINC('demos/images/grey.25'), -fill => $blue,
243
 
               qw(-tags item));
244
 
 
245
 
    $c->create(qw(text 15c 8.2c -text Ovals -anchor n));
246
 
    $c->create(qw(oval 11c 9.5c 14c 12.5c), -outline => $red, qw(-width 3m -tags item));
247
 
    $c->create(qw(oval 10.5c 13.5c 14.5c 15.5c), -fill => $green, qw(-tags item));
248
 
    $c->create(qw(oval 16c 10c 19c 15c), -outline => undef, -stipple => '@'.Tk->findINC('demos/images/grey.25'), -fill => $blue,
249
 
               qw(-tags item));
250
 
 
251
 
    $c->create(qw(text 25c 8.2c -text Text -anchor n));
252
 
    $c->create(qw(rectangle 22.4c 8.9c 22.6c 9.1c));
253
 
    $c->create(qw(text 22.5c 9c -anchor n -width 4c), -font => $font1, -text => 'A short string of text, word-wrapped, ' .
254
 
               'justified left, and anchored north (at the top).  The rectangles show the anchor points for each piece ' .
255
 
               'of text.', qw(-tags item));
256
 
    $c->create(qw(rectangle 25.4c 10.9c 25.6c 11.1c));
257
 
    $c->create(qw(text 25.5c 11c -anchor w), -font => $font1, -fill => $blue, -text => "Several lines,\n each centered\n" .
258
 
               "individually,\nand all anchored\nat the left edge.", qw(-justify center -tags item));
259
 
    $c->create(qw(rectangle 24.9c 13.9c 25.1c 14.1c));
260
 
    $c->create(qw(text 25c 14c -anchor c), -font => $font2, -fill => $red, -stipple => '@'.Tk->findINC('demos/images/grey.5'),
261
 
               -text => 'Stippled characters', qw(-tags item));
262
 
 
263
 
    $c->create(qw(text 5c 16.2c -text Arcs -anchor n));
264
 
    $c->create(qw(arc 0.5c 17c 7c 20c), -fill => $green, qw(-outline black -start 45 -extent 270 -style pieslice -tags item));
265
 
    $c->create(qw(arc 6.5c 17c 9.5c 20c -width 4m -style arc), -fill => $blue, -stipple => '@'.Tk->findINC('demos/images/grey.25'),
266
 
               qw(-start -135 -extent 270 -tags item));
267
 
    $c->create(qw(arc 0.5c 20c 9.5c 24c -width 4m -style pieslice), -fill => undef, -outline => $red,
268
 
               qw(-start 225 -extent -90 -tags item));
269
 
    $c->create(qw(arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord), -fill => $blue, -outline => undef,
270
 
               qw(-start 45 -extent 270  -tags item));
271
 
 
272
 
    $c->create(qw(text 15c 16.2c -text Bitmaps -anchor n));
273
 
    $c->create(qw(bitmap 13c 20c), -bitmap => '@'.Tk->findINC('demos/images/face'), qw(-tags item));
274
 
    $c->create(qw(bitmap 17c 18.5c), -bitmap => '@'.Tk->findINC('demos/images/noletters'), qw(-tags item));
275
 
    $c->create(qw(bitmap 17c 21.5c), -bitmap => '@'.Tk->findINC('demos/images/letters'), qw(-tags item));
276
 
 
277
 
    $c->create(qw(text 25c 16.2c -text Windows -anchor n));
278
 
    my $c_button = $c->Button(-text => 'Press Me', -command => [sub {butPress(@_)}, $c, $red]);
279
 
    $c->create(qw(window 21c 18c), -window => $c_button, qw(-anchor nw -tags item));
280
 
    my $c_entry = $c->Entry(-width => '20', -relief => 'sunken');
281
 
    $c_entry->insert('end' => 'Edit this text');
282
 
    $c->create(qw(window 21c 21c), -window => $c_entry, qw(-anchor nw -tags item));
283
 
    my $c_scale = $c->Scale(-from => '0', -to => '100', '-length' => '6c', -sliderlength => '.4c', -width => '.5c',
284
 
                             -tickinterval => '0');
285
 
    $c->create(qw(window 28.5c 17.5c), -window => $c_scale, qw(-anchor n -tags item));
286
 
    $c->create(qw(text 21c 17.9c -text Button: -anchor sw));
287
 
    $c->create(qw(text 21c 20.9c -text Entry: -anchor sw));
288
 
    $c->create(qw(text 28.5c 17.4c -text Scale: -anchor s));
289
 
 
290
 
    # Set up event bindings for canvas.
291
 
 
292
 
    $c->bind('item', '<Any-Enter>' => sub {itemEnter(@_)});
293
 
    $c->bind('item', '<Any-Leave>' => sub {itemLeave(@_)});
294
 
    $c->Tk::bind('<1>' => sub {
295
 
        my($c) = @_;
296
 
        my $e = $c->XEvent;
297
 
        itemStartDrag $c, $e->x, $e->y;
298
 
    });
299
 
    $c->Tk::bind('<B1-Motion>' => sub {
300
 
        my($c) = @_;
301
 
        my $e = $c->XEvent;
302
 
        itemDrag $c, $e->x, $e->y;
303
 
    });
304
 
    $c->Tk::bind('<2>' => sub {
305
 
        my($c) = @_;
306
 
        my $e = $c->XEvent;
307
 
        $c->scan('mark', $e->x, $e->y);
308
 
    });
309
 
    $c->Tk::bind('<B2-Motion>' => sub {
310
 
        my ($c) = @_;
311
 
        my $e = $c->XEvent;
312
 
        $c->scan('dragto', $e->x, $e->y);
313
 
    });
314
 
    $c->Tk::bind('<3>' => sub {
315
 
        my($c) = @_;
316
 
        my $e = $c->XEvent;
317
 
        itemMark $c, $e->x, $e->y;
318
 
    });
319
 
    $c->Tk::bind('<B3-Motion>' => sub {
320
 
        my($c) = @_;
321
 
        my $e = $c->XEvent;
322
 
        itemStroke $c, $e->x, $e->y;
323
 
    });
324
 
    $c->Tk::bind('<Control-f>' => sub {
325
 
        my($c) = @_;
326
 
        my $e = $c->XEvent;
327
 
        itemsUnderArea $c;
328
 
    });
329
 
    $w->bind('<Any-Enter>' => [sub {
330
 
        my($w, $c) = @_;
331
 
        my $e = $c->XEvent;
332
 
        $c->Tk::focus;
333
 
    }, $c]);
334
 
 
335
 
} # end mkItems
336
 
 
337
 
 
338
 
1;