File Coverage

blib/lib/Math/Bezier/Convert.pm

Criterion	Covered	Total	%
statement	9	139	6.4
branch	0	34	0.0
condition	0	60	0.0
subroutine	3	12	25.0
pod	6	6	100.0
total	18	251	7.1

package Math::Bezier::Convert;

require 5.005_62;
use strict;
use warnings;
use Carp;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
    divide_cubic
    divide_quadratic
    cubic_to_quadratic
    quadratic_to_cubic
    cubic_to_lines
    quadratic_to_lines
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '0.01';

# Globals

our $APPROX_QUADRATIC_TOLERANCE = 1;
our $APPROX_LINE_TOLERANCE = 1;
our $CTRL_PT_TOLERANCE = 3;

sub divide_cubic {
    my ($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $sep) = @_;
    my ($p10x, $p10y, $p11x, $p11y, $p12x, $p12y, $p20x, $p20y, $p21x, $p21y, $p30x, $p30y);

    $p10x = $p0x + $sep * ($p1x - $p0x);
    $p10y = $p0y + $sep * ($p1y - $p0y);
    $p11x = $p1x + $sep * ($p2x - $p1x);
    $p11y = $p1y + $sep * ($p2y - $p1y);
    $p12x = $p2x + $sep * ($p3x - $p2x);
    $p12y = $p2y + $sep * ($p3y - $p2y);
    $p20x = $p10x+ $sep * ($p11x-$p10x);
    $p20y = $p10y+ $sep * ($p11y-$p10y);
    $p21x = $p11x+ $sep * ($p12x-$p11x);
    $p21y = $p11y+ $sep * ($p12y-$p11y);
    $p30x = $p20x+ $sep * ($p21x-$p20x);
    $p30y = $p20y+ $sep * ($p21y-$p20y);

    return ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p30x, $p30y, $p21x, $p21y, $p12x, $p12y, $p3x, $p3y);
}

sub divide_quadratic {
    my ($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $sep) = @_;
    my ($p10x, $p10y, $p11x, $p11y, $p20x, $p20y);

    $p10x = $p0x + $sep * ($p1x - $p0x);
    $p10y = $p0y + $sep * ($p1y - $p0y);
    $p11x = $p1x + $sep * ($p2x - $p1x);
    $p11y = $p1y + $sep * ($p2y - $p1y);
    $p20x = $p10x+ $sep * ($p11x-$p10x);
    $p20y = $p10y+ $sep * ($p11y-$p10y);

    return ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p11x, $p11y, $p2x, $p2y);
}

sub cubic_to_quadratic {
    my ($p0x, $p0y, @cp) = @_;
    my ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y);
    my ($a1, $b1, $a2, $b2, $cx, $cy) = (undef) x 6;
    my @qp = ($p0x, $p0y);
    my @p;

    croak '$CTRL_PT_TOLERANCE must be more than 1.5 ' unless $CTRL_PT_TOLERANCE > 1.5;

CURVE:
    while (@cp and @p = ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = splice(@cp, 0, 6)) {

	my $step = 0.5;
	my $sep = 1;
	my @qp1 = ();
	my @cp1 = ();
	my ($cp3x, $cp3y);

	while ($step > 0.0000001) {

	    my ($v01x, $v01y) = ($p1x-$p0x, $p1y-$p0y);
	    my ($v02x, $v02y) = ($p2x-$p0x, $p2y-$p0y);
	    my ($v03x, $v03y) = ($p3x-$p0x, $p3y-$p0y);
	    my ($v32x, $v32y) = ($p2x-$p3x, $p2y-$p3y);

	    next CURVE if (abs($v01x)<0.0001 and abs($v02x)<0.0001 and abs($v03x)<0.0001 and
			   abs($v01y)<0.0001 and abs($v02y)<0.0001 and abs($v03y)<0.0001);


	    if (abs($v01x)<0.0001 and abs($v32x)<0.0001 and
		abs($v01y)<0.0001 and abs($v32y)<0.0001) {

		@qp1 = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
		last;
	    }

	    my $n = $v01y*$v32x - $v01x*$v32y;
	    if ($n == 0) {
		if ($v02x*$v32y - $v02y*$v32x == 0) {
		    @qp1 = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
		    last;
		} else {
		    $sep -= $step;
		    $step /= 2;
		    next;
		}
	    }
	    my $m1 = $v01x*$v03y - $v01y*$v03x;
	    my $m2 = $v02x*$v03y - $v03x*$v02y;
	    if ($m1/$n < 1 or $m2/$n < 1 or $m1/$n >$CTRL_PT_TOLERANCE or $m2/$n > $CTRL_PT_TOLERANCE) {
		$sep -= $step;
		$step /= 2;
		next;
	    }
	    $cx = $p0x + $m2 * $v01x / $n;
	    $cy = $p0y + $m2 * $v01y / $n;

	    if (defined $cx and _q_c_check($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $cx, $cy)) {
		@qp1 = ($cx, $cy);
		last if $sep>=1;
		$sep += $step;
	    } else {
		$sep -= $step;
	    }
	    $step /= 2;
	} continue {
	    (undef, undef, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, @cp1) = divide_cubic($p0x, $p0y, @p, $sep);
	}
	unless (@qp1) {
	    die "Can't approx @p";
#	    return @qp;
	}
	push @qp, @qp1, $p3x, $p3y;
	$p0x = $p3x;
	$p0y = $p3y;
	if (@cp1) {
	    @p = ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = @cp1;
	    redo;
	}
    }
    return @qp;
}

