File Coverage

blib/lib/Graphics/DZI.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Graphics::DZI;

use strict;
use warnings;
use POSIX;

use Moose;

our $log;
use Log::Log4perl;
BEGIN {
    $log = Log::Log4perl->get_logger ();
}

=head1 NAME

Graphics::DZI - DeepZoom Image Pyramid Generation

=head1 SYNOPSIS

  use Graphics::DZI;
  my $dzi = Graphics::DZI     (image    => $image,
                               overlap  => $overlap,
                               tilesize => $tilesize,
                               format   => $format,
                               );

  write_file ('/var/www/xxx.xml', $dzi->descriptor);
  $dzi->iterate ();
  # !!! this does only display the tiles on the screen
  # !!! see Graphics::DZI::Files for a subclass which
  # !!! actually writes to files

=head1 DESCRIPTION

This base package generates tiles from a given image in such a way that they follow the DeepZoom
image pyramid scheme. Consequently this image becomes zoomable with tools like Seadragon.

  http://en.wikipedia.org/wiki/Deep_Zoom

As this is a base class, you may want to look either at the I<deepzoom> script which operators on
the command line, or at one of the subclasses.

=head1 INTERFACE

=head2 Constructor

The constructor accepts the following fields:

=over

=item C<image>

The L<Image::Magick> object which is used as canvas.

(since 0.05)

The image can also be a whole stack (L<Image::Magick> allows you to do that). In that case the
bottom image is regarded as the one with the I<highest> degree of detail, and that is tiled first
(at the higher resolutions). Images up the stack are then taken in turn, until only the top-level
image remains. See C<pop> if you want to influence this policy.

=item C<scale> (integer, default: 1)

Specifies how much the image is stretched in the process.

=item C<overlap> (integer, default: 4)

Specifies how much the individual tiles overlap.

=item C<tilesize> (integer, default: 128)

Specifies the quadratic size of each tile.

=item C<overlays> (list reference, default: [])

An array of L<Graphics::DZI::Overlay> objects which describe how further images are supposed to be
composed onto the canvas image.

=back

=cut

has 'image'    => (isa => 'Image::Magick', is => 'rw', required => 1);
has 'scale'    => (isa => 'Int',           is => 'ro', default => 1);
has 'overlap'  => (isa => 'Int',           is => 'ro', default => 4);
has 'tilesize' => (isa => 'Int',           is => 'ro', default => 256);
has 'format'   => (isa => 'Str'   ,        is => 'ro', default => 'png');
has 'overlays' => (isa => 'ArrayRef',      is => 'rw', default => sub { [] });

=head2 Methods

=over

=item B<crop>

I<$tile> = I<$dzi>->crop (I<$scale>, I<$x>, I<$y>, I<$dx>, I<$dy>)

Given the dimensions of a tile and a current (not the original)
stretch factor this method will return a tile object.

=cut

sub crop {
    my $self = shift;
    my $scale = shift;
    my ($tx, $ty, $tdx, $tdy) = @_;

    my $tile  = $self->{image}->[-1]->clone;                                                 # always take the "last" (lowest) image
    if ($scale != 1) {                                                                       # if our image is not quite the total space
#	warn "new canvas tile scaled $scale";
	my ($htx, $hty, $htdx, $htdy) = map { int ($_ / $scale) }
	                                ($tx, $ty, $tdx, $tdy);                              # rescale this tile to the image dims we have
	$log->debug ("rescale $tx, $ty  -->  $htx, $hty");
	$tile->Crop   (geometry => "${htdx}x${htdy}+${htx}+${hty}");                         # cut that smaller one out
	$tile->Resize ("${tdx}x${tdy}");                                                     # and make it bigger
    } else {                                                                                 # otherwise we are happy with what we have, dimension-wise
#	warn "new canvas tile unscaled";
	$tile->Crop (geometry => "${tdx}x${tdy}+${tx}+${ty}");                               # cut one out
    }
    $log->debug ("tiled ${tdx}x${tdy}+${tx}+${ty}");
#    $tile->Display();
    return $tile;
}

=item B<dimensions>

(I<$W>, I<$H>) = I<$dzi>->dimensions ('total')

(I<$W>, I<$H>) = I<$dzi>->dimensions ('canvas')

This method computes how large (in pixels) the overall image will be. If C<canvas> is passed in,
then any overlays are ignored. Otherwise their size (with their squeeze factors) are used to blow up
the canvas, so that the overlays fit onto the canvas.

=cut

sub dimensions {
    my $self = shift;
    my $what = shift || 'total';

    my ($W, $H);
    if ($what eq 'total') {
	use List::Util qw(max);
	my $max_squeeze = max map { $_->squeeze } @{ $self->overlays };
	$self->{scale} = defined $max_squeeze ? $max_squeeze : 1;
	($W, $H) = map { $_ * $self->{scale} } $self->image->GetAttributes ('width', 'height');
    } else {
	($W, $H) = $self->image->GetAttributes ('width', 'height');
    }
    use POSIX;
    my $level = POSIX::ceil (log ($W > $H ? $W : $H) / log (2));
    $log->debug (" dimensions: $W, $H  --> levels: $level");
    return ($W, $H, $level);
}

