Bicuspid Curve

Author

Eric W. Weisstein
February 17, 2012

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneCurves/BicuspidCurve.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/BicuspidCurve.html.

©2012 Wolfram Research, Inc. except for portions noted otherwise

Equations

Algebraic

eqn=(x^2-a^2)(x-a)^2+(y^2-a^2)^2;

Expand[eqn]

AlgebraicDegree[eqn,{x,y}]

Plot

V5

<<Graphics`ImplicitPlot`

ImplicitPlot[(x^2-a^2)(x-a)^2+(y^2-a^2)^2==0/.a->1,{x,-3,3},Ticks->None,
PlotStyle->Red,
AspectRatio->Automatic]

Show[
Block[{$DisplayFunction=Identity},
Table[ImplicitPlot[(x^2-a^2)(x-a)^2+(y^2-a^2)^2==0,{x,-5,5},AspectRatio->Automatic,Ticks->None,PlotStyle->Hue[a]],
{a,.05,1,.05}]]]

V6

ContourPlot[Evaluate[eqn==0/.a->1],{x,-1.1,1.1},{y,-1.6,1.6},ContourStyle->Red,AspectRatio->Automatic,MaxRecursion->3]

Centroid

eqn/.a->1

RegionPlot[Evaluate[eqn<0/.a->1],{x,-1,1},{y,-1.5,1.5},AspectRatio->Automatic,ImageSize->150]

NIntegrate[{x,y}Boole[(((-1+x))^2) (-1+(x^2))+(((-1+(y^2)))^2)<0],{x,-1,1},{y,-1.5,1.5}]//Chop

Integrate[{x,y}Boole[eqn<0],{x,-∞,∞},{y,-∞,∞},Assumptions->a>0]//FullSimplify//Timing

N[Last[%]]

