Tk::TreeGraph - Tk widget to draw a tree in a Canvas

 use Tk ;
 use Tk::TreeGraph ;

 use strict ;

 my $mw = MainWindow-> new ;

 my $tg = $mw -> Scrolled('TreeGraph') ->
  pack(-expand => 1, -fill => 'both');

 $tg -> addLabel (text => 'some tree');

 my $ref = [qw/some really_silly text/];

 $tg -> addNode 
  (
   nodeId => '1.0', 
   text => $ref
  ) ;

 # EITHER add the arrow and the node
 $tg -> addDirectArrow
  (
   from => '1.0', 
   to => '1.1'
  ) ;

 $tg->addNode
  (
   nodeId => '1.1',
   text => ['some','text']
  ) ;

 # OR add a node after another one, in this case the widget 
 # will draw the arrow
 $tg->addNode
  (
   after =>'1.0',
   nodeId => '1.1',
   text => ['some','text']
  );

 $tg->arrowBind
  (
   button => '<1>',
   color => 'orange',
   command =>  sub{my %h = @_;
                   warn "clicked 1 arrow $h{from} -> $h{to}\n";}
  );

 $tg->nodeBind
  (
   button => '<2>',
   color => 'red',
   command => sub {my %h = @_;
                   warn "clicked 2 node $h{nodeId}\n";}
  );

 $tg->command( on => 'arrow', label => 'dummy 2', 
                 command => sub{warn "arrow menu dummy2\n";});

 $tg->arrowBind(button => '<3>', color => 'green', 
              command => sub{$tg->popupMenu(@_);});

 $tg->command(on => 'node', label => 'dummy 1', 
                 command => sub{warn "node menu dummy1\n";});

 $tg->nodeBind(button => '<3>', color => 'green', 
              command => sub{$tg->popupMenu(@_);});

 # adjust scrolled area with some margin
 my @array = $tg->bbox("all") ;
 $tg->configure(-scrollregion => 
                [0, 0, $array[2] + 50, $array[3] + 50 ]);

 MainLoop ; # Tk's

 my @array = $tg->bbox("all") ;
 $tg->configure(-scrollregion => [0, 0, $array[2] + 50, $array[3] + 50 ]);

 (on => 'node', nodeId => $nodeId)

 (
   on   => 'arrow', 
   from => nodeId_on_arrow_start, 
   to   => nodeId_on_arrow_tip
 ) 

 (on => 'node', nodeId => $nodeId)

 (
   on   => 'arrow', 
   from => nodeId_on_arrow_start, 
   to   => nodeId_on_arrow_tip
 ) 

 my $tree_aref = [['Root', ['Terminal', ['Nonterminal', ['Terminal']]]]] ;

package Tk::TreeGraph;

use strict;
use vars qw($VERSION @ISA);

use Carp ;
use Tk::Derived ;
use Tk::Canvas ;
use Tk::Frame;
use AutoLoader qw/AUTOLOAD/ ;


@ISA = qw(Tk::Derived Tk::Canvas);

$VERSION = sprintf "%d.%03d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/;

Tk::Widget->Construct('TreeGraph');

sub InitObject {
    my ($dw,$args) = @_ ;

    # this should get a reasonable default ...
    my $defc = $dw->parent->cget('-foreground');
    $dw->ConfigSpecs (
       '-shortcutColor'    => ['PASSIVE', undef, undef, 'orange'   ],
       '-shortcutStyle'    => ['PASSIVE', undef, undef, 'straight' ],
       '-animation'        => ['PASSIVE', undef, undef, 0          ],
       '-nodeColor'        => ['PASSIVE', undef, undef, $defc      ],
       '-nodeFill'         => ['PASSIVE', undef, undef, undef      ],
       '-arrowColor'       => ['PASSIVE', undef, undef, $defc      ],
       '-nodeTextColor'    => ['PASSIVE', undef, undef, $defc      ],
       '-labelColor'       => ['PASSIVE', undef, undef, $defc      ],

       # add node Id to text
       '-nodeTag'          => ['PASSIVE', undef, undef, 1          ],
       # use this to tune the shape of nodes and arrows
       '-arrowDeltaY'      => ['PASSIVE', undef, undef,  40        ],
       '-branchSeparation' => ['PASSIVE', undef, undef, 120        ],
       '-x_start'          => ['PASSIVE', undef, undef,  40        ],
       '-y_start'          => ['PASSIVE', undef, undef, 100        ],
      );

    # bind button <1> on nodes to select a version
    $dw->bind ('node', 
               '<1>' => sub {$dw->toggleNode(color => 'blue')});

    $dw->{currentBranch} = 'b000';
    $dw->{column}{$dw->{currentBranch}} = 0;

    $dw->SUPER::InitObject($args) ;
}


