libimager-perl 0.98+dfsg-2 / usr / lib / perl5 / Imager / Matrix2d.pm

package Imager::Matrix2d;
use strict;
use vars qw($VERSION);
use Scalar::Util qw(reftype looks_like_number);
use Carp qw(croak);

$VERSION = "1.011";

=head1 NAME

  Imager::Matrix2d - simple wrapper for matrix construction

=head1 SYNOPSIS

  use Imager::Matrix2d;
  $m1 = Imager::Matrix2d->identity;
  $m2 = Imager::Matrix2d->rotate(radians=>$angle, x=>$cx, y=>$cy);
  $m3 = Imager::Matrix2d->translate(x=>$dx, y=>$dy);
  $m4 = Imager::Matrix2d->shear(x=>$sx, y=>$sy);
  $m5 = Imager::Matrix2d->reflect(axis=>$axis);
  $m6 = Imager::Matrix2d->scale(x=>$xratio, y=>$yratio);
  $m8 = Imager::Matric2d->matrix($v11, $v12, $v13,
                                 $v21, $v22, $v23,
                                 $v31, $v32, $v33);
  $m6 = $m1 * $m2;
  $m7 = $m1 + $m2;
  use Imager::Matrix2d qw(:handy);
  # various m2d_* functions imported 
  # where m2d_(.*) calls Imager::Matrix2d->$1()

=head1 DESCRIPTION

This class provides a simple wrapper around a reference to an array of
9 coefficients, treated as a matrix:

 [ 0, 1, 2,
   3, 4, 5,
   6, 7, 8 ]

Most of the methods in this class are constructors.  The others are
overloaded operators.

Note that since Imager represents images with y increasing from top to
bottom, rotation angles are clockwise, rather than counter-clockwise.

=over

=cut

use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA);
@ISA = 'Exporter';
require 'Exporter.pm';
@EXPORT_OK = qw(m2d_rotate m2d_identity m2d_translate m2d_shear 
                m2d_reflect m2d_scale);
%EXPORT_TAGS =
  (
   handy=> [ qw(m2d_rotate m2d_identity m2d_translate m2d_shear 
                m2d_reflect m2d_scale) ],
  );

use overload 
  '*' => \&_mult,
  '+' => \&_add,
  '""'=>\&_string,
  "eq" => \&_eq;

=item identity()

Returns the identity matrix.

=cut

sub identity {
  return bless [ 1, 0, 0,
                 0, 1, 0,
                 0, 0, 1 ], $_[0];
}

=item rotate(radians=>$angle)

=item rotate(degrees=>$angle)

Creates a matrix that rotates around the origin, or around the point
(x,y) if the 'x' and 'y' parameters are provided.

=cut

sub rotate {
  my ($class, %opts) = @_;
  my $angle;

  if (defined $opts{radians}) {
    $angle = $opts{radians};
  }
  elsif (defined $opts{degrees}) {
    $angle = $opts{degrees} * 3.1415926535 / 180;
  }
  else {
    $Imager::ERRSTR = "degrees or radians parameter required";
    return undef;
  }

  if ($opts{'x'} || $opts{'y'}) {
    $opts{'x'} ||= 0;
    $opts{'y'} ||= 0;
    return $class->translate('x'=>-$opts{'x'}, 'y'=>-$opts{'y'})
      * $class->rotate(radians=>$angle)
        * $class->translate('x'=>$opts{'x'}, 'y'=>$opts{'y'});
  }
  else {
    my $sin = sin($angle);
    my $cos = cos($angle);
    return bless [ $cos, -$sin, 0,
                   $sin,  $cos, 0,
                   0,     0,    1 ], $class;
  }
}

=item translate(x=>$dx, y=>$dy)

=item translate(x=>$dx)

=item translate(y=>$dy)

Translates by the specify amounts.

=cut

sub translate {
  my ($class, %opts) = @_;

  if (defined $opts{'x'} || defined $opts{'y'}) {
    my $x = $opts{'x'} || 0;
    my $y = $opts{'y'} || 0;
    return bless [ 1, 0, $x,
                   0, 1, $y,
                   0, 0, 1 ], $class;
  }

  $Imager::ERRSTR = 'x or y parameter required';
  return undef;
}

=item shear(x=>$sx, y=>$sy)

=item shear(x=>$sx)

=item shear(y=>$sy)

Shear by the given amounts.

=cut
sub shear {
  my ($class, %opts) = @_;

  if (defined $opts{'x'} || defined $opts{'y'}) {
    return bless [ 1,             $opts{'x'}||0, 0,
                   $opts{'y'}||0, 1,             0,
                   0,             0,             1 ], $class;
  }
  $Imager::ERRSTR = 'x and y parameters required';
  return undef;
}

=item reflect(axis=>$axis)

Reflect around the given axis, either 'x' or 'y'.

=item reflect(radians=>$angle)

=item reflect(degrees=>$angle)

Reflect around a line drawn at the given angle from the origin.

=cut

sub reflect {
  my ($class, %opts) = @_;
  
  if (defined $opts{axis}) {
    my $result = $class->identity;
    if ($opts{axis} eq "y") {
      $result->[0] = -$result->[0];
    }
    elsif ($opts{axis} eq "x") {
      $result->[4] = -$result->[4];
    }
    else {
      $Imager::ERRSTR = 'axis must be x or y';
      return undef;
    }

    return $result;
  }
  my $angle;
  if (defined $opts{radians}) {
    $angle = $opts{radians};
  }
  elsif (defined $opts{degrees}) {
    $angle = $opts{degrees} * 3.1415926535 / 180;
  }
  else {
    $Imager::ERRSTR = 'axis, degrees or radians parameter required';
    return undef;
  }

  # fun with matrices
  return $class->rotate(radians=>-$angle) * $class->reflect(axis=>'x') 
    * $class->rotate(radians=>$angle);
}