=item B<iterate>

I<$dzi>->iterate

This method will generate all necessary tiles, invoking the I<manifest> method. You may want to
override that one, if you do not want the tiles to be simply displayed on screen :-) Any options
you add as parameters will be passed on to I<manifest>.

B<NOTE>: During the process the image  will be modified!

=cut

sub iterate {
    my $self = shift;

    my $overlap_tilesize = $self->{tilesize} + 2 * $self->{overlap};
    my $border_tilesize  = $self->{tilesize} +     $self->{overlap};

    my ($CWIDTH, $CHEIGHT, $CANVAS_LEVEL) = $self->dimensions ('canvas');
    my ($WIDTH,  $HEIGHT,  $MAXLEVEL)     = $self->dimensions ('total');

    my ($width, $height) = ($WIDTH, $HEIGHT);
    my $scale = $self->{scale};
    foreach my $level (reverse (0..$MAXLEVEL)) {

	my ($x, $col) = (0, 0);
	while ($x < $width) {
	    my ($y, $row) = (0, 0);
	    my $tile_dx = $x == 0 ? $border_tilesize : $overlap_tilesize;
	    while ($y < $height) {

		my $tile_dy = $y == 0 ? $border_tilesize : $overlap_tilesize;

		my @tiles = grep { defined $_ }                                                # only where there was some intersection
                            map {
				$_->crop ($x, $y, $tile_dx, $tile_dy);                         # and for each overlay crop it onto a tile
			    } @{ $self->overlays };                                            # look at all overlays

		if (@tiles) {                                                                  # if there is at least one overlay tile
		    my $tile = $self->crop ($scale, $x, $y, $tile_dx, $tile_dy);               # do a crop in the canvas and try to get a tile
		    map {
			$tile->Composite (image => $_, x => 0, 'y' => 0, compose => 'Over')
		    } @tiles;
		    $self->manifest ($tile, $level, $row, $col);                               # we flush it

		} elsif ($level <= $CANVAS_LEVEL) {                                            # only if we are in the same granularity of the canvas
		    my $tile = $self->crop ($scale, $x, $y, $tile_dx, $tile_dy);               # do a crop there and try to get a tile
#warn "tile ";		    $tile->Display();
		    $self->manifest ($tile, $level, $row, $col);                               # we flush it
		}

		$y += ($tile_dy - 2 * $self->{overlap});                                       # progress y forward
		$row++;                                                                        # also the row count
	    }
	    $x += ($tile_dx - 2 * $self->{overlap});                                           # progress x forward
	    $col++;                                                                            # the col count
	}

#-- resizing canvas
	($width, $height) = map { POSIX::ceil ($_ / 2) } ($width, $height);
	if (@{ $self->overlays }) {                                                            # do we have overlays from which the scale came?
	    $scale /= 2;                                                                       # the overall magnification is to be reduced
	    foreach my $o (@{ $self->overlays }) {                                             # also resize all overlays
		$o->halfsize;
	    }
	} else {
	    # keep scale == 1
	    $self->{image}->Resize (width => $width, height => $height);                       # resize the canvas for next iteration
	}
	$self->pop;                                                                            # for multi-level images
    }
}

=pod

=item B<pop>

(since 0.05)

This method is only interesting to you if your canvas images is a whole stack, not just a single
image. In that case, it will remove the first of the stack (a shift) to make the next in the line
visible to the further tiling process. As the tiling starts with the highest resolution, your image
stack should be organized that the one with the most details is on the bottom (highest index, pushed
last).

This method will do a C<pop> B<at every> half-sizing step and obviously only that long as there is
something to shift. If you are not happy with this default policy, you will have to subclass.

=cut

sub pop {
    my $self = shift;
    pop @{ $self->image } if scalar @{ $self->image } > 1;                                   # if we have a stack of images, remove that with the most details (i.e. first)
}

=item B<manifest>

I<$dzi>->manifest (I<$tile>, I<$level>, I<$row>, I<$col>)

This method will get one tile as parameter and will simply display the tile on the screen.
Subclasses which want to persist the tiles, can use the additional parameters (level, row and
column) to create file names.

=cut

sub manifest {
    my $self = shift;
    my $tile = shift;
    $tile->Display();
}

=item B<descriptor>

I<$string> = I<$dzi>->descriptor

This method returns the DZI XML descriptor as string.

=cut

sub descriptor {
    my $self     = shift;
    my $overlap  = $self->{overlap};
    my $tilesize = $self->{tilesize};
    my $format   = $self->{format};
    my ($width, $height) = $self->dimensions ('total');
    return qq{<?xml version='1.0' encoding='UTF-8'?>
<Image TileSize='$tilesize'
              Overlap='$overlap'
              Format='$format'
              xmlns='http://schemas.microsoft.com/deepzoom/2008'>
        <Size Width='$width' Height='$height'/>
</Image>
};


}

=back

=head1 TODOs

See the TODOs file in the distribution.

=head1 AUTHOR

Robert Barta, C<< <drrho at cpan.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2010 Robert Barta, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl
itself.

=cut

our $VERSION = '0.05';

"against all odds";