5
# The procedure below completely regenerates all the text and graphics in the canvas window. It's called when the canvas
6
# is initially created, and also whenever any of the parameters of the arrow head are changed interactively. The argument
7
# is the name of the canvas widget to be regenerated, and also the name of a global variable containing the parameters
12
# Remember the current box, if there is one.
14
my(@tags) = $c->gettags('current');
15
my $cur = defined $tags[0] ? $tags[lsearch('box?', @tags)] : '';
17
# Create the arrow and outline.
21
$c->create('line', $v{'x1'}, $v{'y'}, $v{'x2'}, $v{'y'}, -width => 10*$v{'width'},
22
-arrowshape => [10*$v{'a'}, 10*$v{'b'}, 10*$v{'c'}], -arrow => 'last', @{$v{'bigLineStyle'}});
23
my $xtip = $v{'x2'}-10*$v{'b'};
24
my $deltaY = 10*$v{'c'}+5*$v{'width'};
25
$c->create('line', $v{'x2'}, $v{'y'}, $xtip, $v{'y'}+$deltaY, $v{'x2'}-10*$v{'a'}, $v{'y'}, $xtip, $v{'y'}-$deltaY,
26
$v{'x2'}, $v{'y'}, -width => 2, -capstyle => 'round', -joinstyle => 'round');
28
# Create the boxes for reshaping the line and arrowhead.
30
$c->create('rectangle', $v{'x2'}-10*$v{'a'}-5, $v{'y'}-5, $v{'x2'}-10*$v{'a'}+5, $v{'y'}+5, @{$v{'boxStyle'}},
31
-tags => ['box1', 'box']);
32
$c->create('rectangle', $xtip-5, $v{'y'}-$deltaY-5, $xtip+5, $v{'y'}-$deltaY+5, @{$v{'boxStyle'}},
33
-tags => ['box2', 'box']);
34
$c->create('rectangle', $v{'x1'}-5, $v{'y'}-5*$v{'width'}-5, $v{'x1'}+5, $v{'y'}-5*$v{'width'}+5, @{$v{'boxStyle'}},
35
-tags => ['box3', 'box']);
37
# Create three arrows in actual size with the same parameters
39
$c->create('line', $v{'x2'}+50, 0, $v{'x2'}+50, 1000, -width => 2);
40
my $tmp = $v{'x2'}+100;
41
$c->create('line', $tmp, $v{'y'}-125, $tmp, $v{'y'}-75, -width => $v{'width'}, -arrow => 'both',
42
-arrowshape => [$v{'a'}, $v{'b'}, $v{'c'}]);
43
$c->create('line', $tmp-25, $v{'y'}, $tmp+25, $v{'y'}, -width => $v{'width'}, -arrow => 'both',
44
-arrowshape =>[$v{'a'}, $v{'b'}, $v{'c'}]);
45
$c->create('line', $tmp-25, $v{'y'}+75, $tmp+25, $v{'y'}+125, -width => $v{'width'}, -arrow => 'both',
46
-arrowshape => [$v{'a'}, $v{'b'}, $v{'c'}]);
47
$c->itemconfigure($cur, @{$v{'activeStyle'}}) if $cur =~ /box?/;
49
# Create a bunch of other arrows and text items showing the current dimensions.
52
$c->create('line', $tmp, $v{'y'}-5*$v{'width'}, $tmp, $v{'y'}-$deltaY, -arrow => 'both', -arrowshape => $v{'smallTips'});
53
$c->create('text', $v{'x2'}+15, $v{'y'}-$deltaY+5*$v{'c'}, -text => $v{'c'}, -anchor => 'w');
55
$c->create('line', $tmp, $v{'y'}-5*$v{'width'}, $tmp, $v{'y'}+5*$v{'width'}, -arrow => 'both',
56
-arrowshape => $v{'smallTips'});
57
$c->create('text', $v{'x1'}-15, $v{'y'}, -text => $v{'width'}, -anchor => 'e');
58
$tmp = $v{'y'}+5*$v{'width'}+10*$v{'c'}+10;
59
$c->create('line', $v{'x2'}-10*$v{'a'}, $tmp, $v{'x2'}, $tmp, -arrow => 'both', -arrowshape => $v{'smallTips'});
60
$c->create('text', $v{'x2'}-5*$v{'a'}, $tmp+5, -text => $v{'a'}, -anchor => 'n');
62
$c->create('line', $v{'x2'}-10*$v{'b'}, $tmp, $v{'x2'}, $tmp, -arrow => 'both', -arrowshape => $v{'smallTips'});
63
$c->create('text', $v{'x2'}-5*$v{'b'}, $tmp+5, -text => $v{'b'}, -anchor => 'n');
65
$c->create('text', $v{'x1'}, 310, -text => "\"-width\" => $v{'width'}", -anchor => 'w',
66
-font => '-Adobe-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*');
67
$c->create('text', $v{'x1'}, 330, -text => "\"-arrowshape\" => [$v{'a'}, $v{'b'}, $v{'c'}]", -anchor => 'w',
68
-font => '-Adobe-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*');
75
# The procedures below are called in response to mouse motion for one of the three items used to change the line width and
76
# arrowhead shape. Each procedure updates one or more of the controlling parameters for the line and arrowhead, and recreates
77
# the display if that is needed. The arguments are the name of the canvas widget, and the x and y positions of the mouse
87
my($x, $y, $err) = ($e->x, $e->y, 0);
88
my $newA = int(($v{'x2'} + 5 - int($c->canvasx($x))) / 10);
89
$newA = 0, $err = 1 if $newA < 0;
90
$newA = 25, $err = 1 if $newA > 25;
91
if ($newA != $v{'a'}) {
92
$c->move('box1', 10 * ($v{'a'} - $newA), 0);
95
arrow_err($c) if $err;
106
my($x, $y, $errx, $erry) = ($e->x, $e->y, 0, 0);
107
my $newB = int(($v{'x2'} + 5 - int($c->canvasx($x))) / 10);
108
$newB = 0, $errx = 1 if $newB < 0;
109
$newB = 25, $errx = 1 if $newB > 25;
110
my $newC = int(($v{'y'} + 5 - int($c->canvasy($y)) - 5 * $v{'width'}) / 10);
111
$newC = 0, $erry = 1 if $newC < 0;
112
$newC = 12, $erry = 1 if $newC > 12;
113
if (($newB != $v{'b'}) or ($newC != $v{'c'})) {
114
$c->move('box2', 10*($v{'b'}-$newB), 10*($v{'c'}-$newC));
118
arrow_err($c) if $errx or $erry;
129
my($x, $y, $err) = ($e->x, $e->y, 0);
130
my $newWidth = int(($v{'y'} + 2 - int($c->canvasy($y))) / 5);
131
$newWidth = 0, $err = 1 if $newWidth < 0;
132
$newWidth = 20, $err = 1 if $newWidth > 20;
133
if ($newWidth != $v{'width'}) {
134
$c->move('box3', 0, 5*($v{'width'}-$newWidth));
135
$v{'width'} = $newWidth;
137
arrow_err($c) if $err;
146
my $i = $c->create(qw(text .6i .1i -anchor n), -text => "Range error!");
147
$c->after(4000, sub { $c->delete($i) });
153
# Create a top-level window containing a canvas demonstration that allows the user to experiment with arrow shapes.
155
$mkArrow->destroy if Exists($mkArrow);
156
$mkArrow = $top->Toplevel();
159
$w->title('Arrowhead Editor Demonstration');
160
$w->iconname('Arrow');
162
my $w_msg = $w->Label(-font => '-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*', -wraplength => '5i',
163
-justify => 'left', -text => 'This widget allows you to experiment with different widths ' .
164
'and arrowhead shapes for lines in canvases. To change the line width or the shape of the ' .
165
'arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on ' .
166
'the right give examples at normal scale. The text at the bottom shows the configuration ' .
167
'options as you\'d enter them for a line.');
168
my $c = $w->Canvas(-width => '500', -height => '350', -relief => 'sunken', -bd => 2);
169
my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);
170
$w_msg->pack(-side => 'top', -fill => 'both');
171
$w_ok->pack(-side => 'bottom', -pady => '5');
172
$c->pack(-expand => 'yes', -fill => 'both');
174
$demoArrowInfo{'a'} = 8;
175
$demoArrowInfo{'b'} = 10;
176
$demoArrowInfo{'c'} = 3;
177
$demoArrowInfo{'width'} = 2;
178
$demoArrowInfo{'motionProc'} = 'arrowMoveNull';
179
$demoArrowInfo{'x1'} = 40;
180
$demoArrowInfo{'x2'} = 350;
181
$demoArrowInfo{'y'} = 150;
182
$demoArrowInfo{'smallTips'} = [5, 5, 2];
183
$demoArrowInfo{'count'} = 0;
184
if ($mkArrow->depth > 1) {
185
$demoArrowInfo{'bigLineStyle'} = [-fill => 'SkyBlue1'];
186
$demoArrowInfo{'boxStyle'} = [-fill => undef, -outline => 'black', -width => 1];
187
$demoArrowInfo{'activeStyle'} = [-fill => 'red', -outline => 'black', -width => 1];
189
$demoArrowInfo{'bigLineStyle'} = [-fill => 'black', -stipple => '@'.Tk->findINC('demos/images/grey.25')];
190
$demoArrowInfo{'boxStyle'} = [-fill => "", -outline => 'black', -width => 1];
191
$demoArrowInfo{'activeStyle'} = [-fill => 'black', -outline => 'black', -width => 1];
194
$c->bind('box', '<Enter>' => [sub {
196
$c->itemconfigure(@args);
197
}, 'current', @{$demoArrowInfo{'activeStyle'}}]);
198
$c->bind('box', '<Leave>' => [sub {
200
$c->itemconfigure(@args);
201
}, 'current', @{$demoArrowInfo{'boxStyle'}}]);
202
$c->bind('box', '<B1-Enter>' => undef);
203
$c->bind('box', '<B1-Leave>' => undef);
204
$c->bind('box1', '<1>' => sub {
205
$demo_arrowInfo{'motionProc'} = \&arrowMove1;
207
$c->bind('box2', '<1>' => sub {
208
$demo_arrowInfo{'motionProc'} = \&arrowMove2;
210
$c->bind('box3', '<1>', sub {
211
$demo_arrowInfo{'motionProc'} = \&arrowMove3;
213
$c->bind('box', '<B1-Motion>' => sub {
214
&{$demo_arrowInfo{'motionProc'}}(@_);
216
$c->Tk::bind('<Any-ButtonRelease-1>', sub {arrowSetup(@_)});
added
removed
demos/demos/widget_lib/mkArrow.pl