(xybar=Integrate[{x,y}Boole[y^2(a^2-x^2)-(x^2+2a y-a^2)^2>0],{x,-a,a},{y,0,a},Assumptions->a>0]//FullSimplify)//Timing

(xybar=Integrate[{x,y}Boole[y^2(a^2-x^2)-(x^2+2a y-a^2)^2>0],{x,-∞,∞},{y,-∞,∞},Assumptions->a>0]//FullSimplify)//Timing

(area=Integrate[Boole[y^2(a^2-x^2)-(x^2+2a y-a^2)^2>0],{x,-a,a},{y,0,a},Assumptions->a>0]//FullSimplify)//Timing

FullSimplify[(xybar/area)]

Area Moment of Inertia

Integrate[AreaInertiaTensor[x,y]Boole[y^2(a^2-x^2)-(x^2+2a y-a^2)^2>0],{x,-a,a},{y,0,a},Assumptions->a>0]//FullSimplify

Integrate[AreaInertiaTensor[x,y]Boole[y^2(a^2-x^2)-(x^2+2a y-a^2)^2>0],{x,-∞,∞},{y,0,∞},Assumptions->a>0]//FullSimplify

Solving for y(x)

xsoln=y/.Solve[(x^2-a^2)(x-a)^2+(y^2-a^2)^2==0,y]/.a->1

Plot[Evaluate[xsoln],{x,-1,1},AspectRatio->Automatic,PlotStyle->List/@{Red,Yellow,Green,Blue}]

FullSimplify[Solve[xsoln[[1]]==xsoln[[2]],x]]

N[%]

FullSimplify[Solve[xsoln[[2]]==xsoln[[4]],x]]

FullSimplify[xsoln[[2]]/.x->-1]

Solve[D[xsoln[[4]],x]==0,x]

FullSimplify[xsoln[[4]]/.x->-1/2]

"Parametric" Michael 1

mtrott 2/13/2012

Solve for y and then piece it together: (it does five a piecewise C_inf parametrization).  (you get the idea, three more pieces to be added).

ParametricPlot[Piecewise[{{{t,Sqrt[1-Sqrt[-(-1+t)^3 (1+t)]]},0≤t≤1},{With[{τ=1-(t-1)},{τ,Sqrt[1+Sqrt[-(-1+τ)^3 (1+τ)]]}],1≤t≤3},{With[{τ=-1+(t-3)},{τ,Sqrt[1-Sqrt[-(-1+τ)^3 (1+τ)]]}],3<t<3+(1+X)},{With[{τ=X-(t-(3+(1+X)))},{τ,-Sqrt[1-Sqrt[-(-1+τ)^3 (1+τ)]]}],3+(1+X)<t<3+2 (1+X)}}],{t,0,4},PlotRange->2,ColorFunction->(Hue[#3]&),ColorFunctionScaling->True,PlotPoints->100,Evaluated->False,ImageSize->Small]

ParametricPlot[{{x,-(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},{x,(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},{x,-(Sqrt[1+(Sqrt[(((1-x))^3) (1+x)])])},{x,(Sqrt[1+(Sqrt[(((1-x))^3) (1+x)])])}},{x,-1,1},ImageSize->Small]

Parametric Michael

ParametricPlot[With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)}],{t,-1/2 Sqrt[4+3 Sqrt[3]],3/2 Sqrt[4+3 Sqrt[3]]},ImageSize->Small]

Parametric Eric

GraphicsGrid[Partition[{
p1=ParametricPlot[{x,(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},{x,0,1}],
p2=ParametricPlot[{x,(Sqrt[1+(Sqrt[(((1-x))^3) (1+x)])])},{x,-1,1}],
p3=ParametricPlot[{x,(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},{x,-1,0}],
p4=ParametricPlot[{x,-(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},{x,-1,0}],
p5=ParametricPlot[{x,-(Sqrt[1+(Sqrt[(((1-x))^3) (1+x)])])},{x,-1,1}],
p6=ParametricPlot[{x,-(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},{x,0,1}]},3,3,{1,1},{}]]

Show[{p1,p2,p3,p4,p5,p6},PlotRange->All]

ParametricPlot[Piecewise[{
{{x,(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},0<=x<=1},
{{x-2,(Sqrt[1+(Sqrt[(((1-(x-2)))^3) (1+(x-2))])])},1<x≤3},
{{x-4,(Sqrt[1-(Sqrt[(((1-(x-4)))^3) (1+(x-4))])])},3<x≤4},
{{x-5,-(Sqrt[1-(Sqrt[(((1-(x-5)))^3) (1+(x-5))])])},4<x≤5},
{{x-6,-(Sqrt[1+(Sqrt[(((1-(x-6)))^3) (1+(x-6))])])},5≤x≤7},
{{x-8,-(Sqrt[1-(Sqrt[(((1-(x-8)))^3) (1+(x-8))])])},7≤x≤9}
}],{x,0,9},PlotRange->All]

p=Piecewise[pieces={
{{x,(Sqrt[1-(Sqrt[(((1-x))^3) (1+x)])])},0<=x<=1},
{{x-2,(Sqrt[1+(Sqrt[(((1-(x-2)))^3) (1+(x-2))])])},1<=x≤3},
{{x-4,(Sqrt[1-(Sqrt[(((1-(x-4)))^3) (1+(x-4))])])},3<=x≤4},
{{x-5,-(Sqrt[1-(Sqrt[(((1-(x-5)))^3) (1+(x-5))])])},4<=x≤5},
{{x-6,-(Sqrt[1+(Sqrt[(((1-(x-6)))^3) (1+(x-6))])])},5≤x≤7},
{{x-8,-(Sqrt[1-(Sqrt[(((1-(x-8)))^3) (1+(x-8))])])},7≤x≤9}
}];

Sqrt/@(Total/@D[pieces[[All,1]],x]^2)

ds=Piecewise[Transpose[{Sqrt/@(Total/@D[pieces[[All,1]],x]^2),pieces[[All,2]]}]]

NIntegrate[ds,{x,0,9}]

%/2

parametrization[t_?NumericQ]:=With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)}
]

With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)}
]//TraditionalForm

With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},ParametricPlot[parametrization[t],{t,-Z,3 Z},Evaluated->False]]

With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)}
]

With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},ToRadicals[Root[-2 (t^2)+(t^4)+2 #1-2 ((#1)^3)+((#1)^4)&,2],Assumptions->-Z<t<3Z]]

{x,y}=D[UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)},t]

1/2 Sqrt[4+3 Sqrt[3]]//N

Simplify[(Sqrt[x^2+y^2]),-Z<t<3 Z&&1<Z<2]

