Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

Tk:Canvas - Arc with an arrow?

by cmv (Chaplain)
on Oct 08, 2009 at 16:23 UTC ( #800025=perlquestion: print w/ replies, xml ) Need Help??
cmv has asked for the wisdom of the Perl Monks concerning the following question:

Monks-

How can I create an arc (-style=>'chord') with an arrow on the end, in a Perl-Tk canvas?

This sounded like a simple thing for me to answer. It's turning into a quagmire. Here's where I've been so far:

  • Arrow option on $can->createArc()? Nope - arrow option on line items only.
  • Make an arc out of a bunch of lines (needed to ask in CB for math formula).
  • Duh, CB suggestion to put a small line on end of arc, with arrow! Good thinking..., but wait - I can't figure out how to do this, since there's no way I know of to get the coords of the end of the arc to attach a line to (you only get coords of a rectangle that encloses the arc). Back to bunch-o-lines strategy.
  • Built bunch-o-lines prototype (see attached), but arrowhead doesn't follow curve, and there's no way to rotate the arrowhead.
  • Thinking I could create a really short line right at the end, that orients the arrow in the correct direction. Started thinking there has to be a better way. Decided to ask for Monk's help.

    Any thoughts are much appreciated.

    Thanks

    -Craig

    use strict; use warnings; use Tk; my $top = MainWindow->new; my $can = $top->Canvas()->pack(); my @offset = (100, 100); my $PI = atan2(1,1) * 4; my $max = 100; my $radius = 20; my @coords; foreach my $i (1..$max-30) { push(@coords, _circleCoord($i*2*$PI/$max, $radius)); } $can->createLine(@coords, -arrow=>'last', #-arrowshape=>[10, 15, 9], # Goofy arrowhead - this helps tags=>['SELFARROW']); $can->move('SELFARROW', @offset); MainLoop; sub _circleCoord { my $radians = shift || die "Missing radians"; my $radius = shift || die "Missing radius"; my @coords; push(@coords, ($radius * sin($radians))); push(@coords, ($radius * cos($radians))); return(@coords); }
  • Comment on Tk:Canvas - Arc with an arrow?
    Select or Download Code
    Re: Tk:Canvas - Arc with an arrow?
    by AnomalousMonk (Monsignor) on Oct 08, 2009 at 22:21 UTC
      I don't know a general solution to the problem, but a little playing around with the 'goofy arrowhead' approach produces a version that, for me, is more reasonable and might become quite handsome with a bit more futzing around:
      -arrowshape => [2, 5, 4], # less goofy
    Re: Tk:Canvas - Arc with an arrow?
    by ELISHEVA (Prior) on Oct 09, 2009 at 03:08 UTC

      You can get the coordinates for the end point of the arc with the following subroutine:

      use strict; use warnings; use Math::Trig; sub getArcEnd { my ($x, $y, $x2, $y2, $start, $extent) = @_; # -------------------------------------- # Note: this was added in response to liverpole's note below # Optional patch to allow denormalized bounding boxes if ($x2 < $x) { my $tmp = $x; $x=$x2; $x2=$tmp; } if ($y2 < $y) { my $tmp = $y; $y=$y2; $y2=$tmp; } # -------------------------------------- # $x, $y, $x2, $y2 can be the bounding box of an # ellipse (not just a circle) so calculate vertical # and horizontal radius separately my $radiusX = ($x2 - $x)/2; my $centerX = $x + $radiusX; my $radiusY = ($y2 - $y)/2; my $centerY = $y + $radiusY; # Tk expects the starting angle and length of the # arc (extent) to be in degrees but cos and sin expect # them in radian my $radians = deg2rad($start + $extent); # [ x coord of arc end point, y coord of arc end point ] # the coordinate system for Tk::Canvas makes "down" # positive so we need to subtract the Y component # rather than add it. return [ $centerX + $radiusX*cos($radians) , $centerY - $radiusY*sin($radians) ]; }

      The only way to get the arrow head to orient correctly on a line attached to the end of the circle would be to angle the line. That would require a very short line tangent to the circle. I'm not exactly sure how Tk draws its circles, but usually a circle is drawn just as you tried to do it with a series of very short lines. However, there is some smoothing going on so that the line looks less choppy to the human eye. In some cases the points of that short line may not coincide exactly with the points of the circle and you will see a slight thickening at the point where you want to join your arrow. Depending on the size of your arrow and the radius of your arc, it may or may not be noticable.

      Another option is to draw your own arrow. To get the arrow aligned right, the arrow's coordinates need to be rotated clockwise 45 degrees (-45). To get you started, here is a quick routine that draws a very simple arrow head.

      sub drawArrow { my ($xEnd, $yEnd, $start, $extent, $arrowLength) = @_; my $radians = deg2rad($start + $degrees-45); my $xArrow = $arrowLength * cos($radians); my $yArrow = $arrowLength * sin($radians); $can->createLine($xEnd, $yEnd, $xEnd+$xArrow, $yEnd-$yArrow); $can->createLine($xEnd, $yEnd, $xEnd+$yArrow, $yEnd+$xArrow); }

      Best, beth

      Update: Added explanation of how to draw a properly oriented arrow head.

      Update 2: Added optional patch to allow non-normalized bounding boxes - see below, liverpole's note and responses for further discussion.

    Reaped: [DUP] Re: Tk:Canvas - Arc with an arrow?
    by NodeReaper (Curate) on Oct 09, 2009 at 03:12 UTC
    Re: Tk:Canvas - Arc with an arrow?
    by liverpole (Monsignor) on Oct 09, 2009 at 03:54 UTC
      Hi cmv, and ELISHEVA,

      It's an interesting question to try to solve, so I started looking at some test code for it.  While I was doing so, I noticed that ELISHEVA came up with the algorithm getArcEnd; unfortunately, after plugging it into my program, it doesn't seem to work, at least not consistently:

      #!/usr/bin/perl -w ############### ## Libraries ## ############### use strict; use warnings; use Math::Trig; use Tk; ################## ## User-defined ## ################## my $cw = 768; my $ch = 512; my $x1 = 40; my $y1 = 40; my $x2 = 250; my $y2 = 250; my $deg = 60; my $ext = 45; ################## ## Main Program ## ################## my @ids = ( ); my $top = MainWindow->new; my $frm = $top->Frame()->pack(-fill => 'x'); my $can = canvas($top, $cw, $ch); labent($frm, 'X1', \$x1, 8); labent($frm, 'Y1', \$y1, 8); labent($frm, 'X2', \$x2, 8); labent($frm, 'Y2', \$y2, 8); labent($frm, 'Start', \$deg, 8); labent($frm, 'Extent', \$ext, 8); button($frm, 'Exit (Esc)', 'r', sub { exit }, 'Esca +pe'); button($frm, 'Clear Canvas (^L)', 'r', sub { clear_canvas() }, 'Cont +rol-l'); button($frm, 'Random Draw (Space)', 'r', sub { random_draw() }, 'spac +e'); button($frm, 'Draw Arc', 'r', sub { arrowed_arc() }); button($frm, 'Random Args', 'r', sub { random_args() }); MainLoop; ################# ## Subroutines ## ################# sub canvas { my ($w, $width, $height) = @_; my $bg = 'peachpuff'; my $can = $w->Canvas(-width => $width, -height => $height, -bg => +$bg); $can->pack(-expand => 1, -fill => 'both'); return $can; } sub labent { my ($w, $text, $s_var, $width) = @_; my @fargs = (-relief => 'groove', -borderwidth => 4); my @pargs = (-side => 'left', -expand => 1, -fill => 'y'); my $f = $w->Frame(@fargs)->pack(@pargs); my $lbl = $f->Label(-text => $text); my $ent = $f->Entry(-textvar => $s_var, -width => $width); $lbl->pack($ent, -side => 'left'); return [ $lbl, $ent ]; } sub button { my ($f, $text, $side, $c_sub, $binding) = @_; my $btn = $f->Button(-text => $text, -bg => 'lightgreen'); $btn->configure(-command => $c_sub); my $h_sides = {qw( l left r right t top b bottom )}; exists($h_sides->{$side}) and $side = $h_sides->{$side}; $btn->pack(-side => $side); ($binding || 0) and $top->bind("<$binding>" => sub { $btn->invoke +}); return $btn; } sub arrowed_arc { my @opts = ( -style => 'arc', -start => $deg, -extent => $ext ); my $id1 = $can->createArc($x1, $y1, $x2, $y2, @opts); my $a_end = getArcEnd($x1, $y1, $x2, $y2, $deg, $ext); my ($x, $y) = @$a_end; my $id2 = $can->createOval($x - 5, $y - 5, $x + 5, $y + 5, -fill = +> 'red'); push @ids, $id1, $id2; } sub random_args { $x1 = random_value(0, $cw); $x2 = random_value(0, $cw); $y1 = random_value(0, $ch); $y2 = random_value(0, $ch); $deg = random_value(0, 360); } sub clear_canvas { foreach my $id (@ids) { $can->delete($id); } @ids = ( ); $top->update; } sub random_draw { random_args(); arrowed_arc(); } sub random_value { my ($min, $max) = @_; my $rnd = int(rand($max - $min + 1)) + $min; return $rnd; } sub getArcEnd { my ($x, $y, $x2, $y2, $start, $extent) = @_; # $x, $y, $x2, $y2 can be the bounding box of an # ellipse (not just a circle) so calculate vertical # and horizontal radius separately my $radiusX = ($x2 - $x)/2; my $centerX = $x + $radiusX; my $radiusY = ($y2 - $y)/2; my $centerY = $y + $radiusY; # Tk expects the starting angle and length of the # arc (extent) to be in degrees but cos and sin expect # them in radian my $radians = deg2rad($start + $extent); # [ x coord of arc end point, y coord of arc end point ] # the coordinate system for Tk::Canvas makes "down" # positive so we need to subtract the Y component # rather than add it. return [ $centerX + $radiusX*cos($radians) , $centerY - $radiusY*sin($radians) ]; }

      My subroutine arrowed_arc is obviously not yet complete; it draws the arc, and then (for the moment) draws only a small, red circle at the coordinates returned by getArcEnd.  Sometimes that circle appears to be correctly placed, and sometimes not.

      I'm almost out of time this evening, having also been busy watching the Red Sox currently losing the baseball game against the Angels (as well as getting not one but two ridiculous calls by the first-base umpire, who appears to be blind!).  I'll try to look at the problem later, but perhaps someone else will come up with a solution in the meantime (and feel free to use my test code if that helps!)


      s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

        Wow! That's a great script and fun to play with!

        My algorithm assumes a normalized bounding box, that is, x1 < x2, y1 < y2. I'm not yet 100% sure that this is the full explanation, but I noticed that some of your randomly generated inputs violate that assumption and those inputs are the ones that seem to trigger the odd results. Once the non-normalized bounding boxes are disallowed, the odd behavior disappears.

        The following two patches to your code will allow you to demonstrate to yourself the difference between prohibiting and allowing non-normalized bounding boxes.

        # ... intro stuff... labent($frm, 'X1', \$x1, 8); labent($frm, 'Y1', \$y1, 8); labent($frm, 'X2', \$x2, 8); labent($frm, 'Y2', \$y2, 8); labent($frm, 'Start', \$deg, 8); labent($frm, 'Extent', \$ext, 8); #------------------------------------ #PATCH 1 my $normal = 0; labent($frm, 'Normal', \$normal, 8); #------------------------------------ # ... more stuff ... sub random_args { $x1 = random_value(0, $cw); $x2 = random_value(0, $cw); $y1 = random_value(0, $ch); $y2 = random_value(0, $ch); $deg = random_value(0, 360); #------------------------------------ #PATCH 2 if ($normal) { $x2 = 2*$x1 - $x2 if $x2 < $x1; $y2 = 2*$y1 - $y2 if $y2 < $y1; } #------------------------------------ }

        Since Tk allows both normalized and denormalized bounding boxes it probably makes sense to write the arc end point algorithm to handle both cases as well. The following patch to my earlier algorithm will allow it to handle both normalized and denormalized boxes. It will draw correctly whether or not $normal is true or false.

        sub getArcEnd { my ($x, $y, $x2, $y2, $start, $extent) = @_; # -------------------------------------- # PATCH # handle denormalized bounding boxes if ($x2 < $x) { my $tmp = $x; $x=$x2; $x2=$tmp; } if ($y2 < $y) { my $tmp = $y; $y=$y2; $y2=$tmp; } # -------------------------------------- # $x, $y, $x2, $y2 can be the bounding box of an # ellipse (not just a circle) so calculate vertical # and horizontal radius separately my $radiusX = ($x2 - $x)/2; my $centerX = $x + $radiusX; my $radiusY = ($y2 - $y)/2; my $centerY = $y + $radiusY; # Tk expects the starting angle and length of the # arc (extent) to be in degrees but cos and sin expect # them in radian my $radians = deg2rad($start + $extent); # [ x coord of arc end point, y coord of arc end point ] # the coordinate system for Tk::Canvas makes "down" # positive so we need to subtract the Y component # rather than add it. return [ $centerX + $radiusX*cos($radians) , $centerY - $radiusY*sin($radians) ]; }

        Best, beth

        Update: Struck out uncertainty. Updated with patch to demo to show difference in behavior due to normalized and unnormalized bounding boxes.

        Update 2: Added version of getArcEnd() that handles both normalized and denormalized bounding boxes.

          ++ELISHEVA ... good job!

          My program is now consistently displaying little red curved push pins. :-)

          Your math skills are quite impressive.

          So the next step will be to calculate the correct terminal angle, in order to draw the arrowhead.

          By the way, where you've written:

          if ($x2 < $x) { my $tmp = $x; $x=$x2; $x2=$tmp; }

          the following is a bit more succinct (and avoids the temporary variable):

          ($x2 < $x) and ($x, $x2) = ($x2, $x); # Swap $x and $x2

          s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
    Re: Tk:Canvas - Arc with an arrow?
    by cmv (Chaplain) on Oct 09, 2009 at 15:11 UTC
      ELISHEVA++ liverpole++

      Many, many thanks for your work on this problem. It was a delight for me to read through your responses first thing this morning!

      ELISHEVA, your find-the-end-of-the-arc solution works great, in combination with liverpole's fantastic try-things-out-and-play-with-it-script, and the synergy between the two of you has helped educated me in this area quite a bit. Thanks for going all PerlMonks on this one. It's exactly what I needed.

      In the mean time, I continued on with the bunch-o-lines solution, after posting this and came up with the final version attached here.

      My guts are telling me that the right solution is to get Tk to add an arrow option on to the end of the canvas arc item (and possibly others). I've run this gauntlet a long time ago to add a Get/Delete Enhancement for Tk Text Widget, so maybe this would be a good long-term solution (opinions?).

      In any case, thanks again for all the valuable help!

      -Craig

      use strict; use warnings; use Tk; my $top = MainWindow->new; my $can = $top->Canvas()->pack(); my @offset = (100, 100); my $PI = atan2(1,1) * 4; my $max = 100; my $radius = 20; my $start=35; my $end=$max-22; # Generate list of line segments... my @coords; foreach my $i (1..$end) { my $radians = ($i+$start)*2*$PI/$max, $radius; my @nextXY = ( $radius * sin($radians), # X-val $radius * cos($radians), # Y-val ); push(@coords, @nextXY); } # Fix things for the arrowhead... $coords[-1] -= 2; # y $coords[-2] += 2; # x # Draw the line (arrowed arc)... my $l = $can->create('line', \@coords, -arrow=>'last'); $can->move($l, @offset); MainLoop;

    Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Node Status?
    node history
    Node Type: perlquestion [id://800025]
    Approved by Joost
    help
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others exploiting the Monastery: (4)
    As of 2014-08-21 06:39 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The best computer themed movie is:











      Results (128 votes), past polls