File Coverage

blib/lib/Imager/Graph/Util.pm

Criterion	Covered	Total	%
statement	58	58	100.0
branch	5	8	62.5
condition	4	9	44.4
subroutine	7	7	100.0
pod	3	3	100.0
total	77	85	90.5

=head1 NAME

  Imager::Graph::Util - simple geometric functions

=head1 SYNOPSIS

  my @abc = line_from_points($x1, $y1, $x2, $y2);
  my @p = intersect_lines(@abc1, @abc2);
  my @points = intersect_line_and_circle(@abc1, $cx, $cy, $radius);

=head1 DESCRIPTION

Provides some simple geometric functions intended for use in drawing
graphs.

=over

=item line_from_points($x1, $y1, $x2, $y2)

Returns the coefficients of a line in the Ax + By + C = 0 form.

Returns the list (A, B, C), or an empty list if they are the same
point.

=item intersect_lines(@abc1, @abc2)

Returns the point of intersection of the 2 lines, each given in
Ax+By+C=0 form.  Returns either the point (x, y) or an empty list.

=item intersect_line_and_circle(@abc, $cx, $cy, $radius)

Returns the points or point of intersection of the given line and
circle.

=back

=head1 INTERNALS

=over

=cut

package Imager::Graph::Util;
use strict;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
require Exporter;
@EXPORT = qw(intersect_lines intersect_line_and_circle
              line_from_points);
use Carp;
use constant DEBUG => 0;

sub line_from_points {
  my ($x1, $y1, $x2, $y2) = @_;

  my $A = $y1 - $y2;
  my $B = $x2 - $x1;
  my $C = $x1 * $y2 - $y1 * $x2;

  return () if $A == 0 && $B == 0;

  return ($A, $B, $C);
}

sub intersect_lines {
  my ($a1, $b1, $c1, $a2, $b2, $c2) = @_;

  DEBUG and !defined($a1) and croak('$a1 undefined');
  DEBUG and !defined($b1) and croak('$b1 undefined');
  DEBUG and !defined($c1) and croak('$c1 undefined');
  DEBUG and !defined($a2) and croak('$a2 undefined');
  DEBUG and !defined($b2) and croak('$b2 undefined');
  DEBUG and !defined($c2) and croak('$c2 undefined');

  my $divisor = $a2 * $b1 - $a1 * $b2;
  return () if $divisor == 0;

  my $x = ($b2 * $c1 - $b1 * $c2) / $divisor;
  my $y = ($a1 * $c2 - $a2 * $c1) / $divisor;

  return ($x, $y);
}

=item intersect_line_and_circle()

The implementation is a little heavy on math.  Perhaps there was a
better way to implement it.

Starting with the equations of a line and that of a circle:

  (1)  Ax + By + C = 0
  (2)  (x - x1)**2 + (y - y1)**2 = R ** 2
  (3)  Ax = -By - C     # re-arrange (1)
  (4)  A**2 (x - x1)**2 + A**2 (y - y1)**2 = R**2 A**2 # (2) * A**2
  (5)  (Ax - Ax1)**2 + (Ay - Ay1)**2 = R**2 A**2 # move it inside
  (6) (-By - C - Ax1)**2 + (Ay - Ay1)**2 = R**2 A**2 # sub (3) into (5)

Expand and convert to standard quadratic form, and similary for x.

Be careful :)

=cut

sub intersect_line_and_circle {
  my ($a, $b, $c, $cx, $cy, $r) = @_;

  DEBUG and !defined($a)  and croak('$a undefined');
  DEBUG and !defined($b)  and croak('$b undefined');
  DEBUG and !defined($c)  and croak('$c undefined');
  DEBUG and !defined($cx) and croak('$cx undefined');
  DEBUG and !defined($cy) and croak('$cy undefined');
  DEBUG and !defined($r)  and croak('$r undefined');

  # I should probably optimize the following
  my $qya = $b * $b + $a * $a;
  my $qyb = 2 * $b * $c + 2 * $a * $b * $cx - 2 * $a * $a * $cy;
  my $qyc = $c * $c + 2 * $a * $c * $cx + $a * $a * $cy * $cy
    + $a * $a * $cx * $cx - $r * $r * $a * $a;

  my $qxa = $b * $b + $a * $a;
  my $qxb = 2 * $a * $c + 2 * $a * $b * $cy - 2 * $b * $b * $cx;
  my $qxc = $c * $c + 2 * $b * $c * $cy + $b * $b * $cx * $cx
    + $b * $b * $cy * $cy - $r * $r * $b * $b;

  my $dety = $qyb * $qyb - 4 * $qya * $qyc;
  my $detx = $qxb * $qxb - 4 * $qxa * $qxc;

  return () if $dety < 0 || $detx < 0;

  my $detyroot = sqrt($dety);
  my $detxroot = sqrt($detx);

  my $y1 = (- $qyb - $detyroot) / ( 2 * $qya);
  my $x1 = (- $qxb - $detxroot) / ( 2 * $qxa);

  DEBUG and abs($a * $x1 + $b * $y1 + $c) > 0.00001
    and print "(x1 $x1, y1 $y1) not on line\n";
  DEBUG and abs(($x1-$cx)*($x1-$cx)+($y1-$cy)*($y1-$cy) - $r*$r) > 0.0001
    and print "(x1 $x1, y1 $y1) not on circle\n";

  return ($x1, $y1) if $detxroot == 0 && $detyroot == 0;

  my $y2 = (- $qyb + $detyroot) / (2 * $qya);
  my $x2 = (- $qxb + $detxroot) / (2 * $qxa);

  DEBUG and abs($a * $x2 + $b * $y2 + $c) > 0.00001
    and print "(x2 $x2, y2 $y2) not on line\n";
  DEBUG and abs(($x2-$cx)*($x2-$cx)+($y2-$cy)*($y2-$cy) - $r*$r) > 0.0001
    and print "(x2 $x2, y2 $y2) not on circle\n";

  return ($x1, $y1, $x2, $y2);
}

__END__