Beefy Boxes and Bandwidth Generously Provided by pair Networks Bob
P is for Practical
 
PerlMonks  

How to draw a curved arrow in perl Tk canvas ?

by KuntalBhusan (Acolyte)
on Jul 30, 2012 at 13:25 UTC ( #984445=perlquestion: print w/ replies, xml ) Need Help??
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....

Comment on How to draw a curved arrow in perl Tk canvas ?
Download Code
Re: How to draw a curved arrow in perl Tk canvas ?
by choroba (Abbot) 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 (Pope) 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

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (10)
As of 2014-04-16 12:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (425 votes), past polls