| Category: | GUI Programming |
| Author/Contact Info | zentara@zentara.net |
| Description: | UPDATED Jun20,2008 Simplified multiple canvas bindings, and made it all left-mouse-button operation. I like the simplicity of left-mouse single clicks and drags. This recursively browses a directory of png and jpg images (you can add more). It makes thumbnails for selection with a left click on subdirs. Upon left-click selection on a thumbnail, the full image is displayed in the source canvas, and a left-mouse-drag will draw a rectangular region on the image. Upon left-button release, the region will be copied to a second target canvas, where it can be positioned and saved. Useful for easy-mouse selections in creating montages. The entire target canvas can be saved as a jpg. So for instance, you can open a 100 photos, copy off only the faces, arrange them to please yourself, then save the whole montage as a jpg. For the more advanced Tk users, there is an interesting use of ImageMagick blobs to convert postscript directly to jpg, without temp files. |
#!/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__
|
|
Back to
Code Catacombs