"Fossies" - the Fresh Open Source Software Archive 
"Fossies" - the Fresh Open Source Software Archive A hint: This file contains one or more very long lines, so maybe it is better readable using the pure text view mode that shows the contents as wrapped lines within the browser window.
1 # arrows.pl 2 3 use subs qw/arrow_err arrow_move1 arrow_move2 arrow_move3 arrow_setup/; 4 use vars qw/$TOP/; 5 6 sub arrows { 7 8 # Create a top-level window containing a canvas demonstration that 9 # allows the user to experiment with arrow shapes. 10 11 my($demo) = @_; 12 $TOP = $MW->WidgetDemo( 13 -name => $demo, 14 -text => ['This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you\'d enter them for a canvas line item.', qw/-wraplength 5i/], 15 -title => 'Arrowhead Editor Demonstration', 16 -iconname => 'arrows', 17 ); 18 19 my $c = $TOP->Canvas( 20 -width => '500', 21 -height => '350', 22 -relief => 'sunken', 23 -borderwidth => 2, 24 )->pack(qw/-expand yes -fill both/); 25 26 my %ainfo; # arrow information hash 27 $ainfo{a} = 8; 28 $ainfo{b} = 10; 29 $ainfo{c} = 3; 30 $ainfo{width} = 2; 31 $ainfo{move_sub} = undef; 32 $ainfo{x1} = 40; 33 $ainfo{x2} = 350; 34 $ainfo{'y'} = 150; 35 $ainfo{smallTips} = [5, 5, 2]; 36 $ainfo{count} = 0; 37 38 if ($TOP->depth > 1) { 39 $ainfo{bigLineStyle} = [qw/-fill SkyBlue1/]; 40 $ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/]; 41 $ainfo{activeStyle} = [qw/-fill red -outline black -width 1/]; 42 } else { 43 $ainfo{bigLineStyle} = [ 44 -fill => 'black', 45 -stipple => '@'.Tk->findINC('demos/images/grey.25'), 46 ]; 47 $ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/]; 48 $ainfo{activeStyle} = [qw/-fill black -outline black -width 1/]; 49 } 50 arrow_setup $c, \%ainfo; 51 52 # Bindings to highlight the 3 tiny resize boxes. 53 54 foreach ([qw/<Enter> activeStyle/], [qw/<Leave> boxStyle/]) { 55 $c->bind('box', $_->[0] =>[ 56 sub { 57 my($c, $style) = @_; 58 $c->itemconfigure('current', @{$ainfo{$style}}) 59 }, $_->[1]], 60 ); 61 } 62 $c->bind(qw/box <B1-Enter>/ => 'NoOp'); 63 $c->bind(qw/box <B1-Leave>/ => 'NoOp'); 64 65 # Bindings that select one of the 3 tiny resize boxes' "move code". 66 67 my $n; 68 for $n (1,2,3) { 69 $c->bind("box${n}", '<1>' => 70 sub {$ainfo{move_sub} = \&{"arrow_move${n}"}} 71 ); 72 } 73 74 # Bindings to move a resize box and redraw the arrow. 75 76 $c->bind('box', '<B1-Motion>' => 77 sub {&{$ainfo{move_sub}}($c, \%ainfo)} 78 ); 79 $c->Tk::bind('<Any-ButtonRelease-1>' => [\&arrow_setup, \%ainfo]); 80 81 } # end arrows 82 83 sub arrow_err { 84 85 my($c) = @_; 86 87 my $i = $c->createText(qw/.6i .1i -anchor n -text/ => "Range error!"); 88 $c->after(4000, sub { $c->delete($i) }); 89 90 } # end errow_err 91 92 sub arrow_move1 { 93 94 my($c, $v) = @_; 95 my $e = $c->XEvent; 96 97 my($x, $y, $err) = ($e->x, $e->y, 0); 98 my $newA = int(($v->{x2} + 5 - int($c->canvasx($x))) / 10); 99 $newA = 0, $err = 1 if $newA < 0; 100 $newA = 25, $err = 1 if $newA > 25; 101 if ($newA != $v->{a}) { 102 $c->move('box1', 10 * ($v->{a} - $newA), 0); 103 $v->{a} = $newA; 104 } 105 arrow_err($c) if $err; 106 107 } # end arrow_move1 108 109 sub arrow_move2 { 110 111 my($c, $v) = @_; 112 my $e = $c->XEvent; 113 114 my($x, $y, $errx, $erry) = ($e->x, $e->y, 0, 0); 115 my $newB = int(($v->{x2} + 5 - int($c->canvasx($x))) / 10); 116 $newB = 0, $errx = 1 if $newB < 0; 117 $newB = 25, $errx = 1 if $newB > 25; 118 my $newC = int(($v->{'y'} + 5 - int($c->canvasy($y)) - 5 * $v->{width}) 119 / 10); 120 $newC = 0, $erry = 1 if $newC < 0; 121 $newC = 12, $erry = 1 if $newC > 12; 122 if (($newB != $v->{b}) or ($newC != $v->{c})) { 123 $c->move('box2', 10*($v->{b}-$newB), 10*($v->{c}-$newC)); 124 $v->{b} = $newB; 125 $v->{c} = $newC; 126 } 127 arrow_err($c) if $errx or $erry; 128 129 } # end arrow_move2 130 131 sub arrow_move3 { 132 133 my($c, $v) = @_; 134 my $e = $c->XEvent; 135 136 my($x, $y, $err) = ($e->x, $e->y, 0); 137 my $newWidth = int(($v->{'y'} + 2 - int($c->canvasy($y))) / 5); 138 $newWidth = 0, $err = 1 if $newWidth < 0; 139 $newWidth = 20, $err = 1 if $newWidth > 20; 140 if ($newWidth != $v->{width}) { 141 $c->move('box3', 0, 5*($v->{width}-$newWidth)); 142 $v->{width} = $newWidth; 143 } 144 arrow_err($c) if $err; 145 146 } # end arrow_move3 147 148 sub arrow_setup { 149 150 # The procedure below completely regenerates all the text and graphics in 151 # the canvas window. It's called when the canvas is initially created, 152 # and also whenever any of the parameters of the arrow head are changed 153 # interactively. The argument is the name of the canvas widget to be 154 # regenerated, and also the name of a global variable containing the 155 # parameters for the display. 156 157 my($c, $v) = @_; 158 159 # Remember the current box, if there is one. 160 161 my(@tags) = $c->gettags('current'); 162 my $cur = defined $tags[0] ? $tags[lsearch('box?', @tags)] : ''; 163 164 # Create the arrow and outline. 165 166 $c->delete('all'); 167 $c->createLine($v->{x1}, $v->{'y'}, $v->{x2}, $v->{'y'}, 168 -width => 10*$v->{width}, 169 -arrowshape => [10*$v->{a}, 10*$v->{b}, 10*$v->{c}], 170 -arrow => 'last', @{$v->{bigLineStyle}}); 171 my $xtip = $v->{x2}-10*$v->{b}; 172 my $deltaY = 10*$v->{c}+5*$v->{width}; 173 $c->createLine($v->{x2}, $v->{'y'}, $xtip, $v->{'y'}+$deltaY, 174 $v->{x2}-10*$v->{a}, $v->{'y'}, $xtip, $v->{'y'}-$deltaY, 175 $v->{x2}, $v->{'y'}, -width => 2, -capstyle => 'round', 176 -joinstyle => 'round'); 177 178 # Create the boxes for reshaping the line and arrowhead. 179 180 $c->createRectangle($v->{x2}-10*$v->{a}-5, $v->{'y'}-5, 181 $v->{x2}-10*$v->{a}+5, $v->{'y'}+5, @{$v->{boxStyle}}, 182 -tags => ['box1', 'box']); 183 $c->createRectangle($xtip-5, $v->{'y'}-$deltaY-5, $xtip+5, 184 $v->{'y'}-$deltaY+5, @{$v->{boxStyle}}, 185 -tags => ['box2', 'box']); 186 $c->createRectangle($v->{x1}-5, $v->{'y'}-5*$v->{width}-5, 187 $v->{x1}+5, $v->{'y'}-5*$v->{width}+5, @{$v->{boxStyle}}, 188 -tags => ['box3', 'box']); 189 190 # Create three arrows in actual size with the same parameters 191 192 $c->createLine($v->{x2}+50, 0, $v->{x2}+50, 1000, -width => 2); 193 my $tmp = $v->{x2}+100; 194 $c->createLine($tmp, $v->{'y'}-125, $tmp, $v->{'y'}-75, 195 -width => $v->{width}, -arrow => 'both', 196 -arrowshape => [$v->{a}, $v->{b}, $v->{c}]); 197 $c->createLine($tmp-25, $v->{'y'}, $tmp+25, $v->{'y'}, 198 -width => $v->{width}, -arrow => 'both', 199 -arrowshape =>[$v->{a}, $v->{b}, $v->{c}]); 200 $c->createLine($tmp-25, $v->{'y'}+75, $tmp+25, $v->{'y'}+125, 201 -width => $v->{width}, -arrow => 'both', 202 -arrowshape => [$v->{a}, $v->{b}, $v->{c}]); 203 $c->itemconfigure($cur, @{$v->{activeStyle}}) if $cur =~ /box?/; 204 205 # Create a bunch of other arrows and text items showing the current 206 # dimensions. 207 208 $tmp = $v->{x2}+10; 209 $c->createLine($tmp, $v->{'y'}-5*$v->{width}, $tmp, $v->{'y'}-$deltaY, 210 -arrow => 'both', -arrowshape => $v->{smallTips}); 211 $c->createText($v->{x2}+15, $v->{'y'}-$deltaY+5*$v->{c}, 212 -text => $v->{c}, -anchor => 'w'); 213 $tmp = $v->{x1}-10; 214 $c->createLine($tmp, $v->{'y'}-5*$v->{width}, $tmp, 215 $v->{'y'}+5*$v->{width}, -arrow => 'both', 216 -arrowshape => $v->{smallTips}); 217 $c->createText($v->{x1}-15, $v->{'y'}, -text => $v->{width}, 218 -anchor => 'e'); 219 $tmp = $v->{'y'}+5*$v->{width}+10*$v->{c}+10; 220 $c->createLine($v->{x2}-10*$v->{a}, $tmp, $v->{x2}, $tmp, 221 -arrow => 'both', -arrowshape => $v->{smallTips}); 222 $c->createText($v->{x2}-5*$v->{a}, $tmp+5, -text => $v->{a}, 223 -anchor => 'n'); 224 $tmp = $tmp+25; 225 $c->createLine($v->{x2}-10*$v->{b}, $tmp, $v->{x2}, $tmp, 226 -arrow => 'both', -arrowshape => $v->{smallTips}); 227 $c->createText($v->{x2}-5*$v->{b}, $tmp+5, -text => $v->{b}, 228 -anchor => 'n'); 229 230 $c->createText($v->{x1}, 310, -text => "-width => $v->{width}", 231 -anchor => 'w', 232 -font => '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'); 233 $c->createText($v->{x1}, 330, 234 -text => "-arrowshape => [$v->{a}, $v->{b}, $v->{c}]", 235 -anchor => 'w', 236 -font => '-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*'); 237 238 $v->{count}++; 239 240 } # end arrow_setup 241 242 1;