http://www.perlmonks.org?node_id=984445

KuntalBhusan has asked for the wisdom of the Perl Monks concerning the following question:

Dear Monks, I want to draw two curved arrows joining two nodes of a graph in the Tk Canvas. The method provided are :
use Tk; my $mw = new MainWindow(-title => 'Test'); my $canvas = $mw->Canvas(-width => 512, -height => 512)->pack; $id1 = $canvas->createLine(60,60, 400,400,-arrow => "first",-arrowshap +e => [ 20, 20, 20]); $id2 = $canvas->createLine(60,60, 400,400,-arrow => "last",-arrowshape + => [ 20, 20, 20]); MainLoop;
As you can see the two lines $id1 and $id2 gets superimposed one over the other. I want two make them as curved lines. I tried with the createArc method but it has two problems : 1) It does not allow to attach an arrowhead 2) It creates circles only...I just want the two lines to see a bit separated on the either sides as small curved lines. Seeking for the monks help....

Replies are listed 'Best First'.
Re: How to draw a curved arrow in perl Tk canvas ?
by choroba (Cardinal) on Jul 30, 2012 at 13:43 UTC
    Use -smooth to draw curved arrows. You just have to provide more points. If the middle points are slightly different, the lines will bend in a non overlapping way:
    my $id1 = $canvas->createLine(60, 60, 220, 240, 400, 400, -smooth => 1, -arrow => "first", -arrowshape => [ 20, 20, 20]); my $id2 = $canvas->createLine(60, 60, 220, 260, 400, 400, -smooth => 1, -arrow => "last", -arrowshape => [ 20, 20, 20]);