1;

__END__

## data structures (i.e $dw->{...})

# arrow -> start -> hash : key is arrow widget id, 
#                          value is node Id where the arrow starts
# arrow -> tip   -> hash : key is arrow widget id, 
#                          value is node Id where the arrow ends

# node -> text      : text widget ref
# node -> rectangle : rectangle widget ref

# nodeId->hash ref: key is text or rectangle widget id, value: nodeId

# tset -> hash ref : (toggle set) key is nodeId set by the user, value is
#                    the rectangle widget id

# xset -> arrow: (eXclusive set) : arrow widget id of the arrow set by the user
# xset -> node : (eXclusive set) : nodeId of the node set by the user

# shortcutFrom -> hash : key is the nodeId of the start of the shortcut,
#                        value is the nodeId of the end of the shortcut

## General functions

sub clear
  {
    my $dw = shift ;
    
    foreach (qw/arrow node nodeId tset xset shortcutFrom x y 
             tree_start after limit column next_limit/)
      {
        delete $dw->{$_};
      }

    $dw->delete('all');

    $dw->{currentBranch} = 'b000';
    $dw->{column}{$dw->{currentBranch}} = 0;
  }

sub addLabel
  {
    my $dw = shift ;
    my %args = @_ ;
    my $text = defined $args{-text} ?  $args{-text} : $args{text} ;
    
    my $defc = $dw->cget('-labelColor') ;
    $dw->create('text', '7c' , 5 , -anchor => 'n' , -fill => $defc,
                               -text=> $text, -justify => 'center') ;
  }

sub checkOverlay
  {
    my $dw = shift ;
    my $y = shift ;

    my $c= $dw->{column}{$dw->{currentBranch}};

    #print "checking branch $dw->{currentBranch} col $c for y $y\n";

    return 0 unless defined $dw->{limit}[$c];
    #print "limit for col $c is $dw->{limit}[$c]\n";
    return 0 unless $y > $dw->{limit}[$c]; 

    my $old_c = $c ;
    # must move the branch
    while (defined $dw->{limit}[$c] and $y > $dw->{limit}[$c])
      {
        $c++ ;
      }

    #print "must move from column $old_c to $c\n";

    my $b=$dw->{currentBranch} ;
    my $dx = $dw->cget('-branchSeparation')*($c-$old_c) ;

    # shift the whole branch
    $dw->move($dw->{currentBranch},$dx,0) ; 

    # shift the tip of the arrow
    my @coord = $dw->coords("arrow".$dw->{currentBranch}) ;
    $coord[2]+= $dx ;
    $dw->coords("arrow".$dw->{currentBranch}, @coord) ; 

    # set the new limits to the bottom of the node from where the branch 
    # starts
    foreach my $idx ($old_c .. $c - 1)
      {
        #print "auto setting limit for col $idx at $coord[1]\n";
        $dw->{limit}[$idx] = $coord[1] ;
      }
    
    # update the cache the new column occupied by this branch 
    $dw->{next_limit} = [ $c,  $coord[1] ];

    # update current column
    $dw->{column}{$dw->{currentBranch}} = $c;
    
    $dw->checkOverlay($y) ;
  }

