Re: Tk:Canvas - Arc with an arrow?

[liverpole]

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!)

[ELISHEVA]

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.

[liverpole]

++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