Re: How to draw a curved arrow in perl Tk canvas ?
by BrowserUk (Patriarch) on Jul 30, 2012 at 13:43 UTC

    Construct it yourself:

    #! perl -slw use strict; use Tk; my $mw = new MainWindow(-title => 'Test'); my $canvas = $mw->Canvas(-width => 512, -height => 512)->pack; $canvas->createArc( 0, 500, 200, 300, -start => 0, -extent => 90, -sty +le => 'arc' ); $canvas->createPolygon( 190, 400, 210, 400, 200, 410 ); $canvas->createPolygon( 100, 290, 100, 310, 90, 300 ); MainLoop;

    With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.

    The start of some sanity?

      Thankss a lot for the help....A small additional query....is it somehow possible to implement the same in the module Tk::GraphItems::Connector where if two nodes have more than one connecting lines, they will appear as curved lines... The link for the code is : http://cpansearch.perl.org/src/LAMPRECHT/Tk-GraphItems-0.12/lib/Tk/GraphItems/Connector.pm
        is it somehow possible to implement the same in the module Tk::GraphItems::Connector where if two nodes have more than one connecting lines, they will appear as curved lines...

        I have no knowledge of that module. If you want to modify it, you'll need to look into it yourself or contact the author.

        But, given a canvas and two points, this subroutine will connect them with a 60° arc with arrows:

        Updated code: fixed wraparound error

        sub curvedArrow { my( $cnv, $x1, $y1, $x2, $y2, $color ) = @_; ## set the radius to the distance between p1 & p2 my $rad = sqrt( abs( $x1 - $x2 )**2 + abs( $y1 - $y2 )**2 ); my $q = sqrt( ( $x2 - $x1 )**2 + ( $y2 - $y1 )**2 ); my( $x3, $y3 ) = ( ( $x1 + $x2 ) / 2, ( $y1 + $y2 ) / 2 ); my $xc = $x3 + sqrt( $rad**2 - ( $q / 2 )**2 ) * ( $y1 - $y2 ) / $ +q; my $yc = $y3 + sqrt( $rad**2 - ( $q / 2 )**2 ) * ( $x2 - $x1 ) / $ +q; my $a1 = atan2( ( $yc - $y1 ), -( $xc - $x1 ) ) * RAD; my $a2 = atan2( ( $yc - $y2 ), -( $xc - $x2 ) ) * RAD; $cnv->createArc( $xc - $rad, $yc - $rad, $xc + $rad, $yc + $rad, -style => 'arc', -start => $a1, -extent => -60, -outline=> $color ); my $r2 = $rad / 15; $cnv->createArc( $x1-$r2, $y1-$r2, $x1+$r2, $y1+$r2, -start=>$a1-77, -extent=> -30, -fill=> $color ); $cnv->createArc( $x2-$r2, $y2-$r2, $x2+$r2, $y2+$r2, -start=> ( $a2+107 ) %360, -extent=> -30, -fill=> $color ); return $xc, $yc; }

        The arc will be drawn clockwise from the first supplied point, to the second, in black.

        If you want the arc to run the other way, reverse the order of the points.

        If you want to adjust the color, add it as a parameter.

        If you want to increase or decrease the curvature of the arc; adjust the radius calculation accordingly.

        A short test script that generates two random points and connects them with arcs running both ways:

        #! perl -slw use strict; use Tk; use constant PI => 3.1415926535897932384626433832795; use constant RAD => 180 / PI; sub curvedArrow { my( $cnv, $x1, $y1, $x2, $y2, $color ) = @_; ## set the radius to the distance between p1 & p2 my $rad = sqrt( abs( $x1 - $x2 )**2 + abs( $y1 - $y2 )**2 ); my $q = sqrt( ( $x2 - $x1 )**2 + ( $y2 - $y1 )**2 ); my( $x3, $y3 ) = ( ( $x1 + $x2 ) / 2, ( $y1 + $y2 ) / 2 ); my $xc = $x3 + sqrt( $rad**2 - ( $q / 2 )**2 ) * ( $y1 - $y2 ) / $ +q; my $yc = $y3 + sqrt( $rad**2 - ( $q / 2 )**2 ) * ( $x2 - $x1 ) / $ +q; my $a1 = atan2( ( $yc - $y1 ), -( $xc - $x1 ) ) * RAD; my $a2 = atan2( ( $yc - $y2 ), -( $xc - $x2 ) ) * RAD; $cnv->createArc( $xc - $rad, $yc - $rad, $xc + $rad, $yc + $rad, -style => 'arc', -start => $a1, -extent => -60, -outline=> $color ); my $r2 = $rad / 15; $cnv->createArc( $x1-$r2, $y1-$r2, $x1+$r2, $y1+$r2, -start=>$a1-77, -extent=> -30, -fill=> $color ); $cnv->createArc( $x2-$r2, $y2-$r2, $x2+$r2, $y2+$r2, -start=> ( $a2+107 ) %360, -extent=> -30, -fill=> $color ); return $xc, $yc; } our $W //= 1000; our $H //= 800; my $mw = new MainWindow(-title => 'Test'); my $canvas = $mw->Canvas(-width => $W, -height => $H )->pack; my( $x1, $y1 ) = ( $W/4 + int( rand( $W/2 ) ), $H/4 + int( rand( $H / +2 ) ) ); $canvas->createLine( $x1-5, $y1, $x1+5, $y1, -fill => 'blue' ); $canvas->createLine( $x1, $y1-5, $x1, $y1+5, -fill => 'blue' ); my( $x2, $y2 ) = ( int( rand $W ), int( rand $H ) ); $canvas->createLine( $x2-5, $y2, $x2+5, $y2, -fill => 'green' ); $canvas->createLine( $x2, $y2-5, $x2, $y2+5, -fill => 'green' ); my( $xc, $yc ) = curvedArrow( $canvas, $x1, $y1, $x2, $y2 ); $canvas->createLine( $xc-5, $yc, $xc+5, $yc, -fill => 'red' ); $canvas->createLine( $xc, $yc-5, $xc, $yc+5, -fill => 'red' ); ( $xc, $yc ) = curvedArrow( $canvas, $x2, $y2, $x1, $y1 ); $canvas->createLine( $xc-5, $yc, $xc+5, $yc, -fill => 'red' ); $canvas->createLine( $xc, $yc-5, $xc, $yc+5, -fill => 'red' ); MainLoop; __END__

        With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
        Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
        "Science is about questioning the status quo. Questioning authority".
        In the absence of evidence, opinion is indistinguishable from prejudice.

        The start of some sanity?

Re: How to draw a curved arrow in perl Tk canvas ?
by zentara (Archbishop) on Jul 30, 2012 at 19:39 UTC
    No one mentioned the use of splinesteps, but here is how to smooth your curves.
    #!/usr/bin/perl use warnings; use strict; use Tk; my $mw = tkinit; $mw->geometry("600x400+100+100"); my $canvas = $mw->Canvas(-width => 600, -height => 400, -bg => 'black')->pack(); my $line5 = $canvas->createLine(400,0,500,150, -fill => 'pink', -width => 5, ); my $line6 = $canvas->createLine(0,200,100,350,0,300,350,200, -width => 5, -smooth => 1, -fill => 'lightgreen'); my $line7 = $canvas->createLine(300,200,500,350,0,300,350,200, -width => 5, -smooth => 1, -splinesteps => 20, -fill => 'purple'); MainLoop;

    I'm not really a human, but I play one on earth.
    Old Perl Programmer Haiku ................... flash japh