p1=With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},NIntegrate[(Sqrt[1+((4 (t^2) (((-1+(t^2)))^2))/((((-1+Root[-2 (t^2)+(t^4)+2 #1-2 ((#1)^3)+((#1)^4)&,2]))^4) (((1+2 Root[-2 (t^2)+(t^4)+2 #1-2 ((#1)^3)+((#1)^4)&,2]))^2)))]),{t,-Z,Z}]]

With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},Integrate[(Sqrt[1+((4 (t^2) (((-1+(t^2)))^2))/((((-1+Root[-2 (t^2)+(t^4)+2 #1-2 ((#1)^3)+((#1)^4)&,2]))^4) (((1+2 Root[-2 (t^2)+(t^4)+2 #1-2 ((#1)^3)+((#1)^4)&,2]))^2)))]),{t,-Z,Z}]]

p2=With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},NIntegrate[√(1+(4 ((((t^3)+2 Z-6 (t^2) Z-8 (Z^3)+t (-1+12 (Z^2))))^2))/((((-1+Root[-2 (t^2)+(t^4)+8 t Z-8 (t^3) Z-8 (Z^2)+24 (t^2) (Z^2)-32 t (Z^3)+16 (Z^4)+2 #1-2 ((#1)^3)+((#1)^4)&,1]))^4) (((1+2 Root[-2 (t^2)+(t^4)+8 t Z-8 (t^3) Z-8 (Z^2)+24 (t^2) (Z^2)-32 t (Z^3)+16 (Z^4)+2 #1-2 ((#1)^3)+((#1)^4)&,1]))^2))),{t,Z,3Z}]]

p1+p2

With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},Integrate[√(1+(4 ((((t^3)+2 Z-6 (t^2) Z-8 (Z^3)+t (-1+12 (Z^2))))^2))/((((-1+Root[-2 (t^2)+(t^4)+8 t Z-8 (t^3) Z-8 (Z^2)+24 (t^2) (Z^2)-32 t (Z^3)+16 (Z^4)+2 #1-2 ((#1)^3)+((#1)^4)&,1]))^4) (((1+2 Root[-2 (t^2)+(t^4)+8 t Z-8 (t^3) Z-8 (Z^2)+24 (t^2) (Z^2)-32 t (Z^3)+16 (Z^4)+2 #1-2 ((#1)^3)+((#1)^4)&,1]))^2))),{t,Z,3Z}]]

Solving for x(y)

ysoln=x/.Solve[(x^2-a^2)(x-a)^2+(y^2-a^2)^2==0,x]/.a->1

ParametricPlot[Evaluate[{#,y}&/@ysoln],{y,-2,2},AspectRatio->Automatic,PlotStyle->List/@{Red,Yellow,Green,Blue}]

Area

(x^2-a^2)(x-a)^2+(y^2-a^2)^2<0/.a->1

<<Graphics`InequalityGraphics`

With[{a=1},
InequalityPlot[(x^2-a^2)(x-a)^2+(y^2-a^2)^2<0,
{x},{y}]
]

With[{a=1},NIntegrate[Boole[(x^2-a^2)(x-a)^2+(y^2-a^2)^2<0],{x,-∞,∞},{y,-∞,∞}]]

Boole

Integrate[Boole[(((-1+x))^2) (-1+(x^2))+(((-1+(y^2)))^2)<0],{x,-∞,∞},{y,-∞,∞}]//Timing

Integrate[Boole[(((-1+x))^2) (-1+(x^2))+(((-1+(y^2)))^2)<0],{y,-∞,∞},{x,-∞,∞}]//Timing

y(x)

Numeric

2Plus@@{NIntegrate[xsoln[[4]]-xsoln[[2]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
NIntegrate[xsoln[[4]],{x,Root[2-2 ((#1)^2)+((#1)^3)&,1],0}],
NIntegrate[xsoln[[4]]-xsoln[[2]],{x,0,1}]
}//Timing

v4.2

2Plus@@{Integrate[xsoln[[4]]-xsoln[[2]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
Integrate[xsoln[[4]],{x,Root[2-2 ((#1)^2)+((#1)^3)&,1],0}],
Integrate[xsoln[[4]]-xsoln[[2]],{x,0,1}]
}//Timing

v5.1

2Plus@@{Integrate[xsoln[[4]]-xsoln[[2]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
Integrate[xsoln[[4]],{x,Root[2-2 ((#1)^2)+((#1)^3)&,1],0}],
Integrate[xsoln[[4]]-xsoln[[2]],{x,0,1}]
}//Timing

v6

2Plus@@{Integrate[xsoln[[4]]-xsoln[[2]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
Integrate[xsoln[[4]],{x,Root[2-2 ((#1)^2)+((#1)^3)&,1],0}],
Integrate[xsoln[[4]]-xsoln[[2]],{x,0,1}]
}//Timing

Solving for y

dax=Simplify[xsoln[[4]]-xsoln[[3]]]

Numeric

NIntegrate[dax,{y,-(Sqrt[1+(3/4)(Sqrt[3])]),(Sqrt[1+(3/4)(Sqrt[3])])},MaxRecursion->20]

2NIntegrate[dax,{y,0,(Sqrt[1+(3/4)(Sqrt[3])])},MaxRecursion->20]

v4.2

2Integrate[dax,{y,0,(Sqrt[1+(3/4)(Sqrt[3])])}]//Timing

...hangs...

v5.1

Integrate[dax,{y,-(Sqrt[1+(3/4)(Sqrt[3])]),(Sqrt[1+(3/4)(Sqrt[3])])}]//Timing

...hangs...

v6

2Integrate[dax,{y,0,(Sqrt[1+(3/4)(Sqrt[3])])}]//Timing

...hangs...

Arc Length

y(x)

dsx=Simplify[(Sqrt[1+((D[#,x])^2)])&/@xsoln[[{2,4}]]]

v4.2

2Plus@@{Integrate[dsx[[1]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
Integrate[dsx[[2]],{x,-1,1}],
Integrate[dsx[[1]],{x,0,1}]}//Timing

...hangs...

v5.0

2Plus@@{NIntegrate[dsx[[1]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
NIntegrate[dsx[[2]],{x,-1,1}],
NIntegrate[dsx[[1]],{x,0,1}]}

v5.2

2Plus@@{Integrate[dsx[[1]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
Integrate[dsx[[2]],{x,-1,1}],
Integrate[dsx[[1]],{x,0,1}]}//Timing

2Plus@@{NIntegrate[dsx[[1]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
NIntegrate[dsx[[2]],{x,-1,1}],
NIntegrate[dsx[[1]],{x,0,1}]}//Timing

v6

2Plus@@{Integrate[dsx[[1]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
Integrate[dsx[[2]],{x,-1,1}],
Integrate[dsx[[1]],{x,0,1}]}//Timing

2Plus@@{NIntegrate[dsx[[1]],{x,-1,Root[2-2 ((#1)^2)+((#1)^3)&,1]}],
NIntegrate[dsx[[2]],{x,-1,1}],
NIntegrate[dsx[[1]],{x,0,1}]}//Timing

x(y)

dsy=(Sqrt[1+D[#,y]^2])&/@ysoln[[{3,4}]];

dsy

Simplify[dsy]

v5.2

2Plus@@(NIntegrate[#,{y,0,(Sqrt[1+(3/4)(Sqrt[3])])}]&/@dsy)

2Plus@@(NIntegrate[#,{y,0,1,(Sqrt[1+(3/4)(Sqrt[3])])}]&/@dsy)

2Plus@@(NIntegrate[#,{y,0,1,(Sqrt[1+(3/4)(Sqrt[3])])},MaxRecursion->20,SingularityDepth->10,WorkingPrecision->20]&/@dsy)

v6

2Plus@@(NIntegrate[#,{y,0,(Sqrt[1+(3/4)(Sqrt[3])])}]&/@dsy)

2Plus@@(NIntegrate[#,{y,0,1,(Sqrt[1+(3/4)(Sqrt[3])])}]&/@dsy)

2Plus@@(NIntegrate[#,{y,0,1,(Sqrt[1+(3/4)(Sqrt[3])])},Method->QuasiMonteCarlo]&/@dsy)

2Plus@@(NIntegrate[#,{y,0,1,(Sqrt[1+(3/4)(Sqrt[3])])},MaxRecursion->20,SingularityDepth->10,WorkingPrecision->20]&/@dsy)

Properties

Curvature

Refine[Curvature[With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},a (UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)})],t],t!=(1/2) (Sqrt[4+3 (Sqrt[3])])]

Simplify[Curvature[With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},a (UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)})],t],-1/2 Sqrt[4+3 Sqrt[3]]<t<3/2 Sqrt[4+3 Sqrt[3]]]//Timing

Factor[ImplicitCurvature[eqn,{x,y}]]

FullSimplify[%,a>0]

SortBy[FullSimplify[Curvature[eqn,{x,y}],a>0&&(x|y)∈Reals],ByteCount]

ByteCount/@%

Inflection Points

pts=InflectionPoints[eqn,{x,y},a>0]

Simplify[Solve[eqn==-16 (((a-x))^4) (((a+2 x))^2) ((a^2)-3 (y^2))+192 x (-a+x) (y^2) ((((a^2)-(y^2)))^2)==0,{x,y}]//Union,a>0]

Singular Points

pts=SingularPoints[eqn,{x,y}]

Block[{a=1},
ContourPlot[eqn==0,{x,-1.2,1.2},{y,-1.6,1.6},ContourStyle->Red,AspectRatio->Automatic,MaxRecursion->4,Axes->True,Epilog->{PointSize[.04],Point[pts]}]
]

Slope

FullSimplify[Slope[(x^2-a^2) (x-a)^2+(y^2-a^2)^2==0,{x,y}]]

FullSimplify[Slope[(x^2-a^2) (x-a)^2+(y^2-a^2)^2==0,{x,y}]]

Simplify[Slope[With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},a (UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)})],t],-1/2 Sqrt[4+3 Sqrt[3]]<t<3/2 Sqrt[4+3 Sqrt[3]]]//Timing

Piecewise[{{(1/(2*t - 2*t^3))*(1 - 3*Root[-2*t^2 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 2]^
        2 + 2*Root[-2*t^2 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 2]^3), 
    (-2^(-1))*Sqrt[4 + 3*Sqrt[3]] <= t <= (1/2)*Sqrt[4 + 3*Sqrt[3]]}, 
   {-(((-1 + Root[35 + 18*Sqrt[3] - 12*Sqrt[4 + 3*Sqrt[3]]*t - 
            12*Sqrt[3*(4 + 3*Sqrt[3])]*t + 22*t^2 + 18*Sqrt[3]*t^2 - 
            4*Sqrt[4 + 3*Sqrt[3]]*t^3 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 1])^2*
       (1 + 2*Root[35 + 18*Sqrt[3] - 12*Sqrt[4 + 3*Sqrt[3]]*t - 
            12*Sqrt[3*(4 + 3*Sqrt[3])]*t + 22*t^2 + 18*Sqrt[3]*t^2 - 
            4*Sqrt[4 + 3*Sqrt[3]]*t^3 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 1]))/
      (6*(1 + Sqrt[3])*Sqrt[4 + 3*Sqrt[3]] - 2*(11 + 9*Sqrt[3])*t + 
       6*Sqrt[4 + 3*Sqrt[3]]*t^2 - 2*t^3)), (2^(-1))*Sqrt[4 + 3*Sqrt[3]] <= t <= 
     (3/2)*Sqrt[4 + 3*Sqrt[3]]}}]//TraditionalForm

Plot[Piecewise[{{(1/(2*t - 2*t^3))*(1 - 3*Root[-2*t^2 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 2]^
        2 + 2*Root[-2*t^2 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 2]^3), 
    (-2^(-1))*Sqrt[4 + 3*Sqrt[3]] <= t <= (1/2)*Sqrt[4 + 3*Sqrt[3]]}, 
   {-(((-1 + Root[35 + 18*Sqrt[3] - 12*Sqrt[4 + 3*Sqrt[3]]*t - 
            12*Sqrt[3*(4 + 3*Sqrt[3])]*t + 22*t^2 + 18*Sqrt[3]*t^2 - 
            4*Sqrt[4 + 3*Sqrt[3]]*t^3 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 1])^2*
       (1 + 2*Root[35 + 18*Sqrt[3] - 12*Sqrt[4 + 3*Sqrt[3]]*t - 
            12*Sqrt[3*(4 + 3*Sqrt[3])]*t + 22*t^2 + 18*Sqrt[3]*t^2 - 
            4*Sqrt[4 + 3*Sqrt[3]]*t^3 + t^4 + 2*#1 - 2*#1^3 + #1^4 & , 1]))/
      (6*(1 + Sqrt[3])*Sqrt[4 + 3*Sqrt[3]] - 2*(11 + 9*Sqrt[3])*t + 
       6*Sqrt[4 + 3*Sqrt[3]]*t^2 - 2*t^3)), (2^(-1))*Sqrt[4 + 3*Sqrt[3]] <= t <= 
     (3/2)*Sqrt[4 + 3*Sqrt[3]]}}],{t,-1/2 Sqrt[4+3 Sqrt[3]],3/2 Sqrt[4+3 Sqrt[3]]},PlotRange->{Automatic,{-7,7}},Exclusions->None]

FullSimplify[Slope[With[{Z=1/2 Sqrt[4+3 Sqrt[3]]},a (UnitStep[Z-t] {Root[-2 t^2+t^4+2 #1-2 #1^3+#1^4&,2],t}+UnitStep[t-Z] {Root[-2 (t-2 Z)^2+(t-2 Z)^4+2 #1-2 #1^3+#1^4&,1],-(t-2 Z)})],t],-1/2 Sqrt[4+3 Sqrt[3]]<t<3/2 Sqrt[4+3 Sqrt[3]]]//Timing