=item scale(x=>$xratio, y=>$yratio)

Scales at the given ratios.

You can also specify a center for the scaling with the C<cx> and C<cy>
parameters.

=cut

sub scale {
  my ($class, %opts) = @_;

  if (defined $opts{'x'} || defined $opts{'y'}) {
    $opts{'x'} = 1 unless defined $opts{'x'};
    $opts{'y'} = 1 unless defined $opts{'y'};
    if ($opts{cx} || $opts{cy}) {
      return $class->translate('x'=>-$opts{cx}, 'y'=>-$opts{cy})
        * $class->scale('x'=>$opts{'x'}, 'y'=>$opts{'y'})
          * $class->translate('x'=>$opts{cx}, 'y'=>$opts{cy});
    }
    else {
      return bless [ $opts{'x'}, 0,          0,
                     0,          $opts{'y'}, 0,
                     0,          0,          1 ], $class;
    }
  }
  else {
    $Imager::ERRSTR = 'x or y parameter required';
    return undef;
  }
}

=item matrix($v11, $v12, $v13, $v21, $v22, $v23, $v31, $v32, $v33)

Create a matrix with custom coefficients.

=cut

sub matrix {
  my ($class, @self) = @_;

  if (@self == 9) {
    return bless \@self, $class;
  }
  else {
    $Imager::ERRSTR = "9 coefficients required";
    return;
  }
}

=item _mult()

Implements the overloaded '*' operator.  Internal use.

Currently both the left and right-hand sides of the operator must be
an Imager::Matrix2d.

=cut

sub _mult {
  my ($left, $right, $order) = @_;

  if (ref($right)) {
    if (reftype($right) eq "ARRAY") {
      @$right == 9
	or croak "9 elements required in array ref";
      if ($order) {
	($left, $right) = ($right, $left);
      }
      my @result;
      for my $i (0..2) {
	for my $j (0..2) {
	  my $accum = 0;
	  for my $k (0..2) {
	    $accum += $left->[3*$i + $k] * $right->[3*$k + $j];
	  }
	  $result[3*$i+$j] = $accum;
	}
      }
      return bless \@result, __PACKAGE__;
    }
    else {
      croak "multiply by array ref or number";
    }
  }
  elsif (defined $right && looks_like_number($right)) {
    my @result = map $_ * $right, @$left;

    return bless \@result, __PACKAGE__;
  }
  else {
    # something we don't handle
    croak "multiply by array ref or number";
  }
}

=item _add()

Implements the overloaded binary '+' operator.

Currently both the left and right sides of the operator must be
Imager::Matrix2d objects.

=cut
sub _add {
  my ($left, $right, $order) = @_;

  if (ref($right) && UNIVERSAL::isa($right, __PACKAGE__)) {
    my @result;
    for (0..8) {
      push @result, $left->[$_] + $right->[$_];
    }
    
    return bless \@result, __PACKAGE__;
  }
  else {
    return undef;
  }
}

=item _string()

Implements the overloaded stringification operator.

This returns a string containing 3 lines of text with no terminating
newline.

I tried to make it fairly nicely formatted.  You might disagree :)

=cut

sub _string {
  my ($m) = @_;

  my $maxlen = 0;
  for (@$m[0..8]) {
    if (length() > $maxlen) {
      $maxlen = length;
    }
  }
  $maxlen <= 9 or $maxlen = 9;

  my @left = ('[ ', '  ', '  ');
  my @right = ("\n", "\n", ']');
  my $out;
  my $width = $maxlen+2;
  for my $i (0..2) {
    $out .= $left[$i];
    for my $j (0..2) {
      my $val = $m->[$i*3+$j];
      if (length $val > 9) {
        $val = sprintf("%9f", $val);
        if ($val =~ /\./ && $val !~ /e/i) {
          $val =~ s/0+$//;
          $val =~ s/\.$//;
        }
        $val =~ s/^\s//;
      }
      $out .= sprintf("%-${width}s", "$val, ");
    }
    $out =~ s/ +\Z/ /;
    $out .= $right[$i];
  }
  $out;
}

=item _eq

Implement the overloaded equality operator.

Provided for older perls that don't handle magic auto generation of eq
from "".

=cut

sub _eq {
  my ($left, $right) = @_;

  return $left . "" eq $right . "";
}

=back

The following functions are shortcuts to the various constructors.

These are not methods.

You can import these methods with:

  use Imager::Matrix2d ':handy';

=over

=item m2d_identity

=item m2d_rotate()

=item m2d_translate()

=item m2d_shear()

=item m2d_reflect()

=item m2d_scale()

=back

=cut

sub m2d_identity {
  return __PACKAGE__->identity;
}

sub m2d_rotate {
  return __PACKAGE__->rotate(@_);
}

sub m2d_translate {
  return __PACKAGE__->translate(@_);
}

sub m2d_shear {
  return __PACKAGE__->shear(@_);
}

sub m2d_reflect {
  return __PACKAGE__->reflect(@_);
}

sub m2d_scale {
  return __PACKAGE__->scale(@_);
}

1;

=head1 AUTHOR

Tony Cook <tony@develop-help.com>

=head1 BUGS

Needs a way to invert a matrix.

=head1 SEE ALSO

Imager(3), Imager::Font(3)

http://imager.perl.org/

=cut