## Arrow functions

# add a an arrow for a regular revision, return the new $$yr at the bottom of
# the arrow
sub addDirectArrow
  {
    my $dw = shift ;
    my %args = @_ ;
    my $nodeId = defined $args{-from} ? $args{-from}:  $args{from};
    my $lowerNodeId = defined $args{-to} ? $args{-to} : $args{to};

    $dw->{after}{$nodeId}=1;
    my $branch_dx= $dw->cget('-branchSeparation');
    my $c = $dw->{column}{$dw->{currentBranch}} ;
    my $x = $branch_dx * $c + $dw->{tree_start} + $branch_dx/2 - 10 ;
    my $old_y = $dw->{y};

    $dw->BackTrace("addDirectArrow: unknown 'from' nodeId: $nodeId\n")
      unless defined $dw->{node}{rectangle}{$nodeId};
    
    my $y = $old_y + $dw->cget('-arrowDeltaY') ; # give length of arrow

    my $defc = $dw->cget('-arrowColor'); 
    my $itemId = $dw->create
      ('line', $x, $old_y, $x, $y , 
       -fill => $defc, 
       -tags => ["arrow",$dw->{currentBranch}],
       -arrow =>'last'); 

    $dw->{arrow}{start}{$itemId} = $nodeId ; 
    $dw->{arrow}{tip}{$itemId} = $lowerNodeId ; 

    $dw->{'y'} = $y ;
  }

 # will call-back sub with ($start_nodeId,$tip_nodeId) nodeId 
sub arrowBind 
  { 
    my $dw = shift ; 
    my %args = @_ ; 
    my $button = defined $args{-button} ? $args{-button} : $args{button}; 
    my $color  = defined $args{-color}  ? $args{-color}  : $args{color}; 
    my $callback = defined $args{-command} ? $args{-command} : $args{command} ;

    # bind button <1> on arrows to display history information
    $dw->bind
      (
       'arrow', $button => sub 
       {
         my @ids = $dw->setArrow(color => $color) ;
         $dw->idletasks;
         &$callback(on => 'arrow', @ids) ;
       });

    $dw->bind
      (
       'scutarrow', $button => sub 
       {
         my @ids = $dw->setArrow(color => $color) ;
         $dw->idletasks;
         &$callback(on => 'arrow',@ids) ;
       });
  }

# will return with ($start_revision,$tip_revison) rev numbers
# setArrow
sub setArrow
  {
    my $dw = shift ;
    my %args = @_ ;
    my $color = defined $args{-color} ? $args{-color} : $args{color};
    
    # reset any selected arrow
    if (defined $dw->{xset}{arrow})
      {
        my $tag = $dw->gettags($dw->{xset}{arrow});
        my $defc = $tag eq 'scutarrow'? 
          $dw->cget('-shortcutColor') :  $dw->cget('-arrowColor');

        $dw->itemconfigure($dw->{xset}{arrow}, -fill => $defc);
      }

    my ($itemId) = $dw->find('withtag' => 'current');
    $dw->{xset}{arrow} = $itemId ;
    $dw->itemconfigure($itemId, -fill => $color) ;
    my $tipNodeId = $dw->{arrow}{tip}{$itemId} ;
    my $endNodeId = $dw->{arrow}{start}{$itemId} ;

    return (from => $endNodeId, to => $tipNodeId) ;
  }

## Slanted Arrows

