home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _3a3325464038eb43956541c8ff647cab < prev    next >
Encoding:
Text File  |  2004-04-13  |  8.9 KB  |  221 lines
  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;
  221.