Thomson Cubic

Author

Eric W. Weisstein
July 19, 2005

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneGeometry/ThomsonCubic.nb.

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

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

Pivot Point

CubicFunction[ThomsonCubic]

CenterFunction[Centroid]

Curve

TrilinearEquation[ThomsonCubic]

Incident Points

(ctrs=IncidentCenters[KimberlingCenters,TrilinearEquation[ThomsonCubic]])//Timing

{#,Name[#]}&/@ctrs//TableForm

Check

trilinears=Join[
Trilinears/@ctrs,
IdentityMatrix[3],
Midpoint/@Partition[IdentityMatrix[3],2,1,1],
TrilinearVertexMatrix[ExcentralTriangle],
Midpoint/@Transpose[{IdentityMatrix[3],TrilinearVertexMatrix[OrthicTriangle]}]
];

Do[
Print[{i,TimeConstrained[
FullSimplify[Numerator[DistanceTrilinears[TrigExpand[CubicEquation[ThomsonCubic]/.Thread[{α,β,γ}->trilinears[[i]]]]]],
TriangleQ[]],1000]//Timing}],
{i,Length[trilinears]}
]

Simplify[DistanceTrilinears[CubicEquation[ThomsonCubic]/.Thread[{α,β,γ}->Trilinears[X[223]]]/.
Tan[x_/2]:>(1-Cos[x])/Sin[x]],TriangleQ[]]//Timing

Simplify[DistanceTrilinears[CubicEquation[ThomsonCubic]/.Thread[{α,β,γ}->Trilinears[X[282]]]/.
Cot[x_/2]:>(1+Cos[x])/Sin[x]],TriangleQ[]]//Timing

Total points

Length[trilinears]

Products

Length[prods=Subsets[KimberlingCenters,{2}]]

tri=RandomTriangle[30]

rules=Join[Thread[{a,b,c}->SideLengths[Evaluate[tri]]],Thread[{A,B,C}->Angles[tri]]]

eqn=TrilinearEquation[ThomsonCubic]/.Thread[{a,b,c}->SideLengths[Evaluate[tri]]]

#==0.&/@(eqn/.Thread[{α,β,γ}->#]&/@(TrilinearProduct@@@Map[Trilinears,
Map[X,
{
{84,1490},{204,1032},{221,1034},{1073,1712}
},{2}],{2}]/.TriangleRules/.rules))

prods=(TrilinearEquation[ThomsonCubic]/.Thread[{α,β,γ}->#]&/@(TrilinearProduct@@@Map[Trilinears,
Map[X,
{
{84,1490},{204,1032},{221,1034},{1073,1712}
},{2}],{2}]/.TriangleRules));

Together//@ToSidelengths[prods[[1]]]//Timing

Simplify[ToSidelengths[prods[[2]]],TriangleQ[]]//Timing

Together//@ToSidelengths[HalfAngleFormulas[prods[[3]]]]//Timing

Factor[Factor[ToSidelengths[prods[[4]]]/.Sqrt[x_]Sqrt[y_]:>Simplify[Sqrt[x y],TriangleQ[]]]/.Sqrt[x_]Sqrt[y_]:>Simplify[Sqrt[x y],TriangleQ[]]]//Timing

Timing[pos=Position[#==0.&/@(eqn/.Thread[{α,β,γ}->#]&/@(TrilinearProduct@@@Map[Trilinears,prods,{2}]/.TriangleRules/.rules)),True]]

Quotients

{(Subscript[X, 20])·(((Subscript[X, 3])-Ceva conjugate of ((Subscript[X, 20])^(-1)))/((Subscript[X, 3])-Ceva conjugate of (Subscript[X, 20]))),(Subscript[X, 20])·(((Subscript[X, 4])-Ceva conjugate of ((Subscript[X, 20])^(-1)))/((Subscript[X, 4])-Ceva conjugate of (Subscript[X, 20]))),}

eqn/.(ToSidelengths[Thread[{α,β,γ}->TrilinearProduct[X[20],TrilinearQuotient[CevaConjugate[X[#],IsogonalConjugate[X[20]]],CevaConjugate[X[#],X[20]]]]]]/.TriangleRules/.rules)&/@{3,4}

eqn/.(ToSidelengths[Thread[{α,β,γ}->TrilinearProduct[X[20],TrilinearQuotient[CevaConjugate[X[#],IsogonalConjugate[X[20]]],CevaConjugate[X[#],X[20]]]]]]/.TriangleRules/.rules)&/@{3,4}

eqn/.(ToSidelengths[Thread[{α,β,γ}->TrilinearQuotient[CevaConjugate[X[#],IsogonalConjugate[X[20]]],CevaConjugate[X[#],X[20]]]]]/.TriangleRules/.rules)&/@{3,4}

Together//@(TrilinearEquation[ThomsonCubic]/.ToSidelengths[Thread[{α,β,γ}->TrilinearProduct[X[20],TrilinearQuotient[CevaConjugate[X[#],IsogonalConjugate[X[20]]],CevaConjugate[X[#],X[20]]]]]]&/@{3,4})

Factor[%]

Graphic

Solve[cubic==0/.γ->1,β]

Branches[g_]:=Module[{data=Flatten[g][[1,1]]},
split=Split[data,Sqrt[#.#]&[Subtract@@@#]<10&];
{Line/@(Drop[#,-1]&/@split)
}
]

t=Triangle[{{0,0},{1,0},{.3,.6}}];
Show[Graphics[{
t,
{Purple,
Branches[ParametricPlot[Evaluate[TrilinearToCartesian[t,{α,(-a c+a c (α^2)-√(-4 (-a b+b c α) (-b c α+a b (α^2))+(((a c-a c (α^2)))^2)))/(2 (-a b+b c α)),1}/.Thread[{a,b,c}->SideLengths[Evaluate[t]]]]],{α,-30,30},PlotRange->All,PlotPoints->100,
DisplayFunction->Identity][[1]]],
Branches[ParametricPlot[Evaluate[TrilinearToCartesian[t,{α,(-a c+a c (α^2)+√(-4 (-a b+b c α) (-b c α+a b (α^2))+(((a c-a c (α^2)))^2)))/(2 (-a b+b c α)),1}/.Thread[{a,b,c}->SideLengths[Evaluate[t]]]]],{α,-30,30},PlotRange->All,PlotPoints->100,
DisplayFunction->Identity][[1]]]
},
{Blue,Altitudes[t]},
PointLabels[Join[
Transpose[{VertexPoints[t],{"A","B","C"}}],
Append[#,Red]&/@Transpose[{Midpoints[t],{"(Subscript[M, A])","(Subscript[M, B])","(Subscript[M, C])"}}],
Append[#,Blue]&/@Transpose[{Midpoint/@Altitudes[t],{"(Subscript[M, (Subscript[H, A])])","(Subscript[M, (Subscript[H, B])])","(Subscript[M, (Subscript[H, C])])"}}],
Append[#,DarkGreen]&/@Transpose[{Excenters[t],{"(Subscript[J, A])","(Subscript[J, B])","(Subscript[J, C])"}}],
Append[#,Purple]&/@{
{Incenter[t],"I"},
{Centroid[t],"G"},
{Circumcenter[t],"O"},
{Orthocenter[t],"H"},
{SymmedianPoint[t],"K"},
{X[1073][t],"(Subscript[X, 1073])"}
}
],LabelOffset->.05]
}],AspectRatio->Automatic,PlotRange->{{-.4,1.5},{-1.1,.9}}]

X[1073][t]