Thomsen's Figure

Author

Eric W. Weisstein
September 14, 2005

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

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

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

Init

Lines

p1={(1-k)/a,0,k/c};

p2=Intersections[ParallelLine[p1,TrilinearLine[{1,0,0}]],TrilinearLine[{0,0,1}]]//Simplify//Factor

p3=Intersections[ParallelLine[p2,TrilinearLine[{0,1,0}]],TrilinearLine[{1,0,0}]]//Simplify//Factor

p4=(1/b)Intersections[ParallelLine[p3,TrilinearLine[{0,0,1}]],TrilinearLine[{0,1,0}]]//Simplify//Factor

p5=(1/c)Intersections[ParallelLine[p4,TrilinearLine[{1,0,0}]],TrilinearLine[{0,0,1}]]//Simplify//Factor

p6=(1/a)Intersections[ParallelLine[p5,TrilinearLine[{0,1,0}]],TrilinearLine[{1,0,0}]]//Simplify//Factor

(1/b)Intersections[ParallelLine[p6,TrilinearLine[{0,0,1}]],TrilinearLine[{0,1,0}]]//Simplify//Factor

pts={{(1-k)c,0,k a},{-b (-1+k),a k,0},{0,c k,-b (-1+k)},{c k,0,-a (-1+k)},{b k,-a (-1+k),0},{0,-c (-1+k),b k}};

With[{t=Triangle[{{0,0},{1,0},{.2,.5}}],
k=.3
},
Show[Graphics[{
t,
{Red,ClosedLine[Cartesian[#[t]][[1]]&/@pts]},
PointLabels[Join[
Append[#,Red]&/@Transpose[
{Cartesian[#[t]]&/@pts,{"(Subscript[P, 1])","(Subscript[P, 2])","(Subscript[P, 3])","(Subscript[P, 4])","(Subscript[P, 5])","(Subscript[P, 6])"}}],
Transpose[{VertexPoints[t],{"A","B","C"}}]
],LabelOffset->.03
]
}],AspectRatio->Automatic,PlotRange->All]
]

With[{t=Triangle[{{0,0},{1,0},{.2,.5}}],kk=.3},
Show[Graphics[{
t,
{Red,ClosedLine[Cartesian[#[t]][[1]]&/@pts/.k->kk]},
PointLabels[Join[
Append[#,Red]&/@Transpose[
{Cartesian[#[t]]&/@pts/.k->kk,pts}],
Transpose[{VertexPoints[t],{"A","B","C"}}]
],LabelOffset->.03
]
}],AspectRatio->Automatic,PlotRange->All]
]

With[{t=Triangle[{{0,0},{1,0},{.2,.5}}],kk=.3},
Show[Graphics[{
t,
{Blue,TrilinearCurve[t,conic/.k->kk]},
{Red,ClosedLine[Cartesian[#[t]][[1]]&/@pts/.k->kk]},
PointLabels[Join[
Append[#,Red]&/@Transpose[
{Cartesian[#[t]]&/@pts/.k->kk,Table["",{6}]}],
Transpose[{VertexPoints[t],{"A","B","C"}}]
],LabelOffset->.03
]
}],AspectRatio->Automatic,PlotRange->All]
]

Circumellipse

Conelliptic

conic1=Factor[Conic[Take[pts,5]]]

conic2=Factor[Conic[Take[pts,-5]]]

Equal@@Last/@{conic1,conic2}

conic=Last[conic1]

conic=-(a^2) k (α^2)+(a^2) (k^2) (α^2)+a b α β-2 a b k α β+2 a b (k^2) α β-(b^2) k (β^2)+(b^2) (k^2) (β^2)+a c α γ-2 a c k α γ+2 a c (k^2) α γ+b c β γ-2 b c k β γ+2 b c (k^2) β γ-(c^2) k (γ^2)+(c^2) (k^2) (γ^2);

Center of ellipse

Symmetrize[Center[conic]]

Trilinears[Centroid]

Special Cases

Steiner circumellipse

conic/.k->0

conic/.k->1

Numerator[Together[TrilinearEquation[SteinerCircumellipse]]]

Steiner inellipse

-Numerator[Together[conic/.k->1/2]]

TrilinearEquation[SteinerInellipse]

Radius

Factor[Distance[Trilinears[Centroid],{α,β,γ}]^2]

Maximize[{((a^4) (α^2)-2 (a^2) (b^2) (α^2)-2 (a^2) (c^2) (α^2)-(a^3) b α β-a (b^3) α β+5 a b (c^2) α β-2 (a^2) (b^2) (β^2)+(b^4) (β^2)-2 (b^2) (c^2) (β^2)-(a^3) c α γ+5 a (b^2) c α γ-a (c^3) α γ+5 (a^2) b c β γ-(b^3) c β γ-b (c^3) β γ-2 (a^2) (c^2) (γ^2)-2 (b^2) (c^2) (γ^2)+(c^4) (γ^2)), (a+b-c) (a-b+c) (-a+b+c) (a+b+c)==8(((a α+b β+c γ))^2)},{α,β,γ}]