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.012";
   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 coefficients, 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 coefficients.
 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 coefficients required";
 258     return;
 259   }
 260 }
 261
 262 =item transform($x, $y)
 263
 264 Transform a point the same way matrix_transform does.
 265
 266 =cut
 267
 268 sub transform {
 269   my ($self, $x, $y) = @_;
 270
 271   my $sz = $x * $self->[6] + $y * $self->[7] + $self->[8];
 272   my ($sx, $sy);
 273   if (abs($sz) > 0.000001) {
 274     $sx = ($x * $self->[0] + $y * $self->[1] + $self->[2]) / $sz;
 275     $sy = ($x * $self->[3] + $y * $self->[4] + $self->[5]) / $sz;
 276   }
 277   else {
 278     $sx = $sy = 0;
 279   }
 280
 281   return ($sx, $sy);
 282 }
 283
 284 =item compose(matrix...)
 285
 286 Compose several matrices together for use in transformation.
 287
 288 For example, for three matrices:
 289
 290   my $out = Imager::Matrix2d->compose($m1, $m2, $m3);
 291
 292 is equivalent to:
 293
 294   my $out = $m3 * $m2 * $m1;
 295
 296 Returns the identity matrix if no parameters are supplied.
 297
 298 May return the supplied matrix if only one matrix is supplied.
 299
 300 =cut
 301
 302 sub compose {
 303   my ($class, @in) = @_;
 304
 305   @in
 306     or return $class->identity;
 307
 308   my $out = pop @in;
 309   for my $m (reverse @in) {
 310     $out = $out * $m;
 311   }
 312
 313   return $out;
 314 }
 315
 316 =item _mult()
 317
 318 Implements the overloaded '*' operator.  Internal use.
 319
 320 Currently both the left and right-hand sides of the operator must be
 321 an Imager::Matrix2d.
 322
 323 When composing a matrix for transformation you should multiply the
 324 matrices in the reverse order of the transformations:
 325
 326   my $shear = Imager::Matrix2d->shear(x => 0.1);
 327   my $rotate = Imager::Matrix2d->rotate(degrees => 45);
 328   my $shear_then_rotate = $rotate * $shear;
 329
 330 or use the compose method:
 331
 332   my $shear_then_rotate = Imager::Matrix2d->compose($shear, $rotate);
 333
 334 =cut
 335
 336 sub _mult {
 337   my ($left, $right, $order) = @_;
 338
 339   if (ref($right)) {
 340     if (reftype($right) eq "ARRAY") {
 341       @$right == 9
 342         or croak "9 elements required in array ref";
 343       if ($order) {
 344         ($left, $right) = ($right, $left);
 345       }
 346       my @result;
 347       for my $i (0..2) {
 348         for my $j (0..2) {
 349           my $accum = 0;
 350           for my $k (0..2) {
 351             $accum += $left->[3*$i + $k] * $right->[3*$k + $j];
 352           }
 353           $result[3*$i+$j] = $accum;
 354         }
 355       }
 356       return bless \@result, __PACKAGE__;
 357     }
 358     else {
 359       croak "multiply by array ref or number";
 360     }
 361   }
 362   elsif (defined $right && looks_like_number($right)) {
 363     my @result = map $_ * $right, @$left;
 364
 365     return bless \@result, __PACKAGE__;
 366   }
 367   else {
 368     # something we don't handle
 369     croak "multiply by array ref or number";
 370   }
 371 }
 372
 373 =item _add()
 374
 375 Implements the overloaded binary '+' operator.
 376
 377 Currently both the left and right sides of the operator must be
 378 Imager::Matrix2d objects.
 379
 380 =cut
 381 sub _add {
 382   my ($left, $right, $order) = @_;
 383
 384   if (ref($right) && UNIVERSAL::isa($right, __PACKAGE__)) {
 385     my @result;
 386     for (0..8) {
 387       push @result, $left->[$_] + $right->[$_];
 388     }
 389
 390     return bless \@result, __PACKAGE__;
 391   }
 392   else {
 393     return undef;
 394   }
 395 }
 396
 397 =item _string()
 398
 399 Implements the overloaded stringification operator.
 400
 401 This returns a string containing 3 lines of text with no terminating
 402 newline.
 403
 404 I tried to make it fairly nicely formatted.  You might disagree :)
 405
 406 =cut
 407
 408 sub _string {
 409   my ($m) = @_;
 410
 411   my $maxlen = 0;
 412   for (@$m[0..8]) {
 413     if (length() > $maxlen) {
 414       $maxlen = length;
 415     }
 416   }
 417   $maxlen <= 9 or $maxlen = 9;
 418
 419   my @left = ('[ ', '  ', '  ');
 420   my @right = ("\n", "\n", ']');
 421   my $out;
 422   my $width = $maxlen+2;
 423   for my $i (0..2) {
 424     $out .= $left[$i];
 425     for my $j (0..2) {
 426       my $val = $m->[$i*3+$j];
 427       if (length $val > 9) {
 428         $val = sprintf("%9f", $val);
 429         if ($val =~ /\./ && $val !~ /e/i) {
 430           $val =~ s/0+$//;
 431           $val =~ s/\.$//;
 432         }
 433         $val =~ s/^\s//;
 434       }
 435       $out .= sprintf("%-${width}s", "$val, ");
 436     }
 437     $out =~ s/ +\Z/ /;
 438     $out .= $right[$i];
 439   }
 440   $out;
 441 }
 442
 443 =item _eq
 444
 445 Implement the overloaded equality operator.
 446
 447 Provided for older perls that don't handle magic auto generation of eq
 448 from "".
 449
 450 =cut
 451
 452 sub _eq {
 453   my ($left, $right) = @_;
 454
 455   return $left . "" eq $right . "";
 456 }
 457
 458 =back
 459
 460 The following functions are shortcuts to the various constructors.
 461
 462 These are not methods.
 463
 464 You can import these methods with:
 465
 466   use Imager::Matrix2d ':handy';
 467
 468 =over
 469
 470 =item m2d_identity
 471
 472 =item m2d_rotate()
 473
 474 =item m2d_translate()
 475
 476 =item m2d_shear()
 477
 478 =item m2d_reflect()
 479
 480 =item m2d_scale()
 481
 482 =back
 483
 484 =cut
 485
 486 sub m2d_identity {
 487   return __PACKAGE__->identity;
 488 }
 489
 490 sub m2d_rotate {
 491   return __PACKAGE__->rotate(@_);
 492 }
 493
 494 sub m2d_translate {
 495   return __PACKAGE__->translate(@_);
 496 }
 497
 498 sub m2d_shear {
 499   return __PACKAGE__->shear(@_);
 500 }
 501
 502 sub m2d_reflect {
 503   return __PACKAGE__->reflect(@_);
 504 }
 505
 506 sub m2d_scale {
 507   return __PACKAGE__->scale(@_);
 508 }
 509
 510 1;
 511
 512 =head1 AUTHOR
 513
 514 Tony Cook <tony@develop-help.com>
 515
 516 =head1 BUGS
 517
 518 Needs a way to invert a matrix.
 519
 520 =head1 SEE ALSO
 521
 522 Imager(3), Imager::Font(3)
 523
 524 http://imager.perl.org/
 525
 526 =cut