lib/Imager/Matrix2d.pm

   1 package Imager::Matrix2d;
   2 use strict;
   3 use vars qw($VERSION);
   4 use Scalar::Util qw(reftype looks_like_number);
   5 use Carp qw(croak);
   6
   7 $VERSION = "1.010";
   8
   9 =head1 NAME
  10
  11   Imager::Matrix2d - simple wrapper for matrix construction
  12
  13 =head1 SYNOPSIS
  14
  15   use Imager::Matrix2d;
  16   $m1 = Imager::Matrix2d->identity;
  17   $m2 = Imager::Matrix2d->rotate(radians=>$angle, x=>$cx, y=>$cy);
  18   $m3 = Imager::Matrix2d->translate(x=>$dx, y=>$dy);
  19   $m4 = Imager::Matrix2d->shear(x=>$sx, y=>$sy);
  20   $m5 = Imager::Matrix2d->reflect(axis=>$axis);
  21   $m6 = Imager::Matrix2d->scale(x=>$xratio, y=>$yratio);
  22   $m8 = Imager::Matric2d->matrix($v11, $v12, $v13,
  23                                  $v21, $v22, $v23,
  24                                  $v31, $v32, $v33);
  25   $m6 = $m1 * $m2;
  26   $m7 = $m1 + $m2;
  27   use Imager::Matrix2d qw(:handy);
  28   # various m2d_* functions imported
  29   # where m2d_(.*) calls Imager::Matrix2d->$1()
  30
  31 =head1 DESCRIPTION
  32
  33 This class provides a simple wrapper around a reference to an array of
  34 9 co-efficients, treated as a matrix:
  35
  36  [ 0, 1, 2,
  37    3, 4, 5,
  38    6, 7, 8 ]
  39
  40 Most of the methods in this class are constructors.  The others are
  41 overloaded operators.
  42
  43 Note that since Imager represents images with y increasing from top to
  44 bottom, rotation angles are clockwise, rather than counter-clockwise.
  45
  46 =over
  47
  48 =cut
  49
  50 use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA);
  51 @ISA = 'Exporter';
  52 require 'Exporter.pm';
  53 @EXPORT_OK = qw(m2d_rotate m2d_identity m2d_translate m2d_shear
  54                 m2d_reflect m2d_scale);
  55 %EXPORT_TAGS =
  56   (
  57    handy=> [ qw(m2d_rotate m2d_identity m2d_translate m2d_shear
  58                 m2d_reflect m2d_scale) ],
  59   );
  60
  61 use overload
  62   '*' => \&_mult,
  63   '+' => \&_add,
  64   '""'=>\&_string,
  65   "eq" => \&_eq;
  66
  67 =item identity()
  68
  69 Returns the identity matrix.
  70
  71 =cut
  72
  73 sub identity {
  74   return bless [ 1, 0, 0,
  75                  0, 1, 0,
  76                  0, 0, 1 ], $_[0];
  77 }
  78
  79 =item rotate(radians=>$angle)
  80
  81 =item rotate(degrees=>$angle)
  82
  83 Creates a matrix that rotates around the origin, or around the point
  84 (x,y) if the 'x' and 'y' parameters are provided.
  85
  86 =cut
  87
  88 sub rotate {
  89   my ($class, %opts) = @_;
  90   my $angle;
  91
  92   if (defined $opts{radians}) {
  93     $angle = $opts{radians};
  94   }
  95   elsif (defined $opts{degrees}) {
  96     $angle = $opts{degrees} * 3.1415926535 / 180;
  97   }
  98   else {
  99     $Imager::ERRSTR = "degrees or radians parameter required";
 100     return undef;
 101   }
 102
 103   if ($opts{'x'} || $opts{'y'}) {
 104     $opts{'x'} ||= 0;
 105     $opts{'y'} ||= 0;
 106     return $class->translate('x'=>-$opts{'x'}, 'y'=>-$opts{'y'})
 107       * $class->rotate(radians=>$angle)
 108         * $class->translate('x'=>$opts{'x'}, 'y'=>$opts{'y'});
 109   }
 110   else {
 111     my $sin = sin($angle);
 112     my $cos = cos($angle);
 113     return bless [ $cos, -$sin, 0,
 114                    $sin,  $cos, 0,
 115                    0,     0,    1 ], $class;
 116   }
 117 }
 118
 119 =item translate(x=>$dx, y=>$dy)
 120
 121 =item translate(x=>$dx)
 122
 123 =item translate(y=>$dy)
 124
 125 Translates by the specify amounts.
 126
 127 =cut
 128
 129 sub translate {
 130   my ($class, %opts) = @_;
 131
 132   if (defined $opts{'x'} || defined $opts{'y'}) {
 133     my $x = $opts{'x'} || 0;
 134     my $y = $opts{'y'} || 0;
 135     return bless [ 1, 0, $x,
 136                    0, 1, $y,
 137                    0, 0, 1 ], $class;
 138   }
 139
 140   $Imager::ERRSTR = 'x or y parameter required';
 141   return undef;
 142 }
 143
 144 =item shear(x=>$sx, y=>$sy)
 145
 146 =item shear(x=>$sx)
 147
 148 =item shear(y=>$sy)
 149
 150 Shear by the given amounts.
 151
 152 =cut
 153 sub shear {
 154   my ($class, %opts) = @_;
 155
 156   if (defined $opts{'x'} || defined $opts{'y'}) {
 157     return bless [ 1,             $opts{'x'}||0, 0,
 158                    $opts{'y'}||0, 1,             0,
 159                    0,             0,             1 ], $class;
 160   }
 161   $Imager::ERRSTR = 'x and y parameters required';
 162   return undef;
 163 }
 164
 165 =item reflect(axis=>$axis)
 166
 167 Reflect around the given axis, either 'x' or 'y'.
 168
 169 =item reflect(radians=>$angle)
 170
 171 =item reflect(degrees=>$angle)
 172
 173 Reflect around a line drawn at the given angle from the origin.
 174
 175 =cut
 176
 177 sub reflect {
 178   my ($class, %opts) = @_;
 179
 180   if (defined $opts{axis}) {
 181     my $result = $class->identity;
 182     if ($opts{axis} eq "y") {
 183       $result->[0] = -$result->[0];
 184     }
 185     elsif ($opts{axis} eq "x") {
 186       $result->[4] = -$result->[4];
 187     }
 188     else {
 189       $Imager::ERRSTR = 'axis must be x or y';
 190       return undef;
 191     }
 192
 193     return $result;
 194   }
 195   my $angle;
 196   if (defined $opts{radians}) {
 197     $angle = $opts{radians};
 198   }
 199   elsif (defined $opts{degrees}) {
 200     $angle = $opts{degrees} * 3.1415926535 / 180;
 201   }
 202   else {
 203     $Imager::ERRSTR = 'axis, degrees or radians parameter required';
 204     return undef;
 205   }
 206
 207   # fun with matrices
 208   return $class->rotate(radians=>-$angle) * $class->reflect(axis=>'x')
 209     * $class->rotate(radians=>$angle);
 210 }
 211
 212 =item scale(x=>$xratio, y=>$yratio)
 213
 214 Scales at the given ratios.
 215
 216 You can also specify a center for the scaling with the C<cx> and C<cy>
 217 parameters.
 218
 219 =cut
 220
 221 sub scale {
 222   my ($class, %opts) = @_;
 223
 224   if (defined $opts{'x'} || defined $opts{'y'}) {
 225     $opts{'x'} = 1 unless defined $opts{'x'};
 226     $opts{'y'} = 1 unless defined $opts{'y'};
 227     if ($opts{cx} || $opts{cy}) {
 228       return $class->translate('x'=>-$opts{cx}, 'y'=>-$opts{cy})
 229         * $class->scale('x'=>$opts{'x'}, 'y'=>$opts{'y'})
 230           * $class->translate('x'=>$opts{cx}, 'y'=>$opts{cy});
 231     }
 232     else {
 233       return bless [ $opts{'x'}, 0,          0,
 234                      0,          $opts{'y'}, 0,
 235                      0,          0,          1 ], $class;
 236     }
 237   }
 238   else {
 239     $Imager::ERRSTR = 'x or y parameter required';
 240     return undef;
 241   }
 242 }
 243
 244 =item matrix($v11, $v12, $v13, $v21, $v22, $v23, $v31, $v32, $v33)
 245
 246 Create a matrix with custom co-efficients.
 247
 248 =cut
 249
 250 sub matrix {
 251   my ($class, @self) = @_;
 252
 253   if (@self == 9) {
 254     return bless \@self, $class;
 255   }
 256   else {
 257     $Imager::ERRSTR = "9 co-efficients required";
 258     return;
 259   }
 260 }
 261
 262 =item _mult()
 263
 264 Implements the overloaded '*' operator.  Internal use.
 265
 266 Currently both the left and right-hand sides of the operator must be
 267 an Imager::Matrix2d.
 268
 269 =cut
 270
 271 sub _mult {
 272   my ($left, $right, $order) = @_;
 273
 274   if (ref($right)) {
 275     if (reftype($right) eq "ARRAY") {
 276       @$right == 9
 277         or croak "9 elements required in array ref";
 278       if ($order) {
 279         ($left, $right) = ($right, $left);
 280       }
 281       my @result;
 282       for my $i (0..2) {
 283         for my $j (0..2) {
 284           my $accum = 0;
 285           for my $k (0..2) {
 286             $accum += $left->[3*$i + $k] * $right->[3*$k + $j];
 287           }
 288           $result[3*$i+$j] = $accum;
 289         }
 290       }
 291       return bless \@result, __PACKAGE__;
 292     }
 293     else {
 294       croak "multiply by array ref or number";
 295     }
 296   }
 297   elsif (defined $right && looks_like_number($right)) {
 298     my @result = map $_ * $right, @$left;
 299
 300     return bless \@result, __PACKAGE__;
 301   }
 302   else {
 303     # something we don't handle
 304     croak "multiply by array ref or number";
 305   }
 306 }
 307
 308 =item _add()
 309
 310 Implements the overloaded binary '+' operator.
 311
 312 Currently both the left and right sides of the operator must be
 313 Imager::Matrix2d objects.
 314
 315 =cut
 316 sub _add {
 317   my ($left, $right, $order) = @_;
 318
 319   if (ref($right) && UNIVERSAL::isa($right, __PACKAGE__)) {
 320     my @result;
 321     for (0..8) {
 322       push @result, $left->[$_] + $right->[$_];
 323     }
 324
 325     return bless \@result, __PACKAGE__;
 326   }
 327   else {
 328     return undef;
 329   }
 330 }
 331
 332 =item _string()
 333
 334 Implements the overloaded stringification operator.
 335
 336 This returns a string containing 3 lines of text with no terminating
 337 newline.
 338
 339 I tried to make it fairly nicely formatted.  You might disagree :)
 340
 341 =cut
 342
 343 sub _string {
 344   my ($m) = @_;
 345
 346   my $maxlen = 0;
 347   for (@$m[0..8]) {
 348     if (length() > $maxlen) {
 349       $maxlen = length;
 350     }
 351   }
 352   $maxlen <= 9 or $maxlen = 9;
 353
 354   my @left = ('[ ', '  ', '  ');
 355   my @right = ("\n", "\n", ']');
 356   my $out;
 357   my $width = $maxlen+2;
 358   for my $i (0..2) {
 359     $out .= $left[$i];
 360     for my $j (0..2) {
 361       my $val = $m->[$i*3+$j];
 362       if (length $val > 9) {
 363         $val = sprintf("%9f", $val);
 364         if ($val =~ /\./ && $val !~ /e/i) {
 365           $val =~ s/0+$//;
 366           $val =~ s/\.$//;
 367         }
 368         $val =~ s/^\s//;
 369       }
 370       $out .= sprintf("%-${width}s", "$val, ");
 371     }
 372     $out =~ s/ +\Z/ /;
 373     $out .= $right[$i];
 374   }
 375   $out;
 376 }
 377
 378 =item _eq
 379
 380 Implement the overloaded equality operator.
 381
 382 Provided for older perls that don't handle magic auto generation of eq
 383 from "".
 384
 385 =cut
 386
 387 sub _eq {
 388   my ($left, $right) = @_;
 389
 390   return $left . "" eq $right . "";
 391 }
 392
 393 =back
 394
 395 The following functions are shortcuts to the various constructors.
 396
 397 These are not methods.
 398
 399 You can import these methods with:
 400
 401   use Imager::Matrix2d ':handy';
 402
 403 =over
 404
 405 =item m2d_identity
 406
 407 =item m2d_rotate()
 408
 409 =item m2d_translate()
 410
 411 =item m2d_shear()
 412
 413 =item m2d_reflect()
 414
 415 =item m2d_scale()
 416
 417 =back
 418
 419 =cut
 420
 421 sub m2d_identity {
 422   return __PACKAGE__->identity;
 423 }
 424
 425 sub m2d_rotate {
 426   return __PACKAGE__->rotate(@_);
 427 }
 428
 429 sub m2d_translate {
 430   return __PACKAGE__->translate(@_);
 431 }
 432
 433 sub m2d_shear {
 434   return __PACKAGE__->shear(@_);
 435 }
 436
 437 sub m2d_reflect {
 438   return __PACKAGE__->reflect(@_);
 439 }
 440
 441 sub m2d_scale {
 442   return __PACKAGE__->scale(@_);
 443 }
 444
 445 1;
 446
 447 =head1 AUTHOR
 448
 449 Tony Cook <tony@develop-help.com>
 450
 451 =head1 BUGS
 452
 453 Needs a way to invert a matrix.
 454
 455 =head1 SEE ALSO
 456
 457 Imager(3), Imager::Font(3)
 458
 459 http://imager.perl.org/
 460
 461 =cut