Math::Project - Perl extension for computing intersection with upright line

SchemaView-Plus documentation Contained in the SchemaView-Plus distribution.

Index

Code Index:

NAME

Top

Math::Project - Perl extension for computing intersection with upright line through input point

SYNOPSIS

Top

	use Math::Project qw/project/;

	my ($x,$y,$distance) = project ($x1, $y1, $x2, $y2, $xi, $yi);

DESCRIPTION

Top

This module provides function project() for computing intersection with upright line through input point [xi,yi]. You must specify points [x1,y1] and [x2,y2] of straight line.

You can use list of imported functions or access functions via Math::Project::function schema.

FUNCTIONS

Top

project (x1, y1, x2, y2, xi, yi)

Computes intersection between straight line specified with [x1,y1] and [x2,y2] and upright line through input point [xi,yi]. Return three items in list, the first two are coordinates of intersection [xc,yc] and the third is distance between intersection and input point.

	my ($x,$y,$distance) = project ($x1, $y1, $x2, $y2, $xi, $yi);

abscissa_project (x1, y1, x2, y2, xi, yi)

Same as project() but [x1,y1] and [x2,y2] determine abscissa.

	my ($x,$y,$distance) = abscissa_project ($x1, $y1, $x2, $y2,
		$xi, $yi);

VERSION

Top

0.03

AUTHOR

Top

(c) 2001 Milan Sorm, sorm@pef.mendelu.cz at Faculty of Economics, Mendel University of Agriculture and Forestry in Brno, Czech Republic.

This module was needed for making SchemaView Plus (svplus) for adding drag points to coord based connection method.

SEE ALSO

Top

perl(1), svplus(1).

SchemaView-Plus documentation Contained in the SchemaView-Plus distribution. 
package Math::Project;

use strict;
use vars qw/$VERSION @ISA @EXPORT_OK/;
use Exporter;

$VERSION = '0.03';
@ISA = qw/Exporter/;
@EXPORT_OK = qw/project abscissa_project/;


sub _sign {
	my $x = shift;
	return -1 if $x < 0;
	return +1 if $x > 0;
	return 0;
}

sub _round {
	my $f = shift;
	return int ($f+0.5);
}

sub _project {
	my ($x1,$y1,$x2,$y2,$xi,$yi) = @_;

	return [ $x1,$y1,0 ] if $x1 == $xi and $y1 == $yi;
	return [ $x2,$y2,0 ] if $x2 == $xi and $y2 == $yi;
	return [ $x1,$y1,0 ] if $x1 == $x2 and $y1 == $y2;

	my $dx = $x2-$x1;  my $dy = $y2-$y1;

	my $l = sqrt($dx*$dx+$dy*$dy);
	my $b = sqrt(($xi-$x1)*($xi-$x1)+($yi-$y1)*($yi-$y1));
	my $c = sqrt(($xi-$x2)*($xi-$x2)+($yi-$y2)*($yi-$y2));
	my $a = ($b*$b-$c*$c+$l*$l)/(2*$l);
	my $d = sqrt($b*$b-$a*$a);

	my $xo = ($a/$l) * $dx;
	my $yo = ($a/$l) * $dy;

	my $abscissa = 0;
	++$abscissa if _sign($dx) == _sign($xo) and _sign($dy) == _sign($yo)
		and (abs($xo) < abs($dx) or abs($yo) < abs($dy));

	my @res = (_round($x1+$xo), _round($y1+$yo), _round(abs($d)), 
		$abscissa);

	return wantarray ? @res : \@res;
}

sub project {
	my @res = _project(@_);
	pop @res;  
	return wantarray ? @res : \@res;
}

sub abscissa_project {
	my @res = _project(@_);
	my $a = pop @res;
	return wantarray ? () : undef unless $a;
	return wantarray ? @res : \@res;
}

1;

__END__