Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

ztk-mapper

by zentara (Archbishop)
on Sep 30, 2005 at 21:45 UTC ( [id://496524]=sourcecode: print w/replies, xml ) Need Help??
Category: GUI Programming
Author/Contact Info zentara@zentara.net
Description: Pops up a Canvas on which you can draw maps or diagrams by dragging the mouse. Right clicks allow entering text. Will export the map to postscript. The window can be resized to size canvas. Undo mistakes with a middle-mouse click.
#!/usr/bin/perl
use warnings;
use strict;
use Tk;
require Tk::DialogBox;

#by zentara on Sept 30, 2005 

# Usage: 
# Press and drag Mouse Button 1 to draw lines 
# Right click to add text at click point 
# Middle Click(or both mouse buttons ) to delete item under mouse 
# Save will write the canvas to postscript 

my @s;            #line drawing buffer  
my $count_l = 0;  #count for lines tags 
my $count_t = 0;  #count for text tags 

my $mw = tkinit;

$mw->fontCreate('big', -family=>'arial',
   -weight=>'bold', -size=> 18 );

my $topframe = $mw->Frame(-bg=>'black')->pack(-fill =>'x');

$topframe->Button(-text=>'Exit',-command=>sub{ exit })
                     ->pack(-side => 'right', -padx => 5);

my $canvas = $mw->Canvas( -width => 640,
                      -height => 480,
                      -bg => 'white',
                 )->pack(-fill=>'both', -expand => 1);

$canvas->Tk::bind('<1>', [ \&Start, Ev('x'), Ev('y') ] );
$canvas->Tk::bind("<B1-Motion>", [ \&Move, Ev('x'), Ev('y') ]);
$canvas->Tk::bind('<ButtonRelease>', sub { @s =() });

#text insert with right button click 
$canvas->Tk::bind('<3>', [ \&Text_insert, Ev('x'), Ev('y') ] );

#undo with a middle mouse click 
$canvas->Tk::bind('<2>', sub{
           $canvas->delete( ($canvas->gettags("current"))[0] );
          });

$topframe->Button(
     -text    => "Save",
    -command => [sub {
           $canvas->update;
           my @capture=();
           my ($x0,$y0,$x1,$y1)=$canvas->bbox('all');
           @capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-
+$x0);
           $canvas -> postscript(-colormode=>'color',
                               -file=>$0.'.ps',
                               -rotate=>0,
                               -width=>800,
                               -height=>500,
                               @capture);
                              }
         ])->pack(-side=>'left', -padx =>5);

$topframe->Button(
     -text    => "Restart",
    -command => sub{
          $canvas->delete('line','text');
       })->pack(-side=>'left', -padx =>5);

MainLoop;
############################################################# 
sub Start {
     my ($canv, $x, $y) = @_;
     $count_l++;
     @s =();
     my @coords = ($canv->canvasx($x) , $canv->canvasx($y) );
     push @s, @coords;
}
############################################################# 
sub Move {
   my ($canv, $x, $y) = @_;
   my @coords = ($canv->canvasx($x) , $canv->canvasx($y) );
   push @s, @coords;

   $canvas->createLine( @s,
               -width => 5,
               -smooth => 1,
               -tags => [ 'l'.$count_l , 'line'],
               -fill => 'black');

  #shift off previous points to avoid overlapping 
  shift @s; shift @s;
}
############################################################## 
sub Text_insert {
     my ($canv, $x, $y) = @_;
     $count_t++;
     my @coords = ($canv->canvasx($x) , $canv->canvasx($y) );

     my $dialog = $mw->DialogBox(
       -buttons => ['Ok'],
       -title => 'Text Insert',
                   -bg    => 'lightsteelblue',
                  );

     my $dentry = $dialog->add('Entry',
                -bg=>'yellow',
                -font => 'big',
                )->pack();

     $dialog->configure(-focus => $dentry);
     my $button = $dialog->Show();

     if ( $button eq "Ok" ) {
        my $text = $dialog->Subwidget('entry')->get();

        $canvas->createText( @coords,
               -text => $text,
               -anchor => 'w',
               -justify => 'left',
               -font => 'big',
               -tags => [ 't'.$count_t, 'text' ],
               -fill => 'red');
     }
}
################################################################ 

__END__

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://496524]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others chilling in the Monastery: (8)
As of 2024-03-28 19:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found