sub addSlantedArrow
  {
    my $dw = shift ;
    my %args = @_ ;
    my $nodeId = defined $args{-from} ? $args{-from} : $args{from};
    my $branch = defined  $args{-to} ? $args{-to} : $args{to} ;
    my $y = $dw->{'y'} ;

    $dw->BackTrace("AddSlantedArrow: unknown 'from' nodeId: $nodeId\n")
      unless defined $dw->{node}{rectangle}{$nodeId};

    my $nodeBranch = $dw -> {node}{branch}{$nodeId};
    my $old_c = $dw->{column}{$nodeBranch} ;
    my ($old_x, $old_y) = ($dw->coords($dw->{node}{rectangle}{$nodeId}))[0,3];

    $y = $old_y + $dw->cget('-arrowDeltaY') ; # give length of arrow

    # create the new branch on the next column
    $dw->{currentBranch}++;
    $dw->{column}{$dw->{currentBranch}} = $old_c + 1 ;

    my $branch_dx= $dw->cget('-branchSeparation');
    my $x = $branch_dx * ($old_c+1) + $dw->{tree_start}  ;

    my $defc = $dw->cget('-arrowColor');
    my $itemId = $dw->create('line', 
                             $old_x + $branch_dx/2 - 10, $old_y, 
                             $x + $branch_dx/2 - 10, $y,
                             -fill => $defc,
                             -tags => ["arrow","arrow".$dw->{currentBranch}],
                             -arrow =>'last'); 

    $dw->{arrow}{start}{$itemId} = $nodeId ;
    $dw->{arrow}{tip}{$itemId} = $branch ;

    if (defined $dw->{next_limit})
      {
        my ($c,$l) = @{$dw->{next_limit}};
        #print "setting limit for col $c at $l\n";
        $dw->{limit}[$c] =  $l ;
      }
    
    # cache the limit for that we don't limit the drawing of this branch
    #print "setting next limit for col ",$old_c+1, " at $old_y\n";
    $dw->{next_limit} = [ $old_c + 1,  $old_y ];

    $dw->{y} = $y ;
  }

## Short Cut Arrows 

sub addShortcutInfo
  {
    my $dw = shift ;
    my %args = @_ ;
    my $nodeId = defined $args{-from} ? $args{-from} : $args{from} ;
    my $mNodeId = defined  $args{-to} ? $args{-to} : $args{to} ;

    push( @{$dw->{shortcutFrom}{$nodeId}}, $mNodeId );
  }

sub addAllShortcuts
  {
    my $dw = shift ;

    my $color = $dw->cget('-shortcutColor') || $dw->cget('-foreground');

    my $dx= $dw->cget('-branchSeparation')/2 - 10;
    my $branch_dx= $dw->cget('-branchSeparation');
    my $style = $dw->cget('-shortcutStyle') ;

    foreach my $nodeId (keys %{$dw->{shortcutFrom}})
      {
        next unless defined $dw->{node}{rectangle}{$nodeId} ;
	
        foreach my $mNodeId (@{$dw->{shortcutFrom}{$nodeId}})
          {
            next unless defined $dw->{node}{rectangle}{$mNodeId} ;
            # beginning of arrow
            my ($bx, $by) = ($dw->coords($dw->{node}{rectangle}{$nodeId}))[0,3] ;
            # end of arrow
            my ($ex, $ey) =($dw->coords($dw->{node}{rectangle}{$mNodeId}))[0,1] ;
            my @opt = ($bx + $dx, $by); # arrow start

            # intermediate points for multi-segment line
            push @opt, ($bx+ $dx + $ex +$dx - $branch_dx)/2, ($by+$ey)/2 
              if $style eq 'spline' ;

            push @opt , $ex + $dx, $ey ; # arrow end

            push @opt ,qw/-smooth on/ if $style eq 'spline'; # spline mode 

            my $itemId = $dw->create
              (
               'line', @opt ,
               -arrow => 'last', 
               -tag => 'scutarrow',
               -fill=>$color
              );
            $dw->{arrow}{start}{$itemId} = $nodeId;
            $dw->{arrow}{tip}{$itemId} = $mNodeId ;
	  }
      }
  }

## Node functions

