Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | |
2 | ||
3 | sub arrowSetup { | |
4 | ||
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 | |
8 | # for the display. | |
9 | ||
10 | my($c) = @_; | |
11 | ||
12 | # Remember the current box, if there is one. | |
13 | ||
14 | my(@tags) = $c->gettags('current'); | |
15 | my $cur = defined $tags[0] ? $tags[lsearch('box?', @tags)] : ''; | |
16 | ||
17 | # Create the arrow and outline. | |
18 | ||
19 | *v = *demoArrowInfo; | |
20 | $c->delete('all'); | |
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'); | |
27 | ||
28 | # Create the boxes for reshaping the line and arrowhead. | |
29 | ||
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']); | |
36 | ||
37 | # Create three arrows in actual size with the same parameters | |
38 | ||
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?/; | |
48 | ||
49 | # Create a bunch of other arrows and text items showing the current dimensions. | |
50 | ||
51 | $tmp = $v{'x2'}+10; | |
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'); | |
54 | $tmp = $v{'x1'}-10; | |
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'); | |
61 | $tmp = $tmp+25; | |
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'); | |
64 | ||
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-*-*-*-*-*-*'); | |
69 | ||
70 | $v{'count'}++; | |
71 | ||
72 | } # end arrowSetup | |
73 | ||
74 | ||
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 | |
78 | # within the widget. | |
79 | ||
80 | ||
81 | sub arrowMove1 { | |
82 | ||
83 | my($c) = @_; | |
84 | my $e = $c->XEvent; | |
85 | ||
86 | *v = *demoArrowInfo; | |
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); | |
93 | $v{'a'} = $newA; | |
94 | } | |
95 | arrow_err($c) if $err; | |
96 | ||
97 | } # end arrowMove1 | |
98 | ||
99 | ||
100 | sub arrowMove2 { | |
101 | ||
102 | my($c) = @_; | |
103 | my $e = $c->XEvent; | |
104 | ||
105 | *v = *demoArrowInfo; | |
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)); | |
115 | $v{'b'} = $newB; | |
116 | $v{'c'} = $newC; | |
117 | } | |
118 | arrow_err($c) if $errx or $erry; | |
119 | ||
120 | } # end arrowMove2 | |
121 | ||
122 | ||
123 | sub arrowMove3 { | |
124 | ||
125 | my($c) = @_; | |
126 | my $e = $c->XEvent; | |
127 | ||
128 | *v = *demoArrowInfo; | |
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; | |
136 | } | |
137 | arrow_err($c) if $err; | |
138 | ||
139 | } # end arrowMove3 | |
140 | ||
141 | ||
142 | sub arrow_err { | |
143 | ||
144 | my($c) = @_; | |
145 | ||
146 | my $i = $c->create(qw(text .6i .1i -anchor n), -text => "Range error!"); | |
147 | $c->after(4000, sub { $c->delete($i) }); | |
148 | ||
149 | } # end errow_err | |
150 | ||
151 | sub mkArrow { | |
152 | ||
153 | # Create a top-level window containing a canvas demonstration that allows the user to experiment with arrow shapes. | |
154 | ||
155 | $mkArrow->destroy if Exists($mkArrow); | |
156 | $mkArrow = $top->Toplevel(); | |
157 | my $w = $mkArrow; | |
158 | dpos $w; | |
159 | $w->title('Arrowhead Editor Demonstration'); | |
160 | $w->iconname('Arrow'); | |
161 | ||
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'); | |
173 | ||
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]; | |
188 | } else { | |
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]; | |
192 | } | |
193 | arrowSetup $c; | |
194 | $c->bind('box', '<Enter>' => [sub { | |
195 | my($c, @args) = @_; | |
196 | $c->itemconfigure(@args); | |
197 | }, 'current', @{$demoArrowInfo{'activeStyle'}}]); | |
198 | $c->bind('box', '<Leave>' => [sub { | |
199 | my($c, @args) = @_; | |
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; | |
206 | }); | |
207 | $c->bind('box2', '<1>' => sub { | |
208 | $demo_arrowInfo{'motionProc'} = \&arrowMove2; | |
209 | }); | |
210 | $c->bind('box3', '<1>', sub { | |
211 | $demo_arrowInfo{'motionProc'} = \&arrowMove3; | |
212 | }); | |
213 | $c->bind('box', '<B1-Motion>' => sub { | |
214 | &{$demo_arrowInfo{'motionProc'}}(@_); | |
215 | }); | |
216 | $c->Tk::bind('<Any-ButtonRelease-1>', sub {arrowSetup(@_)}); | |
217 | ||
218 | } # end mkArrow | |
219 | ||
220 | 1; |