File Coverage

blib/lib/Math/Bezier/Convert.pm

Criterion	Covered	Total	%
statement	9	188	4.7
branch	0	52	0.0
condition	0	72	0.0
subroutine	3	12	25.0
pod	6	6	100.0
total	18	330	5.4

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.02';

# 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 ($a1, $b1, $a2, $b2, $cx, $cy) = (undef) x 6;
    my @qp = ($p0x, $p0y);

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

CURVE:
    while (@cp and my @p = my ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = splice(@cp, 0, 6)) {
	my @qp1 = ();
	my $revf = 0;
DIVCURVE:
	{
	    my $step = 0.5;
	    my $sep = 1;
	    my @cp1 = ();
	    my @qp2 = ();
	    my ($cp3x, $cp3y);

	    while ($step > 0.001) {

		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);

# skip if all points are almost same position.
		last DIVCURVE if (abs($v01x)<0.01 and abs($v02x)<0.01 and abs($v03x)<0.01 and
				  abs($v01y)<0.01 and abs($v02y)<0.01 and abs($v03y)<0.01);

		if (abs($v01x)<0.01 and abs($v01y)<0.01) {
		    if ($revf) {
			@qp2 = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
			last;
		    } else {
			if (abs($v32x) <0.01 and abs($v32y) <0.01) {
			    @qp2 = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
			    last;
			}
			$revf = 1;
			@qp1 = ($p[4], $p[5]);
			($p0x, $p0y, @p) =
			    ($p[4], $p[5], $p[2], $p[3], $p[0], $p[1], $p0x, $p0y);
			($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = @p;
			redo DIVCURVE;
		    }
		}

		my $vp14 = $v01y*$v32x - $v01x*$v32y;
		my $vp12 = $v01x*$v02y - $v01y*$v02x;
		my $vp13 = $v01x*$v03y - $v01y*$v03x;
		my $vp23 = $v02x*$v03y - $v03x*$v02y;

		if ($vp14 == 0) {
# if v01 and v32 are parallel and not in line, do next step.
		    if ($vp12) {
			$sep -= $step;
			$step /= 2;
			next;
		    } else {
# if anchors and control points are in line,
			@qp2 = ($p0x, $p0y);
			my $deltax = 3*($p1x - $p0x);
			my $deltay = 3*($p1y - $p0y);
			my $betax = 3*($p2x - $p1x) - $deltax;
			my $betay = 3*($p2y - $p1y) - $deltay;
			my $alphax = $p3x - $p0x - $deltax - $betax;
			my $alphay = $p3y - $p0y - $deltay - $betay;
			my $d_x = $betax*$betax - 3*$alphax*$deltax;
			my $d_y = $betay*$betay - 3*$alphay*$deltay;
			last if ($d_x < 0 or $d_y < 0);
			my ($u1, $u2);
			if ($deltax == 0 and $betax == 0 and $alphax == 0) {
			    $u1 = (-2*$betay + 2*sqrt($d_y)) / (6*$alphay);
			    $u2 = (-2*$betay - 2*sqrt($d_y)) / (6*$alphay);
			} else {
			    $u1 = (-2*$betax + 2*sqrt($d_x)) / (6*$alphax);
			    $u2 = (-2*$betax - 2*sqrt($d_x)) / (6*$alphax);
			}
			($u1, $u2) = ($u2, $u1) if $u1 > $u2;
			if ($u1 > 0 and $u1 < 1) {
			    my @p = (divide_cubic($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $u1))[6,7];
			    push @qp2, @p, @p;
			}
			if ($u2 > 0 and $u2 < 1) {
			    my @p = (divide_cubic($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $u2))[6,7];
			    push @qp2, @p, @p;
			}
			last;
		    }
		} else {
		    my $n = $vp23 / $vp14;
		    if ($n <= 0 or $n > $CTRL_PT_TOLERANCE or $vp13 / $vp14 <= 0 or $vp13 / $vp14 > $CTRL_PT_TOLERANCE) {
			$sep -= $step;
			$step /= 2;
			next;
		    } else {
			$cx = $p0x + $n * $v01x;
			$cy = $p0y + $n * $v01y;
		    }
		    if (defined $cx and _q_c_check($p0x, $p0y, $p1x, $p1y, $p2x, $p2y, $p3x, $p3y, $cx, $cy)) {
			@qp2 = ($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);
	    }

	    push @qp1, @qp2, $p3x, $p3y;
	    $p0x = $p3x;
	    $p0y = $p3y;
	    if (@cp1) {
		@p = ($p1x, $p1y, $p2x, $p2y, $p3x, $p3y) = @cp1;
		redo DIVCURVE;
	    }
	    unless (@qp2) {
		die "Can't approx ";
	    }
	} # DIVCURVE
	if ($revf) {
	    pop @qp1;
	    pop @qp1;
	    my ($x, $y);
	    while (@qp1) {
		$y = pop @qp1;
		$x = pop @qp1;
		push @qp, $x, $y;
	    }
	    $p0x = $x;
	    $p0y = $y;
	} else {
	    push @qp, @qp1;
	}
    }
    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.5);
    my ($cx, $cy) = (($p0x+$p3x)/2, ($p0y+$p3y)/2);
    if (($p30x-$cx)*($p30x-$cx)+($p30y-$cy)*($p30y-$cy) < $APPROX_LINE_TOLERANCE) {
	my ($c0x, $c0y) = (($p0x+$p30x)/2, ($p0y+$p30y)/2);
	my ($pp30x, $pp30y) = @{[divide_cubic(@p,0.25)]}[6,7];
	return () if (($pp30x-$c0x)*($pp30x-$c0x)+($pp30y-$c0y)*($pp30y-$c0y) < $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);
    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__