# draw a node, return the y coord of the bottom of the node 
#($x does not change)
sub addNode
  {
    my $dw = shift ;
    my %args = @_ ;

    my $nodeId = $args{-nodeId} || $args{nodeId} ;
    my $text_parm = defined $args{-text} ? $args{-text} : $args{text} ;
    my $text = ref $text_parm ? join("\n",@$text_parm) : $text_parm ;
    chomp $text;

    #print "Drawing node $nodeId\n";
    my $after = defined $args{-after} ? $args{-after} : $args{after};
    if (defined $after)
      {
        if (ref($after) eq 'ARRAY')
          {
            # re-start another tree
            ($dw->{tree_start},$dw->{y}) = @$after;
          }
        elsif (defined $dw->{after}{$after})
          {
            $dw->addSlantedArrow('from' => $after, to => $nodeId);
          }
        else
          {
            $dw->addDirectArrow('from' => $after, to => $nodeId);
          }
      }
    
    # initialization
    $dw->{tree_start}=$dw->cget('-x_start') unless defined $dw->{tree_start};
    
    # compute text to draw
    $text = "$nodeId\n". $text if $dw->cget('-nodeTag') ;

    # first compute y coord 
    my $oldy = $dw->{y} || $dw->cget('-y_start');
    my $y = $oldy + 5 ; # give some breathing space 

    # then compute the x coordinate
    my $branch_dx= $dw->cget('-branchSeparation');
    my $c = $dw->{column}{$dw->{currentBranch}} ;
    my $x = $branch_dx * $c + $dw->{tree_start}  ;

    # compute y coord
    # draw node text
    my $defc = $args{-nodeTextColor} || $args{nodeTextColor} 
      || $dw->cget('-nodeTextColor');

    my $tid = $dw->create('text', $x + $branch_dx/2 - 10, $oldy + 5, 
                          -text => $text,  -fill => $defc,
                          qw/-justify center -anchor n -width 12c/,
                          -tags => ['node', $dw->{currentBranch}]) ;

    # compute y according to the text drawn
    my @box = $dw->bbox($tid) ;
    $y = $box[3] + 5 ;

    # draw node rectangle
    $defc = $args{-nodeColor} || $args{nodeColor} || $dw->cget('-nodeColor');
    my $bgc = $args{-nodeFill} || $args{nodeFill} 
      || $dw->cget('-nodeFill');
    my $newx = $x + $branch_dx   - 20 ;
    my $rid = $dw->create('rectangle',
                          $x , $oldy,
                          $newx , $y,
                          -outline => $defc, -width => 2 , -fill => $bgc ,
                          -tags => ['node', $dw->{currentBranch}]
                        ) ;
    
    $dw->raise($tid,$rid); # the text is hidden below if forgotten

    # check if we have not drawn over something
    $dw->checkOverlay($y);

    $dw -> {nodeId}{$tid}=$nodeId ; 
    $dw -> {nodeId}{$rid}=$nodeId ; # also stored
    $dw -> {node}{text}{$nodeId}=$tid ;
    $dw -> {node}{rectangle}{$nodeId}=$rid ;
    $dw -> {node}{branch}{$nodeId}= $dw->{currentBranch} ;

    $dw->{x} = $x;
    $dw->{y} = $y ;

    my $delay = $dw->cget('-animation') ;

    if ($delay)
      {
        $dw->viewNode($nodeId) and $dw->after($delay);
      }
  }

