lib/Imager/Matrix2d.pm

   1 package Imager::Matrix2d;
   2 use 5.006;
   3 use strict;
   4 use Scalar::Util qw(reftype looks_like_number);
   5 use Carp qw(croak);
   6
   7 our $VERSION = "1.013";
   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 our @ISA = 'Exporter';
  51 require Exporter;
  52 our @EXPORT_OK = qw(m2d_rotate m2d_identity m2d_translate m2d_shear
  53                 m2d_reflect m2d_scale);
  54 our %EXPORT_TAGS =
  55   (
  56    handy=> [ qw(m2d_rotate m2d_identity m2d_translate m2d_shear
  57                 m2d_reflect m2d_scale) ],
  58   );
  59
  60 use overload
  61   '*' => \&_mult,
  62   '+' => \&_add,
  63   '""'=>\&_string,
  64   "eq" => \&_eq;
  65
  66 =item identity()
  67
  68 Returns the identity matrix.
  69
  70 =cut
  71
  72 sub identity {
  73   return bless [ 1, 0, 0,
  74                  0, 1, 0,
  75                  0, 0, 1 ], $_[0];
  76 }
  77
  78 =item rotate(radians=>$angle)
  79
  80 =item rotate(degrees=>$angle)
  81
  82 Creates a matrix that rotates around the origin, or around the point
  83 (x,y) if the 'x' and 'y' parameters are provided.
  84
  85 =cut
  86
  87 sub rotate {
  88   my ($class, %opts) = @_;
  89   my $angle;
  90
  91   if (defined $opts{radians}) {
  92     $angle = $opts{radians};
  93   }
  94   elsif (defined $opts{degrees}) {
  95     $angle = $opts{degrees} * 3.1415926535 / 180;
  96   }
  97   else {
  98     $Imager::ERRSTR = "degrees or radians parameter required";
  99     return undef;
 100   }
 101
 102   if ($opts{'x'} || $opts{'y'}) {
 103     $opts{'x'} ||= 0;
 104     $opts{'y'} ||= 0;
 105     return $class->translate('x'=>$opts{'x'}, 'y'=>$opts{'y'})
 106       * $class->rotate(radians=>$angle)
 107         * $class->translate('x'=>-$opts{'x'}, 'y'=>-$opts{'y'});
 108   }
 109   else {
 110     my $sin = sin($angle);
 111     my $cos = cos($angle);
 112     return bless [ $cos, -$sin, 0,
 113                    $sin,  $cos, 0,
 114                    0,     0,    1 ], $class;
 115   }
 116 }
 117
 118 =item translate(x=>$dx, y=>$dy)
 119
 120 =item translate(x=>$dx)
 121
 122 =item translate(y=>$dy)
 123
 124 Translates by the specify amounts.
 125
 126 =cut
 127
 128 sub translate {
 129   my ($class, %opts) = @_;
 130
 131   if (defined $opts{'x'} || defined $opts{'y'}) {
 132     my $x = $opts{'x'} || 0;
 133     my $y = $opts{'y'} || 0;
 134     return bless [ 1, 0, $x,
 135                    0, 1, $y,
 136                    0, 0, 1 ], $class;
 137   }
 138
 139   $Imager::ERRSTR = 'x or y parameter required';
 140   return undef;
 141 }
 142
 143 =item shear(x=>$sx, y=>$sy)
 144
 145 =item shear(x=>$sx)
 146
 147 =item shear(y=>$sy)
 148
 149 Shear by the given amounts.
 150
 151 =cut
 152 sub shear {
 153   my ($class, %opts) = @_;
 154
 155   if (defined $opts{'x'} || defined $opts{'y'}) {
 156     return bless [ 1,             $opts{'x'}||0, 0,
 157                    $opts{'y'}||0, 1,             0,
 158                    0,             0,             1 ], $class;
 159   }
 160   $Imager::ERRSTR = 'x and y parameters required';
 161   return undef;
 162 }
 163
 164 =item reflect(axis=>$axis)
 165
 166 Reflect around the given axis, either 'x' or 'y'.
 167
 168 =item reflect(radians=>$angle)
 169
 170 =item reflect(degrees=>$angle)
 171
 172 Reflect around a line drawn at the given angle from the origin.
 173
 174 =cut
 175
 176 sub reflect {
 177   my ($class, %opts) = @_;
 178
 179   if (defined $opts{axis}) {
 180     my $result = $class->identity;
 181     if ($opts{axis} eq "y") {
 182       $result->[0] = -$result->[0];
 183     }
 184     elsif ($opts{axis} eq "x") {
 185       $result->[4] = -$result->[4];
 186     }
 187     else {
 188       $Imager::ERRSTR = 'axis must be x or y';
 189       return undef;
 190     }
 191
 192     return $result;
 193   }
 194   my $angle;
 195   if (defined $opts{radians}) {
 196     $angle = $opts{radians};
 197   }
 198   elsif (defined $opts{degrees}) {
 199     $angle = $opts{degrees} * 3.1415926535 / 180;
 200   }
 201   else {
 202     $Imager::ERRSTR = 'axis, degrees or radians parameter required';
 203     return undef;
 204   }
 205
 206   # fun with matrices
 207   return $class->rotate(radians=>-$angle) * $class->reflect(axis=>'x')
 208     * $class->rotate(radians=>$angle);
 209 }
 210
 211 =item scale(x=>$xratio, y=>$yratio)
 212
 213 Scales at the given ratios.
 214
 215 You can also specify a center for the scaling with the C<cx> and C<cy>
 216 parameters.
 217
 218 =cut
 219
 220 sub scale {
 221   my ($class, %opts) = @_;
 222
 223   if (defined $opts{'x'} || defined $opts{'y'}) {
 224     $opts{'x'} = 1 unless defined $opts{'x'};
 225     $opts{'y'} = 1 unless defined $opts{'y'};
 226     if ($opts{cx} || $opts{cy}) {
 227       return $class->translate('x'=>-$opts{cx}, 'y'=>-$opts{cy})
 228         * $class->scale('x'=>$opts{'x'}, 'y'=>$opts{'y'})
 229           * $class->translate('x'=>$opts{cx}, 'y'=>$opts{cy});
 230     }
 231     else {
 232       return bless [ $opts{'x'}, 0,          0,
 233                      0,          $opts{'y'}, 0,
 234                      0,          0,          1 ], $class;
 235     }
 236   }
 237   else {
 238     $Imager::ERRSTR = 'x or y parameter required';
 239     return undef;
 240   }
 241 }
 242
 243 =item matrix($v11, $v12, $v13, $v21, $v22, $v23, $v31, $v32, $v33)
 244
 245 Create a matrix with custom coefficients.
 246
 247 =cut
 248
 249 sub matrix {
 250   my ($class, @self) = @_;
 251
 252   if (@self == 9) {
 253     return bless \@self, $class;
 254   }
 255   else {
 256     $Imager::ERRSTR = "9 coefficients required";
 257     return;
 258   }
 259 }
 260
 261 =item transform($x, $y)
 262
 263 Transform a point the same way matrix_transform does.
 264
 265 =cut
 266
 267 sub transform {
 268   my ($self, $x, $y) = @_;
 269
 270   my $sz = $x * $self->[6] + $y * $self->[7] + $self->[8];
 271   my ($sx, $sy);
 272   if (abs($sz) > 0.000001) {
 273     $sx = ($x * $self->[0] + $y * $self->[1] + $self->[2]) / $sz;
 274     $sy = ($x * $self->[3] + $y * $self->[4] + $self->[5]) / $sz;
 275   }
 276   else {
 277     $sx = $sy = 0;
 278   }
 279
 280   return ($sx, $sy);
 281 }
 282
 283 =item compose(matrix...)
 284
 285 Compose several matrices together for use in transformation.
 286
 287 For example, for three matrices:
 288
 289   my $out = Imager::Matrix2d->compose($m1, $m2, $m3);
 290
 291 is equivalent to:
 292
 293   my $out = $m3 * $m2 * $m1;
 294
 295 Returns the identity matrix if no parameters are supplied.
 296
 297 May return the supplied matrix if only one matrix is supplied.
 298
 299 =cut
 300
 301 sub compose {
 302   my ($class, @in) = @_;
 303
 304   @in
 305     or return $class->identity;
 306
 307   my $out = pop @in;
 308   for my $m (reverse @in) {
 309     $out = $out * $m;
 310   }
 311
 312   return $out;
 313 }
 314
 315 =item _mult()
 316
 317 Implements the overloaded '*' operator.  Internal use.
 318
 319 Currently both the left and right-hand sides of the operator must be
 320 an Imager::Matrix2d.
 321
 322 When composing a matrix for transformation you should multiply the
 323 matrices in the reverse order of the transformations:
 324
 325   my $shear = Imager::Matrix2d->shear(x => 0.1);
 326   my $rotate = Imager::Matrix2d->rotate(degrees => 45);
 327   my $shear_then_rotate = $rotate * $shear;
 328
 329 or use the compose method:
 330
 331   my $shear_then_rotate = Imager::Matrix2d->compose($shear, $rotate);
 332
 333 =cut
 334
 335 sub _mult {
 336   my ($left, $right, $order) = @_;
 337
 338   if (ref($right)) {
 339     if (reftype($right) eq "ARRAY") {
 340       @$right == 9
 341         or croak "9 elements required in array ref";
 342       if ($order) {
 343         ($left, $right) = ($right, $left);
 344       }
 345       my @result;
 346       for my $i (0..2) {
 347         for my $j (0..2) {
 348           my $accum = 0;
 349           for my $k (0..2) {
 350             $accum += $left->[3*$i + $k] * $right->[3*$k + $j];
 351           }
 352           $result[3*$i+$j] = $accum;
 353         }
 354       }
 355       return bless \@result, __PACKAGE__;
 356     }
 357     else {
 358       croak "multiply by array ref or number";
 359     }
 360   }
 361   elsif (defined $right && looks_like_number($right)) {
 362     my @result = map $_ * $right, @$left;
 363
 364     return bless \@result, __PACKAGE__;
 365   }
 366   else {
 367     # something we don't handle
 368     croak "multiply by array ref or number";
 369   }
 370 }
 371
 372 =item _add()
 373
 374 Implements the overloaded binary '+' operator.
 375
 376 Currently both the left and right sides of the operator must be
 377 Imager::Matrix2d objects.
 378
 379 =cut
 380 sub _add {
 381   my ($left, $right, $order) = @_;
 382
 383   if (ref($right) && UNIVERSAL::isa($right, __PACKAGE__)) {
 384     my @result;
 385     for (0..8) {
 386       push @result, $left->[$_] + $right->[$_];
 387     }
 388
 389     return bless \@result, __PACKAGE__;
 390   }
 391   else {
 392     return undef;
 393   }
 394 }
 395
 396 =item _string()
 397
 398 Implements the overloaded stringification operator.
 399
 400 This returns a string containing 3 lines of text with no terminating
 401 newline.
 402
 403 I tried to make it fairly nicely formatted.  You might disagree :)
 404
 405 =cut
 406
 407 sub _string {
 408   my ($m) = @_;
 409
 410   my $maxlen = 0;
 411   for (@$m[0..8]) {
 412     if (length() > $maxlen) {
 413       $maxlen = length;
 414     }
 415   }
 416   $maxlen <= 9 or $maxlen = 9;
 417
 418   my @left = ('[ ', '  ', '  ');
 419   my @right = ("\n", "\n", ']');
 420   my $out;
 421   my $width = $maxlen+2;
 422   for my $i (0..2) {
 423     $out .= $left[$i];
 424     for my $j (0..2) {
 425       my $val = $m->[$i*3+$j];
 426       if (length $val > 9) {
 427         $val = sprintf("%9f", $val);
 428         if ($val =~ /\./ && $val !~ /e/i) {
 429           $val =~ s/0+$//;
 430           $val =~ s/\.$//;
 431         }
 432         $val =~ s/^\s//;
 433       }
 434       $out .= sprintf("%-${width}s", "$val, ");
 435     }
 436     $out =~ s/ +\Z/ /;
 437     $out .= $right[$i];
 438   }
 439   $out;
 440 }
 441
 442 =item _eq
 443
 444 Implement the overloaded equality operator.
 445
 446 Provided for older perls that don't handle magic auto generation of eq
 447 from "".
 448
 449 =cut
 450
 451 sub _eq {
 452   my ($left, $right) = @_;
 453
 454   return $left . "" eq $right . "";
 455 }
 456
 457 =back
 458
 459 The following functions are shortcuts to the various constructors.
 460
 461 These are not methods.
 462
 463 You can import these methods with:
 464
 465   use Imager::Matrix2d ':handy';
 466
 467 =over
 468
 469 =item m2d_identity
 470
 471 =item m2d_rotate()
 472
 473 =item m2d_translate()
 474
 475 =item m2d_shear()
 476
 477 =item m2d_reflect()
 478
 479 =item m2d_scale()
 480
 481 =back
 482
 483 =cut
 484
 485 sub m2d_identity {
 486   return __PACKAGE__->identity;
 487 }
 488
 489 sub m2d_rotate {
 490   return __PACKAGE__->rotate(@_);
 491 }
 492
 493 sub m2d_translate {
 494   return __PACKAGE__->translate(@_);
 495 }
 496
 497 sub m2d_shear {
 498   return __PACKAGE__->shear(@_);
 499 }
 500
 501 sub m2d_reflect {
 502   return __PACKAGE__->reflect(@_);
 503 }
 504
 505 sub m2d_scale {
 506   return __PACKAGE__->scale(@_);
 507 }
 508
 509 1;
 510
 511 =head1 AUTHOR
 512
 513 Tony Cook <tony@develop-help.com>
 514
 515 =head1 BUGS
 516
 517 Needs a way to invert a matrix.
 518
 519 =head1 SEE ALSO
 520
 521 Imager(3), Imager::Font(3)
 522
 523 http://imager.perl.org/
 524
 525 =cut