in reply to Re^2: How to draw a curved arrow in perl Tk canvas ?
in thread How to draw a curved arrow in perl Tk canvas ?
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__
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re^4: How to draw a curved arrow in perl Tk canvas ?
by KuntalBhusan (Acolyte) on Aug 01, 2012 at 10:46 UTC | |
by BrowserUk (Patriarch) on Aug 01, 2012 at 12:23 UTC | |
by KuntalBhusan (Acolyte) on Aug 01, 2012 at 14:23 UTC |