An image viewer on the Gnome::Canvas in perl

[dov imagic weizmann ac il]

Hello,

I wrote the following image viewer with the perl Gnome::Canvas module.
In terms of functionality everything except scrolling works quite well.
The main work of this pseudo widget is done in the sub view_changed()
that does the following series of calls:
    
    $sim = $img->crop_and_clone($x0,$y0,$cw,$ch);
    $sim2 = $sim->clone_scaled_image($sw, $sh);
    $canv_img->get("image")->destroy_image;
    $canv_img->set("image",$sim2);

Where:
    $img        is the original imlib image
    $x0, $y0    Are the coordinates in the orig image beeing zoomed in.
    $cw, $ch    Are the width and the height of the area beeing zoomed in.
    $sw, $sh    are the scaled width and height.

Thus there is a lot of work being done for every scrolling and scaling
callback action. If the image had a parameter "-crop" indicating the
rectangle of the original image currently being viewed, then there
could be more intelligent scrolling being done inside the canvas image
widget code, but as it is now, I don't think I can make it any faster.
But I would be happy if you could prove me wrong.

I would also be very thankful if someone could make this pseudo widget
into a real widget, or at least point me to documentation of how to
do this in perl.

TIA,
Dov Grobgeld

#!/usr/local/bin/perl -w
######################################################################
#  An example pseudo widget that is zoomable with callbacks similar
#  to gimp.
#
#  This code is released under the GPL.
#  Dov Grobgeld 2000-01-23
######################################################################

use Gnome;
use strict;

######################################################################
#  The zoom canvas code. This should be changed into a real widget.
######################################################################
sub new_zoom_canvas {
    my ($img) = shift;
    my $this = {};
    $this->{current_scale} = 0;
    $this->{x0} = 0;
    $this->{y0} = 0;
    $this->{do_scroll} = 0;
    $this->{img} = $img;
    $this->{canvas_width} = $img->rgb_width;
    $this->{canvas_height} = $img->rgb_height;
    my $canvas = Gnome::Canvas->new();
    $this->{root} = $canvas->root();
    $this->{canvas} = $canvas;
    my $canv_img  = Gnome::CanvasItem->new($this->{root},
					"Gnome::CanvasImage",
					image  => $img->crop_and_clone_image(0,0,$img->rgb_width, $img->rgb_height),
					x      => 0,
					y      => 0,
					width  => $img->rgb_width,
					height => $img->rgb_height,
					anchor => "nw",
				       );
    $canvas->set_usize($this->{canvas_width},$this->{canvas_height});
    $canvas->set_scroll_region (0, 0, $this->{canvas_width},
				$this->{canvas_height});
    $canvas->signal_connect("key_press_event" =>
			    [\&key_press_handler, $this]);
    $canvas->signal_connect("button_press_event" =>
			    [\&button_press_handler, $this]);
    $canvas->signal_connect("button_release_event" =>
			    [\&button_release_handler, $this]);
    $canvas->signal_connect("motion_notify_event" =>
			    [\&motion_handler, $this]);
    $this->{canv_img} = $canv_img;

    $this->{last_x} = 0;
    $this->{last_y} = 0;
    $this->{do_scroll} = 0;

    view_changed($this, 1,0,0);
    return $canvas;
}

sub key_press_handler {
    my($this, $zc, $ev) = @_;
    my $keych = pack("C*", $ev->{keyval});

    if    ($keych =~ /^[1]$/)  { zoom_reset($zc); }
    elsif ($keych =~ /^[>=]$/) { zoom_in($zc, $zc->{last_x}, $zc->{last_y}); }
    elsif ($keych =~ /^[<-]$/) { zoom_out($zc, $zc->{last_x},$zc->{last_y}); }
}

sub button_press_handler {
    my($this, $zc, $ev) = @_;
    my($x,$y) = ($ev->{x}, $ev->{y});
    my($button) = $ev->{button};
    
    if    ($button == 1) {
	zoom_in($zc, $x,$y);
    }
    elsif ($button == 2) {
	$zc->{do_scroll} = 1;
	$zc->{last_x} = $x;
	$zc->{last_y} = $y;
    }
    elsif ($button == 3) {
	zoom_out($zc, $x,$y);
    }
}

sub button_release_handler {
    my($this, $zc, $ev) = @_;
    my($button) = $ev->{button};
    if ($button == 2) {
	$zc->{do_scroll} = 0;
    }
}

sub motion_handler {
    my($this, $zc, $ev) = @_;
    my($x,$y) = ($ev->{x}, $ev->{y});
    my $current_scale = $zc->{current_scale};
    my $current_x0 = $zc->{current_x0};
    my $current_y0 = $zc->{current_y0};
    my $last_x = $zc->{last_x};
    my $last_y = $zc->{last_y};
    
    if ($zc->{do_scroll}) {
	my($dx, $dy) = (($last_x-$x) / $current_scale,
			($last_y-$y) / $current_scale);
	view_changed($zc, $current_scale, $current_x0 + $dx, $current_y0 + $dy);
    }
    $zc->{last_x} = $x;
    $zc->{last_y} = $y;
}

