magic-1 magic-2 magic-3 defend-1 defend-2 defend-3 hit-1 hit-2 hit-3 dead-1 dead-2 dead-3 sick-1 sick-2 sick-3 win-1 win-2 win-3 left-1 left-2 left-3 right-1 right-2 right-3 ##
##

package Image::Tileset;

use strict;
use warnings;
use Image::Magick;
use XML::Simple;
use Data::Dumper;

our $VERSION = '0.01';

=head1 NAME

Image::Tileset - A tileset loader.

=head1 SYNOPSIS

  use Image::Tileset;

  my $ts = new Image::Tileset (
    image => "my-tileset.png",
    xml   => "my-tileset.xml",
  );

  open (OUT, ">grass.png");
  binmode OUT;
  print OUT $ts->tile("grass");
  close (OUT);

=head1 DESCRIPTION

Image::Tileset is a simple tileset image loader. The preferred usage is to have
an XML description file alongside the tileset image that describes how the
tiles are to be sliced up.

The module supports "simple" tilesets (where all tiles have a uniform width and
height, though they don't need to begin at the top left corner of the image)
as well as "fixed" tilesets (where you need to specify the exact pixel coords
of every tile).

It also supports the management of animations for your tiles (but not the means
to display them; this is left up to your front-end code. There is a demo that
uses Perl/Tk to give you an idea how to do this).

=head1 SPECIFICATION FILE

Tileset images are paired with a "specification file," which describes how the
image is to be sliced up into the different tiles.

The spec file is usually an XML document, and it's read with L.
If you wish, you can also send the spec data as a Perl data structure, skipping
the XML part.

An example XML file is as follows, and shows all the capabilities of the
spec file markup:

  
  
    
    
      
      
      
      

      
      
      
      
    

    
    
      
      
    

    
    
      water-1
      water-2
      water-3
      water-2
    
  

See the examples in the C folder for more information.

=head1 METHODS

=head2 new (hash options)

Create a new C object. Options include:

  bool   debug:  Debug mode (prints stuff to the terminal on STDERR)
  string xml:    Path to an XML spec file that describes the image.
  hash   spec:   Spec data in Perl data structure form (skip XML file).
  string image:  Path to the image file.

=cut

sub new {
	my $class = shift;

	my $self = {
		debug  => 0,      # Debug mode
		xml    => '',     # XML file
		spec   => [],     # Spec data (XML data in Perl form)
		image  => '',     # Image file
		magick => undef,  # Image::Magick object
		error  => '',     # Last error state
		tiles  => {},     # Tile positions in tileset
		animations => {}, # Animation information
		@_,
	};
	bless ($self,$class);

	$self->{magick} = Image::Magick->new;

	# If given an image, load it.
	if (length $self->{image}) {
		$self->image ($self->{image});
	}

	# If given an XML file, load it.
	if (length $self->{xml}) {
		$self->xml ($self->{xml});
		$self->{xml} = '';
	}

	# If given a spec, load it.
	if (ref($self->{spec}) eq "ARRAY" && scalar @{$self->{spec}} > 0) {
		$self->refine ($self->{spec});
		$self->{spec} = [];
	}

	return $self;
}

sub debug {
	my ($self,$line) = @_;
	return unless $self->{debug};
	print STDERR "$line\n";
}

=head2 void error ()

Print the last error message given. Example:

  $tileset->loadImage("myfile.png") or die $tileset->error;

=cut

sub error {
	my ($self,$error) = @_;
	if (defined $error) {
		$self->{error} = $error;
	}
	return $self->{error};
}

=head2 bool image (string image)

Load an image file with C.

Returns 1 on success, undef on error.

=cut

sub image {
	my ($self,$image) = @_;
	$self->debug("Attempting to load image file from $image");

	# Exists?
	if (!-e $image) {
		$self->error("Can't load image file $image: file not found!");
		return undef;
	}

	# Load it with Image::Magick.
	my $x = $self->{magick}->Read($image);
	warn $x if $x;

	return 1;
}

=head2 bool xml (string specfile)

Load a specification file from XML.

Returns 1 on success, undef on error.

=cut

sub xml {
	my ($self,$file) = @_;
	$self->debug("Attempting to load XML file from $file");

	# Exists?
	if (!-e $file) {
		$self->error("Can't load XML spec file $file: file not found!");
		return undef;
	}

	# Load it with XML::Simple.
	my $o_xs = new XML::Simple (
		RootName   => 'tileset',
		ForceArray => 1,
		KeyAttr    => 'id',
	);
	my $xs = $o_xs->XMLin($file);

	# Does it look good?
	if (!exists $xs->{layout}) {
		$self->error("No layout information was found in XML spec file!");
		return undef;
	}

	# Refine it. We want pixel coords of every named tile.
	$self->refine($xs->{layout}) or return undef;

	return 1;
}

=head2 bool refine (array spec)

Refines the specification data. The spec describes how the image is cut up;
C goes through that and stores the exact pixel coordinates of every
tile named in the spec, for quick extraction when the tile is wanted.

This method is called automatically when an XML spec file is parsed. If you
pass in a C during the call to C, this method will be called
automatically for your spec. If you want to load a spec directly after you've
created the object, you can call C directly with your new spec.

=cut

sub refine {
	my ($self,$spec) = @_;

	# It must be an array.
	if (ref($spec) ne "ARRAY") {
		$self->error("Spec file must be an array of layouts!");
		return undef;
	}

	# Clear the currently loaded data.
	delete $self->{tiles};
	delete $self->{animations};
	$self->{tiles} = {};
	$self->{animations} = {};

	# Go through the layouts.
	$self->debug("Refining the specification...");
	foreach my $layout (@{$spec}) {
		my $type = lc($layout->{type});

		# Supported layout types:
		# tiles
		# fixed
		# animation
		if ($type eq "tiles") {
			# How big are the tiles?
			if ($layout->{size} !~ /^\d+x\d+$/) {
				$self->error("Syntax error in spec: 'tiles' layout but no valid tile 'size' set!");
				return undef;
			}
			my ($width,$height) = split(/x/, $layout->{size}, 2);
			$self->debug("Looking for 'tiles' layout; tile dimensions are $width x $height");

			# Offset coords.
			my $x = $layout->{x} || 0;
			my $y = $layout->{y} || 0;

			# Collect the tiles.
			foreach my $id (keys %{$layout->{tile}}) {
				# Tile coordinates.
				my $tileX = $layout->{tile}->{$id}->{x};
				my $tileY = $layout->{tile}->{$id}->{y};

				# Pixel coordinates.
				my $x1 = $x + ($width * $tileX);
				my $x2 = $x1 + $width;
				my $y1 = $y + ($height * $tileY);
				my $y2 = $y1 + $height;
				$self->debug("Found tile '$id' at pixel coords $x1,$y1,$x2,$y2");

				# Store it.
				$self->{tiles}->{$id} = [ $x1, $y1, $x2, $y2 ];
			}
		}
		elsif ($type eq "fixed") {
			# Fixed is easy, we already have all the coords we need.
			$self->debug("Looking for 'fixed' tiles");
			foreach my $id (keys %{$layout->{tile}}) {
				# Pixel coordinates.
				my $x1 = $layout->{tile}->{$id}->{x1};
				my $y1 = $layout->{tile}->{$id}->{y1};
				my $x2 = $layout->{tile}->{$id}->{x2};
				my $y2 = $layout->{tile}->{$id}->{y2};
				$self->debug("Found tile '$id' at pixel coords $x1,$y1,$x2,$y2");

				# Store it.
				$self->{tiles}->{$id} = [ $x1, $y1, $x2, $y2 ];
			}
		}
		elsif ($type eq "animation") {
			# Animations just have a list of tiles involved and some meta info.
			my $id = $layout->{id}; # Name of the animation sprite
			my $speed = $layout->{speed} || 500; # Speed of animation, in milliseconds
			$self->{animations}->{$id} = {
				speed => $speed,
				tiles => $layout->{tile},
			};
		}
		else {
			warn "Unknown layout type '$type'!";
		}
	}
}

=head2 data tiles ()

Return the tile coordinate information. In array context, returns a list of the
tile ID's. In scalar context, returns a hash reference in the following format:

  {
    'tile-id' => [
      x1, y1,
      x2, y2
    ],
    ...
  };

=cut

sub tiles {
	my ($self) = @_;
	return wantarray ? sort keys %{$self->{tiles}} : $self->{tiles};
}

=head2 data animations ()

Return the animation information. In array context, returns a list of the
animation ID's. In scalar context, returns a hash reference in the following
format:

  {
    'animation-id' => {
      speed => '...',
      tiles => [
        'tile-id',
        ...
      ],
    },
  };

=cut

sub animations {
	my ($self) = @_;
	return wantarray ? sort keys %{$self->{animations}} : $self->{animations};
}

=head2 bin tile (string id)

Get the binary data of one of the tiles, named C, from the original
tileset.

Returns undef on error.

=cut

sub tile {
	my ($self,$id) = @_;

	# Tile exists?
	if (!exists $self->{tiles}->{$id}) {
		$self->error("No tile named '$id' in tileset!");
		return undef;
	}

	# Slice the image.
	my $slice = $self->slice ($id);
	my $png = $slice->ImageToBlob();
	return $png;
}

=head2 data animation (string id)

Get the animation information about a specific animation ID.

Returns data in the format:

  {
    speed => '...',
    tiles => [ ... ],
  };

Returns undef on error.

=cut

sub animation {
	my ($self,$id) = @_;

	# Animation exists?
	if (!exists $self->{animations}->{$id}) {
		$self->error("No animation named '$id' in tileset!");
		return undef;
	}

	return $self->{animations}->{$id};
}

=head2 ImageMagick slice (string id)

Returns an C object that contains the sliced tile from the
original tileset. This is mostly for internal use only.

=cut

sub slice {
	my ($self,$id) = @_;

	# Tile exists?
	if (!exists $self->{tiles}->{$id}) {
		$self->error("No tile named '$id' in tileset!");
		return undef;
	}

	# Get the dimensions of the tile.
	my $width  = $self->{tiles}->{$id}->[2] - $self->{tiles}->{$id}->[0]; # x2 - x1
	my $height = $self->{tiles}->{$id}->[3] - $self->{tiles}->{$id}->[1]; # y2 - y1
	if ($width < 1 || $height < 1) {
		$self->error("Tile '$id' has impossible dimensions: $width x $height");
		return undef;
	}

	my $dims = $width . 'x' . $height;

	# Make a new ImageMagick object.
	my $slice = $self->{magick}->Clone();

	# Crop it.
	my $x = $self->{tiles}->{$id}->[0];
	my $y = $self->{tiles}->{$id}->[1];
	my $crop = $dims . "+$x+$y";
	$self->debug("Cropping image clone to $crop for tile $id");
	$slice->Crop($crop);

	return $slice;
}

=head1 SEE ALSO

L, which powers this module's graphics handling.

L, which powers this module's XML parsing.

=head1 CHANGES

  0.01  Fri Jan 15 2010
  - Initial release.

=head1 COPYRIGHT

The tileset graphics included for demonstration purposes are from RPG Maker
2003 and are copyright (C) Enterbrain.

Code written by Noah Petherbridge, http://www.kirsle.net/

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself, either Perl version 5.10.0 or, at your option,
any later version of Perl 5 you may have available.

=cut

1;