sub viewNode
  {
    my $dw = shift ;
    my $nodeId = shift;

    my @sc = $dw->cget('-scrollregion');

    # even if the scrollregion is not defined, the array has 4 elements
    # so i must tesst one of the elements of the array
    return 0 unless (defined $sc[0]) ; # 

    my @bb = $dw->bbox("all") ;

    # adjust scroll region is something is outside of it
    foreach my $i (0,1)
      {
        $sc[$i] = $bb[$i] - 50 if ($bb[$i] < $sc[$i]);
      }
    foreach my $i (2,3)
      {
        $sc[$i] = $bb[$i] + 50 if ($bb[$i] > $sc[$i]);
      }

    $dw->configure(-scrollregion => \@sc );

    # get the rectangle coordinates
    my $rectangle_id = $dw -> {node}{rectangle}{$nodeId};
    my ($rx1,$ry1,$rx2,$ry2)= $dw->coords($rectangle_id);

    # get the full canvas coordinates
    my ($cx1,$cy1,$cx2,$cy2) = @sc;
    # compute where is the node within this widget (fraction)
    my ($xf1,$yf1,$xf2,$yf2) = 
      ($rx1/($cx2-$cx1), $ry1/($cy2-$cy1), $rx2/($cx2-$cx1), $ry2/($cy2-$cy1));

    # check if xf is out of view
    my ($xvleft,$xvright) = $dw->xview ;
    my $deltax = $xvright - $xvleft ;

    # put the widget at the center (x wise)
    $dw->xview(moveto=> (($xf1 + $xf2 - $deltax) / 2) )
      if ($xf1< $xvleft or $xf2> $xvright);

    # check if yf is out of view
    my ($yvtop,$yvbottom) = $dw->yview ;
    my $deltay = $yvbottom - $yvtop ;
    $dw->yview(moveto=>(($yf1 + $yf2 - $deltay) / 2 ) )
      if ($yf1 < $yvtop or $yf2 > $yvbottom);

    # print "delay $x $y, fx $xf fy $yf\n" ;
    $dw->idletasks;

    return 1 ;
  }

sub modifyNode
  {
    my $dw = shift ;
    my %args = @_ ;

    my $nodeId = $args{-nodeId} || $args{nodeId} || $dw->getCurrentNodeId; # optional

    croak "modifyNode: missing nodeId parameter" 
      unless defined $nodeId;

    my $rid = $dw->{node}{rectangle}{$nodeId} ; # retrieve id of rectangle
    my $tid = $dw->{node}{text}{$nodeId} ; 

    croak "modifyNode: unknown nodeId : $nodeId" unless defined $rid ;

    my $nc = $args{-nodeColor} || $args{nodeColor} ;
    if (defined $nc)
      {
        $dw->itemconfigure($rid, -outline => $nc) ;
      }

    my $text_parm = defined $args{-text} ? $args{-text} : $args{text} ;
    if (defined $text_parm)
      {
        my $text = ref $text_parm ? join("\n",$text_parm) : $text_parm;
        chomp $text ;

        $text = $nodeId."\n$text" if $dw->cget('-nodeTag') ;
        my $count = $text ;
        $count =~ s/[^\n]// ;

        my $oldText = $dw->itemcget($tid, '-text' ) ;
        $oldText =~ s/[^\n]// ;

        if (length($count) > length($oldText))
          {
            croak "modifyNode error: New text is longer than the old one. It will no fit in the node" ;
          }

        $dw->itemconfigure($tid, -text => $text) ;
      }

    my $ntc = $args{-nodeTextColor} || $args{nodeTextColor} ;
    if (defined $ntc)
      {
        $dw->itemconfigure($tid, -fill => $ntc) ;
      }

    my $nf = $args{-nodeFill} || $args{nodeFill} ;
    if (defined $nf)
      {
        $dw->itemconfigure($rid, -fill => $nf) ;
      }
  }