######################################################################
# Called to do the repainting according to the scale and the
# new origin. 
######################################################################
sub view_changed {
    my($zc, $scale, $x0, $y0) = @_;
    my $img = $zc->{img};
    my $canv_img = $zc->{canv_img};
    my $canvas_width = $zc->{canvas_width};
    my $canvas_height = $zc->{canvas_height};
    my $current_x0 = $zc->{current_x0};
    my $current_y0 = $zc->{current_y0};
    my $current_scale = $zc->{current_scale};
    my ($width, $height);

    if ($scale>128) {
	return 0;
    }

    # Crop the request 
    $x0 = 0 if ($x0 < 0);
    $y0 = 0 if ($y0 < 0);

    if ($zc->{img}) {
	my $img_width = $img->rgb_width;
	my $img_height = $img->rgb_height;
	
	if ($img_width*$scale > $canvas_width) {
	    $width = $canvas_width;
	}
	else {
	    $width = $img_width * $scale;
	}
	if ($img_height*$scale > $canvas_height) {
	    $height = $canvas_height;
	}
	else {
	    $height = $img->rgb_height * $scale;
	}
	
	if ($x0 + $width/$scale > $img->rgb_width) {
	    $x0 = int($img->rgb_width - $width/$scale);
	}
	if ($y0 + $height/$scale > $img->rgb_height) {
	    $y0 = int($img->rgb_height - $height/$scale);
	}
    }
    
    $x0 = int($x0);
    $y0 = int($y0);

    if ($current_scale != $scale || $x0 != $current_x0 || $y0 != $current_y0) {
	if ($img) {
	    my $cut_width = int(1.0*$width/$scale+0.9999);
	    my $cut_height = int(1.0*$height/$scale+0.9999);
	    my ($scale_width, $scale_height);

	    if ($cut_width > $img->rgb_width) {
		$cut_width = $img->rgb_width;
	    }
	    if ($cut_height > $img->rgb_height) {
		$cut_height = $img->rgb_height;
	    }
	
	    $scale_width = $cut_width * $scale;
	    $scale_height = $cut_height * $scale;

	    # Cut out a small rectangle 
	    my $sim = $img->crop_and_clone_image($x0,$y0,$cut_width, $cut_height);
	    
	
	    # Scale it to the current scale 
	    my $sim2 = $sim->clone_scaled_image($scale_width, $scale_height);
	    $canv_img->get("image")->destroy_image; # Critical in order not to get a memory leek!

	    $canv_img->set("image",$sim2);
	    $canv_img->set("width",$sim2->rgb_width);
	    $canv_img->set("height",$sim2->rgb_height);

	    # cleanup;
	    $sim->destroy_image;
	}
    }

    $zc->{current_scale} = $scale;
    $zc->{current_x0} = $x0;
    $zc->{current_y0} = $y0;
}

sub zoom_reset {
    my($zc) = shift;
    view_changed($zc, 1,0,0);
}

sub zoom_out
{
    my ($zc, $x, $y) = @_;
    my $current_scale = $zc->{current_scale}; # shortcut
    my $new_scale=$current_scale /2;
    my ($x0, $y0);

    if ($new_scale < 1.0/16) {
	$new_scale = 1.0/16;
    }
    $x0 = $zc->{current_x0} - $zc->{canvas_width}/$current_scale/2;
    if ($x0<0) {
	$x0 = 0;
    }
    $y0 = $zc->{current_y0} - $zc->{canvas_height}/$current_scale/2;
    if ($y0<0) {
	$y0 = 0;
    }

    view_changed($zc, $new_scale, $x0, $y0);
}

sub zoom_in {
    my($zc, $x, $y) = @_;
    my ($x0, $y0);
    my $scale = $zc->{current_scale}; # shortcut
    $x0 = $zc->{current_x0} + $x/$scale - $zc->{canvas_width}/4/$scale;
    $y0 = $zc->{current_y0} + $y/$scale - $zc->{canvas_height}/4/$scale;

    view_changed($zc, $scale * 2, $x0, $y0);
}

######################################################################
# main
######################################################################

init Gnome "img on canvas";
init Gtk::Gdk::ImlibImage;

my $img = Gtk::Gdk::ImlibImage->load_image(shift||"toroid.png") || die;

# Create main window
my $mw = Gtk::Widget->new("Gtk::Window",
			  -type                 => -toplevel,
			  -title                => "Test of ZoomCanvas",
			  -signal::destroy => sub {exit}
			 );
    
# Create a zoom canvas
my $canvas = new_zoom_canvas($img);
$mw->add($canvas);
show $canvas;
$canvas->grab_focus();

$mw->show;

main Gtk;