sub _q_c_check {
    my ($cx0, $cy0, $cx1, $cy1, $cx2, $cy2, $cx3, $cy3, $qx1, $qy1) = @_;
    my ($a, $b, $c, $d, $sep);

    $a = (($cx0-$cx3)*($cy1-$cy3)-($cy0-$cy3)*($cx1-$cx3)<=>0);
    $b = (($cx0-$cx3)*($cy2-$cy3)-($cy0-$cy3)*($cx2-$cx3)<=>0);
    return if ($a == 0 or $b == 0 or $a != $b);

    my ($cx, $cy) = (divide_cubic($cx0,$cy0,$cx1,$cy1,$cx2,$cy2,$cx3,$cy3, 0.5))[6,7];
    $a = $cx0-2*$qx1+$cx3;
    $b = 2*$qx1-2*$cx0;
    $c = $cx0-$cx;
    $d = $b*$b-4*$a*$c;
    return if ($d<0);
    my ($qx, $qy);
    if ($a!=0) {
	$sep = (-$b-sqrt($d))/2/$a;
	$sep = (-$b+sqrt($d))/2/$a if ($sep<=0 or $sep>=1);
	return if ($sep<=0 or $sep>=1);
	($qx, $qy) = (divide_quadratic($cx0,$cy0,$qx1,$qy1,$cx3,$cy3, $sep))[4, 5];
    } else {
	($qx, $qy) = ($qx1, $qy1);
    }
    return ($cx-$qx)*($cx-$qx)+($cy-$qy)*($cy-$qy) < $APPROX_QUADRATIC_TOLERANCE;
}

sub quadratic_to_cubic {
    my ($p0x, $p0y, @qp) = @_;
    my @cp = ($p0x, $p0y);
    my ($p1x, $p1y, $p2x, $p2y);

    while (@qp and ($p1x, $p1y, $p2x, $p2y) = splice(@qp, 0, 4)) {
	push @cp, $p0x+($p1x-$p0x)*2/3, $p0y+($p1y-$p0y)*2/3, $p1x+($p2x-$p1x)/3, $p1y+($p2y-$p1y)/3, $p2x, $p2y;
	$p0x = $p2x;
	$p0y = $p2y;
    }
    return @cp;
}

sub cubic_to_lines {
    my @cp = @_;
    my @p;
    my @last = splice(@cp, 0, 2);
    my @lp = @last;

    while (@cp and @p = splice(@cp, 0, 6)) {
	push @lp, _c2lsub(@last, @p);
	push @lp, @last = @p[4,5];
    }
    return @lp;
}

sub _c2lsub {
    my @p = @_;
    my ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p30x, $p30y, $p21x, $p21y, $p12x, $p12y, $p3x, $p3y) =
	divide_cubic(@p[0..7], 0.5);
    my ($cx, $cy) = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
    return () if (($p30x-$cx)*($p30x-$cx)+($p30y-$cy)*($p30y-$cy) < $APPROX_LINE_TOLERANCE);
    return (_c2lsub($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p30x, $p30y), $p30x, $p30y, _c2lsub($p30x, $p30y, $p21x, $p21y, $p12x, $p12y, $p3x, $p3y));
}

sub quadratic_to_lines {
    my @qp = @_;
    my @p;
    my @last = splice(@qp, 0, 2);
    my @lp = @last;

    while (@qp and @p = splice(@qp, 0, 4)) {
	push @lp, _q2lsub(@last, @p);
	push @lp, @last = @p[2,3];
    }
    return @lp;
}

sub _q2lsub {
    my @p = @_;
    my ($p0x, $p0y, $p10x, $p10y, $p20x, $p20y, $p11x, $p11y, $p2x, $p2y) =
	divide_quadratic(@p[0..5], 0.5);
    my ($cx, $cy) = (($p0x+$p2x)/2, ($p0y+$p2y)/2);
    return () if (($p20x-$cx)*($p20x-$cx)+($p20y-$cy)*($p20y-$cy) < $APPROX_LINE_TOLERANCE);
    return (_q2lsub($p0x, $p0y, $p10x, $p10y, $p20x, $p20y), $p20x, $p20y, _q2lsub($p20x, $p20y, $p11x, $p11y, $p2x, $p2y));
}

1;
__END__