Tk::RotCanvas - Canvas widget with arbitrary rotation support

    $canvas = $parent->RotCanvas(?options?);
    my $obj = $canvas->create('polygon', @coords, %options);
    $canvas->rotate($obj, $angle, ?x, y?);

package Tk::RotCanvas;

use vars qw/$VERSION/;
$VERSION = 1.2;

use Tk::widgets qw/Canvas/;
use base qw/Tk::Derived Tk::Canvas/;

use strict;
use Carp;

Construct Tk::Widget 'RotCanvas';

sub ClassInit {
    my $class = shift;

    $class->SUPER::ClassInit(@_);
}

sub Populate {
    my ($self, $args) = @_;

    $self->SUPER::Populate($args);
}

my %_cant_handle = (
		    bitmap => 1,
		    image  => 1,
		    arc    => 1,
		    text   => 1,
		    window => 1,
		   );

my %_rotate_methods = (
		       line      => \&_rotate_line,
		       polygon   => \&_rotate_poly,
		       oval      => \&_rotate_poly,
		      );

use constant PI => 3.14159269;

# This is the new rotate() method. It takes as input the
# id of the object to rotate, and the angle to rotate it with.
# It then rotates the object about its center by the given angle

sub rotate {
    my ($self, $id, $angle, $x, $y) = @_;

    unless (defined $angle) {
	croak "rotate: Must supply an angle -";
    }

    # Get the current coordinates of the object.
    my $type = $self->type($id);

    # For now, I don't know how to handle some of these!
    if (exists $_cant_handle{$type}) {
	croak "rotate: Can't handle objects of type '$type' yet -";
    }

    $_rotate_methods{$type}->($self, $id, $angle, $x, $y);
}

sub _rotate_line {
    my ($self, $id, $angle, $midx, $midy) = @_;

    # Get the old coordinates.
    my @coords = $self->coords($id);

    # If the center of rotation is not given, get the default.
    # Get the center of the line. We use this to translate the
    # above coords back to the origin, and then rotate about
    # the origin, then translate back.

    unless (defined $midx) {
	$midx = $coords[0] + 0.5*($coords[2] - $coords[0]);
	$midy = $coords[1] + 0.5*($coords[3] - $coords[1]);
    }

    my @new;

    # Precalculate the sin/cos of the angle, since we'll call
    # them a few times.
    my $rad = PI*$angle/180;
    my $sin = sin $rad;
    my $cos = cos $rad;

    # Calculate the new coordinates of the line.
    while (my ($x, $y) = splice @coords, 0, 2) {
	my $x1 = $x - $midx;
	my $y1 = $y - $midy;

	push @new => $midx + ($x1 * $cos - $y1 * $sin);
	push @new => $midy + ($x1 * $sin + $y1 * $cos);
    }

    # Redraw the line.
    $self->coords($id, @new);
}

sub _rotate_poly {
    my ($self, $id, $angle, $midx, $midy) = @_;

    # Get the old coordinates.
    my @coords = $self->coords($id);

    # Get the center of the poly. We use this to translate the
    # above coords back to the origin, and then rotate about
    # the origin, then translate back. (old)

    ($midx, $midy) = _get_CM(@coords) unless defined $midx;

    my @new;

    # Precalculate the sin/cos of the angle, since we'll call
    # them a few times.
    my $rad = PI*$angle/180;
    my $sin = sin $rad;
    my $cos = cos $rad;

    # Calculate the new coordinates of the line.
    while (my ($x, $y) = splice @coords, 0, 2) {
	my $x1 = $x - $midx;
	my $y1 = $y - $midy;

	push @new => $midx + ($x1 * $cos - $y1 * $sin);
	push @new => $midy + ($x1 * $sin + $y1 * $cos);
    }

    # Redraw the poly.
    $self->coords($id, @new);
}

# We have to intercept any calls to createRectangle and
# create('rectangle') and call createPolygon instead.

sub createRectangle {
    my $self = shift;

    $self->_rect_to_poly(@_);
}

sub create {
    my $self = shift;

    my $type = shift;

    if ($type eq 'rectangle') {
	$self->_rect_to_poly(@_);
    } elsif ($type eq 'oval') {
	$self->_oval_to_poly(@_);
    } else {
	$self->SUPER::create($type, @_);
    }
}

sub createOval {
    my $self = shift;
    $self->_oval_to_poly(@_);
}

# This sub transforms the rectangle coords to poly coords.
sub _rect_to_poly {
    my $self = shift;

    my ($x1, $y1, $x2, $y2) = splice @_ => 0, 4;

    $self->createPolygon(
			 $x1, $y1,
			 $x2, $y1,
			 $x2, $y2,
			 $x1, $y2,
			 @_,
			);
}

sub _oval_to_poly {
    my $self = shift;

    my ($x1, $y1, $x2, $y2) = splice @_ => 0, 4;

    my $steps = 100;
    my $xc = ($x2 - $x1) / 2;
    my $yc = ($y2 - $y1) / 2;
    my @pointlist;

    for my $i (0..$steps) {
	my $theta = (PI * 2)* ($i / $steps);
	my $x = $xc * cos($theta) - $xc + $x2;
	my $y = $yc * sin($theta) + $yc + $y1;
	push(@pointlist, $x, $y);
    }

    push(@_, '-fill', undef)      unless grep {/-fill/   } @_;
    push(@_, '-outline', 'black') unless grep {/-outline/} @_;

    $self->createPolygon(@pointlist, @_);
}

# This sub finds the center of mass of a polygon.
# I grabbed the algorithm somewhere from the web.
sub _get_CM {
    my ($x, $y, $area);

    my $i = 0;

    while ($i < $#_) {
	my $x0 = $_[$i];
	my $y0 = $_[$i+1];

	my ($x1, $y1);
	if ($i+2 > $#_) {
	    $x1 = $_[0];
	    $y1 = $_[1];
	} else {
	    $x1 = $_[$i+2];
	    $y1 = $_[$i+3];
	}

	$i += 2;

	my $a1 = 0.5*($x0 + $x1);
	my $a2 = ($x0**2 + $x0*$x1 + $x1**2)/6;
	my $a3 = ($x0*$y1 + $y0*$x1 + 2*($x1*$y1 + $x0*$y0))/6;
	my $b0 = $y1 - $y0;

	$area += $a1 * $b0;
	$x    += $a2 * $b0;
	$y    += $a3 * $b0;
    }

    return split ' ', sprintf "%.0f %0.f" => $x/$area, $y/$area;
}

1;

__END__