Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

comment on
( [id://3333]=superdoc: print w/replies, xml ) Need Help?? 
#!/usr/bin/perl 
use warnings;
use strict;
use Tk;
use Tk::Pane;
use Tk::PNG;
use Tk::JPEG;
use File::Spec;
use File::Basename;
use MIME::Base64;
use Image::Magick;
use Tk::CanvasDirTree; # a single click directory browser

# start script in top dir containing  png, jpg. (no animated
# gif testing so may cause errors with animated gifs)
# --will recurse into subdirs
# --left click on thumbnail to load image in source canvas
# --left-click drag on source image will copy a subsample to
#    the target(rightmost) canvas. The drag will create
#    a rectangle, which will turn momentarily red upon left-button
#    release. When the red disappears, 
#    the subsample is on the target canvas.
#    The samples will be staggered, 
#     and are draggable on the target canvas,
#    with a left mouse button drag. 
# --Escape will clear target canvas
# --Save button will save entire target canvas as jpg.

# set source and target canvas sizes (scrollregions)
my $source_size_x = 1000; 
my $source_size_y = 1000; 
my $target_size_x = 1000; 
my $target_size_y = 1000; 

my $im = Image::Magick->new; # a single object for thumbnails
my $output = Image::Magick->new(magick=>'ps'); #object for copy

my $photo;  #my source $photo ;
my $can1;  #scrolled
my $can2;
my $rcan1; #real
my $rcan2;
my $dx;
my $dy;
my $x2 = 20; # starting point for placing samples on target canvas
my $y2 = 20; 

my %thumbs; #global for reusing Photo objects which hold thumbs
my %info;   #reusable hash to hold photo file info 
my $info = 'File Information';

my $mw = MainWindow->new(-bg=>'black');
$mw->geometry('800x600');

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

$mw->bind('<Control-c>', sub{ Tk::exit;} );

my $topframe = $mw->Frame(-height =>1, -background=>'black')
                            ->pack(-fill=>'x', -expand=>1);

my $topframe1 = $topframe->Frame(-height =>1, -background=>'black')
                            ->pack(-side => 'right',-fill=>'x', -expan
+d=>0);

$topframe1->Button( -background => 'yellow',
                   -foreground =>'black',
           -activebackground => 'lightseagreen',
           -font =>'big',                  
                   -relief=>'raised',
           -command => \&save,
           -text => 'Save',
          )->pack(-side=>'right',-fill =>'x',-expand =>0);


$topframe->Label( -textvariable => \$info,
                  -background => 'black',
                  -foreground =>'yellow',
         # -font =>'big',                  
                  -relief=>'raised',
          )->pack(-side=>'left',-fill =>'x',-expand =>1);


my $leftframe = $mw->Frame( -width =>50, 
                            -background=>'black',
                )->pack(-side => "left", -anchor => "n",
                         -fill=> 'y',
                      -expand=>0,
                     );

my $midframe = $mw->Frame( -width =>150, 
                            -background=>'black',
                )->pack(-side => "left", -anchor => "n",
                         -fill=>'y', 
                     -expand=>0,
                     );


my $mainframe = $mw->Scrolled('Pane', 
               -scrollbars=>'s', 
           -sticky=>'nwse',
           )->pack(-expand=>1, -fill=>'both');

$mainframe->Subwidget("xscrollbar")->configure(
               -background => 'red', 
           -activebackground => 'hotpink',
               -troughcolor => 'mistyrose',
           );

my $f1 = $mainframe->Frame()->pack(-fill=>'both',-expand=>1);
my $f2 = $mainframe->Frame()->pack();


#default empty image
my $image = $mw->Photo(-file => '' ) or die $!;

# a dir selector in left frame

my $ztree = $leftframe->Scrolled('CanvasDirTree',
            -bg =>'white',
            -width =>150,  
        -height =>750, 
            -floatback => 1,
        -font => 'big',        # defaults to system
            -scrollbars =>'sw',
            -borderwidth =>1,
        -scrollregion => [0,0,300,700]
        )->pack(-side=>'left',-fill=>'y', -expand=>0); 


$ztree->bind('<ButtonPress-1>', sub{   
               my $selected = $ztree->get_selected();
            if(length $selected){
                #print "$selected\n";
                add_dir_contents($selected);
             }
       });

# set scrollbar colors
my $xbar = $ztree->Subwidget("xscrollbar");
my $ybar = $ztree->Subwidget("yscrollbar");
# do not attempt to change the scrollbar's  -yscrollbackcommand
# it is used internally by CanvasDirTree
for($xbar,$ybar){
  $_->configure(
           -background => "darkseagreen", 
           -activebackground => "lightgreen",
       -troughcolor => "black",
          );
}


# canvas for midframe to hold thumbnails
my $ct = $midframe->Scrolled('Canvas',
                           -width => 110,
                           -background => 'black',
               -scrollbars => 'w',
              )->pack(-side => "left", -anchor => "n",
                       -fill => 'y', 
                   -expand => 1
                   );

$ct->Subwidget("yscrollbar")->configure(
               -background => 'lightsteelblue', 
           -activebackground => 'steelblue',
               -troughcolor => 'mistyrose',
           );

#fill mainframe with default screen 
setup_pane();

$mw->waitVisibility;

# Start with the current directory
add_dir_contents(".");

MainLoop;
######################################################################
+###
sub setup_pane{


$can1 = $f1->Scrolled('Canvas',
               -background =>'lightyellow',
               -width =>  400,
           -height => 500,
               -scrollbars => 'osow',
           -scrollregion => [ 0, 0, $source_size_x, $source_size_y ], 
             )->pack(-side => 'left',
                       -anchor => 'n',
                       -fill => 'both',
               -expand => 1,
              );

$can1->Subwidget("yscrollbar")->configure(
               -background => 'yellow3', 
           -activebackground => 'yellow',
           -troughcolor => 'white',
           );
$can1->Subwidget("xscrollbar")->configure(
               -background => 'yellow3', 
           -activebackground => 'yellow',
           -troughcolor => 'white',
           );

$rcan1 = $can1->Subwidget("scrolled"); #needed for some bindings

$photo = $can1->createImage(0,0,-image => $image, -anchor =>'nw',-tags
+ => ['image1']);      


$rcan1->Tk::bind('<ButtonPress-1>' => \&start_rect);
$rcan1->Tk::bind('<ButtonRelease-1>' => \&stop_rect);

$can2 = $f1->Scrolled('Canvas',
               -background =>'lightgreen',
               -width =>  400,
           -height => 500,
               -scrollbars => 'osow',
           -scrollregion => [ 0, 0, $target_size_x, $target_size_y ], 
             )->pack(-side => 'left',
                       -anchor => 'n',
                       -fill => 'both',
               -expand => 1,
              );

$rcan2 = $can2->Subwidget("scrolled"); #needed for some bindings

$rcan2->bind('move', '<1>',  \&mobileStart );
$rcan2->bind('move', '<B1-Motion>',  \&mobileMove );
$rcan2->bind('move', '<ButtonRelease>', \&mobileStop );

# clear source canvas
$mw->bind('<Escape>' => sub {   
              $can2->delete('move');
             });

$can2->Subwidget("yscrollbar")->configure(
               -activebackground => 'green3', 
           -background => 'darkolivegreen',
           -troughcolor => 'white',
           );
$can2->Subwidget("xscrollbar")->configure(
               -activebackground => 'green3', 
               -background => 'darkolivegreen',
           -troughcolor => 'white',
           );

$f2->Label( -text => '                                                
+   ',
            -font => 'big',
            -background => 'antiquewhite4',
            -relief=>'raised',
        )->pack(-side=>'left',-fill =>'x',-expand =>1);

$f2->Label( -text => '        <---------------    --------------->    
+   ',
            -font => 'big',
            -background => 'black',
            -foreground => 'hotpink',
            -relief=>'raised',
        )->pack(-side=>'left',-fill =>'x',-expand =>1);

$f2->Label( -text => '                                                
+   ',
            -font => 'big',
            -background => 'antiquewhite4',
            -relief=>'raised',
        )->pack(-side=>'right', -fill => 'x',-expand =>1);

}
############################################################## 
sub browseThis {

  my @tags = $ct->gettags( $ct->find(qw|withtag current|) );
   @tags = grep { $_ ne 'temp' } @tags;
   @tags = grep { $_ ne 'current' } @tags;

   my $pic = $info{ $tags[0]  }{'pic'} || '';

   $image->blank;
   $image->read($pic);
  
   $can1->itemconfigure($photo,-image => $image );
  
   #update label
   $info = $info{ $tags[0] }{'info'};
}

############################################################

sub load_thumbs{

#clean up last display -------------------------

$ct->delete( $ct->find(qw|withtag temp|) );     

foreach my $key(keys %thumbs){
        $thumbs{$key}->blank;  #reuse thumbnail objects
     }

foreach( keys %info ){ 
        $info{$_}{'pic'} = '';
    $info{$_}{'info'} = '';
    $info{$_}{'thumbnail'} = '';
        delete $info{$_}{'pic'};
    delete $info{$_}{'info'};
    delete $info{$_}{'thumbnail'};
        delete $info{$_};
    } 
%info = ();

#-----------------------------------------------

my @exts = qw(.jpg .png ); # list allowed extensions 
#my @exts = qw(.png); # list allowed extensions 

my $picref = shift;
my @pics = @$picref;
my @slots = sort {$a<=>$b} keys %thumbs; 

my $slot_prev = -1;
my $scrollreg = (scalar @pics) * 130;

$ct->configure(-scrollregion =>[0,0,100,$scrollreg]);

foreach my $pic (@pics){    
          my ($basename,$path,$suffix) = fileparse($pic,@exts);
                    
           $info{$basename}{'pic'} = $pic; #full path to image 
       
       #get image info
       my ($width, $height, $size, $format) = $im->Ping($pic);
           $info{$basename}{'info'} = "$pic $width x $height  $size";
          
       # Create smaller version
           $im->Read($pic);
           $im->Scale( geometry => '100x100' );
           $info{$basename}{'thumbnail'} = $im->ImageToBlob();

           undef @$im; # blank $im object 
           
       #reuse slots for thumbnails to avoid memory gain
           my $slot = shift(@slots);
       $slot ||= -1;
       if($slot == -1){ $slot = $slot_prev + 1 }
               
           &add_key( $basename, $slot ); 
           
           $slot_prev = $slot;           
           $mw->update; 
  }

undef @$im;

$ct->bind("temp","<Button-1>", sub { &browseThis  });

}
###################################################################
sub add_key{

my($key, $slot) = @_;

#print "$key $slot\n";

    #Tk needs data images base64 encoded
        my $content = encode_base64( $info{$key}{'thumbnail'} );
        
    if(ref $thumbs{$slot} eq 'Tk::Photo'){       
              $thumbs{$slot}->put($content)
       }else{
          $thumbs{$slot} = $mw->Photo(-data => $content  );
             }

    my $y = $slot * 130;         

    $ct->createText( 50,$y + 10,  
           -tags => ['temp', $key],
       -fill => 'yellow',
       -text => $key,
#       -font => 'medium',
      );         
    
    $ct->createImage( 0, $y +20 , 
           -image =>$thumbs{$slot} , 
       -tags => ['temp', $key],
       -anchor => 'nw' 
       );         
    
    
    $ct->createLine( 0,$y,130,$y,  
            -tags => ['temp',$key],
       -fill => 'white',
       -width => 5,
       -dash => [6,4],
      );         

}

######################################################################
+####
sub add_dir_contents {
    my $path   = $_[0];
    my $oldcursor = $mw->cget('cursor');    # Remember current cursor,
+ and
    $mw->configure( -cursor => 'watch' );   # change cursor to watch
    $mw->update();
   
   #this decode utf8 routine is used so filenames with extended
   # ascii characters (unicode) in filenames, will work properly
   use Encode;
   opendir my $dh, $path or warn "Error: $!";
   my @files = grep !/^\.\.?$/, readdir $dh;
   closedir $dh;
   # @files = map{ "$path/".$_ } sort @files;
   #$_ = decode( 'utf8', $_ ) for ( @files );
   @files = map { decode( 'utf8', "$path/".$_  ) } sort @files;
   
    my @thumbs=();
    foreach my $file (@files) {
        $file =~ s|//|/|g;
       (my $text = $file ) =~ s|^.*/||g;
        if ( -d $file ) {
           next
        }
        else {
             if( $file =~ /.*\.(png|jpg)$/ ){ push @thumbs, "$file" }
             }
    }
    $mw->configure( -cursor => $oldcursor );

load_thumbs( \@thumbs );

}

###############################################################

sub start_rect {

    my $event = $rcan1->XEvent;
    my $x = $rcan1->canvasx($event->x);
    my $y = $rcan1->canvasy($event->y);
    
    $can1->create('rectangle', $x, $y, $x+10, $y+10, 
                 -width => 4,
                 -tags => ['rect']);

    $rcan1->Tk::bind('<Motion>' => \&making_rect);
}
###############################################################


sub making_rect {

    my $event = $rcan1 ->XEvent;
    my $x = $rcan1->canvasx($event->x);
    my $y = $rcan1->canvasy($event->y);

    my ($x0,$y0,$x1,$y1) = $can1->coords('rect');
#    $canvas->coords('rect', $x0, $y0, $x, $y );

   $can1->coords('rect', $x0,$y0,$x,$y);

}

#########################################################

sub stop_rect {
    
    $rcan1->Tk::bind('<Motion>' => undef );   
    
    my $event = $rcan1 ->XEvent;
    my $x = $rcan1->canvasx($event->x);
    my $y = $rcan1->canvasy($event->y);

    my ($x0,$y0,$x1,$y1) = $can1->coords('rect');
#    $canvas->coords('rect', $x0, $y0, $x, $y );

    my $width = $x1 - $x0;
    my $height = $y1 -$y0;

# flash red the delete rect so as not to copy it
    $can1->itemconfigure('rect',-outline =>'red');
    $can1->update;
    $can1->delete('rect');
    
    #returns to $ps
    my $ps = $can1->postscript(  -x=>$x0,
                                 -y=>$y0,
                                 -width => $width,
                                 -height=> $height
                                   );
   #reset IM object
   undef @$output;
   $output->Set(magick=>'ps');
   $output->BlobToImage( $ps );

   #$output->Resize(geometry=> $width.'x'.$height);
   #$output->Write('z.jpg');
  
   $output->Set(magick=>'jpeg');
   my $blob = $output->ImageToBlob(); #now a blob in jpg instead of po
+stscript
   # print $blob;

#make new selection on $can2
   my $new_image = $mw->Photo(-format => 'jpeg',-data => encode_base64
+($blob) ) or die $!;

    $x2 +=20; $y2+=20; #stagger them for ease of dragging to position
    $can2->createImage( $x2, $y2, 
           -image =>$new_image, 
       -tags => ['move'],
       -anchor => 'nw' 
       );         

}

##############################################################

sub mobileStart {
      my $ev = $rcan2->XEvent;
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
      $rcan2->raise('current');
      #print "START MOVE->  $dx  $dy\n";
}
###############################################################

sub mobileMove {
      my $ev = $rcan2->XEvent;
      $rcan2->move('current', $ev->x + $dx, $ev->y +$dy);
      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);
      #print "MOVING->  $dx  $dy\n";
}
############################################################
sub mobileStop{}
##############################################################

sub save{
         $can2->update;
         my @capture=();
         my ($x0,$y0,$x1,$y1)=$can2->bbox('all');
         @capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-$x
+0);
         my $ps = $can2 -> postscript(  -colormode=>'color',
                           -rotate=>0,
                   -width=>$x1-$x0,
                   -height=>$y1-$y0,    
                   @capture);

         #reset/clear IM object and convert from ps to jpg
         undef @$output;
         $output->Set(magick=>'ps');
         $output->BlobToImage( $ps );
         $output->Set(magick=>'jpeg');
         $output->Write("$0.jpg");
         print "saved\n";

}

__END__

[download]

In reply to Tk Canvas Image Sampler/ Montage builder by zentara

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":


  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (6)
As of 2024-04-19 06:42 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found