sub flashNode
  {
    my $dw = shift ;
    my %args = @_ ;

    my $nodeId = $args{-nodeId} || $args{nodeId} || $dw->getCurrentNodeId; # optional
    croak "modifyNode: missing nodeId parameter" 
      unless defined $nodeId;

    my $rid = $dw->{node}{rectangle}{$nodeId} ; # retrieve id of rectangle
    my $tid = $dw->{node}{text}{$nodeId} ; 

    croak "modifyNode: unknown nodeId : $nodeId" unless defined $rid ;

    if (defined $dw -> {node}{flash} and 
        defined $dw -> {node}{flash}{$nodeId} and 
        $dw -> {node}{flash}{$nodeId})
      {
        $dw -> {node}{flash}{$nodeId} = 0;
        return ;
      }
    
    $dw->viewNode($nodeId) ;

    my $time = $args{-time} || $args{time} || 500 ;
    $dw -> {node}{flash}{$nodeId} = 1 ;

    my $oldNodeColor = $dw->itemcget($rid, '-outline') ;
    my $oldNodeTextColor = $dw->itemcget($tid, '-fill') ;
    my $oldNodeFill = $dw->itemcget($rid, '-fill') ;

    my $newNodeColor = $args{-nodeColor} || $args{nodeColor} || $oldNodeColor ;
    my $newNodeTextColor = $args{-nodeTextColor} ||$args{nodeTextColor} 
      || $oldNodeTextColor ;
    my $newNodeFill = $args{-nodeFill} || $args{nodeFill} || $oldNodeFill ;

    my ($on,$off) ;

    $on = sub 
      {
        $dw->itemconfigure($rid, -outline => $newNodeColor) ;
        $dw->itemconfigure($tid, -fill =>    $newNodeTextColor) ;
        $dw->itemconfigure($rid, -fill =>    $newNodeFill) ;
        $dw->after($time,$off) ; # always call off
      };

    $off = sub 
      {
        $dw->itemconfigure($rid, -outline => $oldNodeColor) ;
        $dw->itemconfigure($tid, -fill =>    $oldNodeTextColor) ;
        $dw->itemconfigure($rid, -fill =>    $oldNodeFill) ;
        $dw->after($time,$on) if $dw -> {node}{flash}{$nodeId} ;
      };

    &$on ;
  }

# will return with node Id
# when toggling a node, only the rectangle is highlighted
sub toggleNode
  {
    my $dw = shift ;
    my %args = @_ ;
    my $color = $args{-color} || $args{color} ;
    my $nodeId = $args{-nodeId} || $args{nodeId} || $dw->getCurrentNodeId; # optional

    my $rid = $dw->{node}{rectangle}{$nodeId} ; # retrieve id of rectangle

    if (defined $dw->{tset}{node}{$nodeId})
      {
        my $defc = $dw->cget('-nodeColor');
        $dw->itemconfigure($rid, -outline => $defc) ; #unselect
        delete $dw->{tset}{node}{$nodeId} ;
      } 
    else
      {
        die "Error no color specified while selecting node\n"
          unless defined $color ;
        $dw->itemconfigure($rid, -outline => $color) ;
        $dw->{tset}{node}{$nodeId} = $rid ; # store id of rectangle
      } 

    $dw->idletasks;
    return $nodeId ;
  }

sub getNodeRectangle
  {
    my $dw = shift ;
    my %args = @_ ;
    my $nodeId = $args{-nodeId} || $args{nodeId} || $dw->getCurrentNodeId; # optional
    return $dw->{node}{rectangle}{$nodeId} ;
  }

sub getSelectedNodes
  {
    my $dw = shift ;
    return keys %{$dw->{tset}{node}} ;
  }

sub unselectAllNodes
  {
    my $dw = shift ;

    my $defc = $dw->cget('-nodeColor');
    foreach (values %{$dw->{tset}{node}})
      {
        $dw->itemconfigure($_, -outline => $defc) ; #unselect
      }
    delete $dw->{tset}{node} ;
  }

sub getCurrentNodeId
  {
    my $dw = shift ;

    my ($selected) = $dw->find('withtag' => 'current');

    unless (defined $selected)
      {
        $dw->bell ; $dw->bell ; # twice for debug ...
        return undef ;
      }

    return $dw->{nodeId}{$selected} ;
  }

# set node either from passed nodeId or from the mouse pointer
# when a node is set, only the text is highlighted
sub setNode
  {
    my $dw = shift ;
    my %args = @_ ;

    my $color = $args{-color} || $args{color} ;
    my $nodeId = $args{-nodeId} || $args{nodeId} || $dw->getCurrentNodeId ; # optional

    if (defined $dw->{xset}{node})
      {
        my $defc = $dw->cget('-nodeTextColor') || $dw->cget('-nodeColor');
        $dw->itemconfigure($dw->{xset}{node},fill => $defc);
      }

    my $itemId = $dw->{node}{text}{$nodeId} ;
    $dw->{xset}{node} = $itemId ;
    $dw->itemconfigure($itemId, fill => $color) ;

    return $dw->{nodeId}{$itemId} ;
  }


# will call-back sub with node $rev
sub nodeBind
  {
    my $dw = shift ;
    my %args = @_ ;
    my $color = $args{-color} || $args{color} ;
    my $button = $args{-button} || $args{button} ;
    my $callback = $args{-command} || $args{command} ;

    $dw->bind
      (
       'node', $button => sub 
       {
         my $id = $dw->setNode(color => $color) ;
         $dw->idletasks;
         &$callback(on => 'node', nodeId => $id) ;
       });

  }

## Popup menu commands

# will call-back sub with ($start_nodeId,$tip_nodeId) node Ids
sub command
  {
    my $dw = shift ;
    my %args = @_ ;
    my $on = $args{-on} || $args{on};
    my $label = $args{-label}  || $args{label} ;
    my $sub = $args{-command}  || $args{command} ;
    
    $dw->{command}{$on}{$label} = $sub ;
  }

sub popupMenu
  {
    my $dw = shift ;
    my %args = @_ ;
    my $on = delete $args{-on} || delete $args{on} ;

    my $menu = $dw-> Menu; 
    foreach (keys %{$dw->{command}{$on}})
      {
        my $s = $dw->{command}{$on}{$_};
        $menu -> add 
          (
           'command',
           '-label' => $_, 
           '-command' => sub {&$s(%args) ;}
          );
    }

    $menu->Popup(-popover => 'cursor', -popanchor => 'nw');
  }

sub draw_tree_from_ref {
    my $self            = shift;
    my $tree_aref       = shift;

    my $root_node_id    = '1.0';

    $self->clear() ;

    # Debug:
    #print Dumper $root_node_id;
    #print Dumper $tree_aref;

    # -- ckeck input
    if( ref $tree_aref ne 'ARRAY' ){
	croak("draw_tree_from_ref: the tree must be an array ref");
    }
    else {
	# -- draw root-node and recurse with rest
	$self->addNode(
		       nodeId  => $root_node_id,
		       text    => $tree_aref->[0]->[0],
		      );

	$self->_draw_tree_from_ref_recursive($tree_aref->[0]->[1],
					     $root_node_id);
    }

} # /draw_tree_from_ref

sub _draw_tree_from_ref_recursive {
    my $self            = shift;
    my $tree_aref       = shift;
    my $root_node_id    = shift;

    ## Debug:
    #print Dumper $root_node_id;
    #print Dumper $tree_aref;

    # -- iterate throuh the children of the actual root-node
    foreach my $pos ( 0 ..  (@$tree_aref-1) ) {
	my $e = $tree_aref->[$pos];

	if( ref $e eq 'ARRAY' ) {

	    # -- calculate new id
	    my $new_id = $self->_calcNewTreeId($root_node_id, $pos);

	    # -- draw node containing nonterminal
	    $self->addNode(
			   after   => $root_node_id,
			   nodeId  => $new_id,
			   text    => $e->[0],
			  );

	    # -- recurse with rest
	    $self->_draw_tree_from_ref_recursive($e->[1], $new_id);

	}
	else {

	    # -- build new id
	    my $new_id = $self->_calcNewTreeId($root_node_id, $pos);

	    # -- draw node containing terminal
	    $self->addNode(
			   after   => $root_node_id,
			   nodeId  => $new_id,
			   text    => $e,
			  );

	}
    }

} # /_draw_tree_from_ref_recursive

sub _calcNewTreeId {
    my $self                = shift;
    my $mother_id           = shift;
    my $pos_in_tree_level   = shift; # tree-item-count starts at 0.
    my $new_id              = undef;

    if( $mother_id =~ m/(.+)\.0$/ ) {
	$new_id = $1 . '.' . ($pos_in_tree_level+1);
    }
    else {
	$new_id = $mother_id . '.' . ($pos_in_tree_level+1);
    }

    return $new_id;
} # /