Ehrmann Congruent Squares Point

Author

Eric W. Weisstein
January 22, 2005

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

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

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

Figure

t=Triangle[{{0,0},{1,0},{3/10,7/10}}];

pt=Function[L,{a/(a-L),b/(b-L),c/(c-L)}][Root[-2 a Area b c+2 a Area b #1+2 a Area c #1+(a^2) b c #1+2 Area b c #1+a (b^2) c #1+a b (c^2) #1-2 a Area ((#1)^2)-(a^2) b ((#1)^2)-2 Area b ((#1)^2)-a (b^2) ((#1)^2)-(a^2) c ((#1)^2)-2 Area c ((#1)^2)-(b^2) c ((#1)^2)-a (c^2) ((#1)^2)-b (c^2) ((#1)^2)+(a^2) ((#1)^3)+2 Area ((#1)^3)+(b^2) ((#1)^3)+(c^2) ((#1)^3)&,1]];

Cartesian[(ToSidelengths[pt]/.Thread[{a,b,c}->SideLengths[Evaluate[t]]])[t]]//N

EhrmannCongruentSquaresPoint[t]//N

eqns1={
α1==0,
α2==0,
ExactDistance[{α1,β1,γ1},{α4,β4,γ4}]^2==L^2,
ExactDistance[{α2,β2,γ2},{α3,β3,γ3}]^2==L^2,
ExactDistance[{α1,β1,γ1},{α2,β2,γ2}]^2==L^2,
ExactDistance[{α3,β3,γ3},{α4,β4,γ4}]^2==L^2,
Det[{{0,0,1},{α3,β3,γ3},pt}]==0,
Det[{{0,1,0},{α4,β4,γ4},pt}]==0,
a α1+b β1+c γ1==2Area,
a α2+b β2+c γ2==2Area,
a α3+b β3+c γ3==2Area,
a α4+b β4+c γ4==2Area
};
eqns2={
β1==0,
β2==0,
ExactDistance[{α1,β1,γ1},{α4,β4,γ4}]^2==L^2,
ExactDistance[{α2,β2,γ2},{α3,β3,γ3}]^2==L^2,
ExactDistance[{α1,β1,γ1},{α2,β2,γ2}]^2==L^2,
ExactDistance[{α3,β3,γ3},{α4,β4,γ4}]^2==L^2,
Det[{{1,0,0},{α4,β4,γ4},pt}]==0,
Det[{{0,0,1},{α3,β3,γ3},pt}]==0,
a α1+b β1+c γ1==2Area,
a α2+b β2+c γ2==2Area,
a α3+b β3+c γ3==2Area,
a α4+b β4+c γ4==2Area
};
eqns3={
γ1==0,
γ2==0,
ExactDistance[{α1,β1,γ1},{α4,β4,γ4}]^2==L^2,
ExactDistance[{α2,β2,γ2},{α3,β3,γ3}]^2==L^2,
ExactDistance[{α1,β1,γ1},{α2,β2,γ2}]^2==L^2,
ExactDistance[{α3,β3,γ3},{α4,β4,γ4}]^2==L^2,
Det[{{1,0,0},{α4,β4,γ4},pt}]==0,
Det[{{0,1,0},{α3,β3,γ3},pt}]==0,
a α1+b β1+c γ1==2Area,
a α2+b β2+c γ2==2Area,
a α3+b β3+c γ3==2Area,
a α4+b β4+c γ4==2Area
};

myeqns=ToSidelengths[{eqns1,eqns2,eqns3}/.
L->Root[-2 a Area b c+2 a Area b #1+2 a Area c #1+(a^2) b c #1+2 Area b c #1+a (b^2) c #1+a b (c^2) #1-2 a Area ((#1)^2)-(a^2) b ((#1)^2)-2 Area b ((#1)^2)-a (b^2) ((#1)^2)-(a^2) c ((#1)^2)-2 Area c ((#1)^2)-(b^2) c ((#1)^2)-a (c^2) ((#1)^2)-b (c^2) ((#1)^2)+(a^2) ((#1)^3)+2 Area ((#1)^3)+(b^2) ((#1)^3)+(c^2) ((#1)^3)&,1]]/.Thread[{a,b,c}->SideLengths[Evaluate[t]]];

vars={α1,β1,γ1,α2,β2,γ2,α3,β3,γ3,α4,β4,γ4};

solns=Append[#,First[#]]&[Partition[vars,3]]/.FindRoot[Evaluate[#],Evaluate[Sequence@@({#,Random[Real]}&/@vars)],
MaxIterations->200]&/@myeqns

mysolns={
{{0.`,0.4738201620871933`,0.3391493152560275`},{0.`,0.28908767559467463`,0.47983738549693655`},{0.19896297699879237`,0.2151946735177579`,0.33914932095255673`},{0.1989629769987923`,0.3999271600102765`,0.19846125071164755`},{0.`,0.4738201620871933`,0.3391493152560275`}},
{{0.4425810936485199`,0.`,0.2618670704386425`},{0.25784860715600116`,0.`,0.4447429019046796`},{0.1839556043330938`,0.1989629769987923`,0.36636755370531765`},{0.36868809082561255`,0.1989629769987923`,0.18349172223928056`},{0.4425810936485199`,0.`,0.2618670704386425`}},{{0.48084211962773643`,0.2941140499197574`,0.`},{0.3401540493868272`,0.4769898813857945`,0.`},{0.19946597169106053`,0.39861453473353314`,0.19896297699879234`},{0.3401540419319697`,0.21573870326749606`,0.19896297699879234`},{0.48084211962773643`,0.2941140499197574`,0.`}}
};

xy=Simplify[TrilinearToCartesian[Triangle[{{x1,y1},{x2,y2},{x3,y3}}],{α,β,γ}]/.Abs[x_]:>x]

Conic[{Sequence@@IdentityMatrix[3],{1,1,1},{a,b,c}}]

TrilinearEquation[BrocardInellipse]

xy=Append[Thread[{x,y}==Simplify[TrilinearToCartesian[t,{α,β,γ}]]],-a c α β+b c α β+a b α γ-b c α γ-a b β γ+a c β γ==0/.Thread[{a,b,c}->SideLengths[Evaluate[t]]]]

curve=Eliminate[N[xy,10],{α,β,γ}]

<<Graphics`ImplicitPlot`

Show[Graphics[{
{Green,ImplicitPlot[curve,{x,-2,2},DisplayFunction->Identity,Axes->False][[1]]},
t//N,
{Blue,Cartesian[Line[pt,#][t//N]]&/@IdentityMatrix[3]},
{Red,Cartesian[(Line@@#)[t//N]]&/@mysolns},
PointLabels[Join[
Transpose[{VertexPoints[t],{"A","B","C"}}],
{
{Incenter[t],"I",{Green,LabelOffset->{-.04,-.04}}},
{SymmedianPoint[t],"K",{Green,LabelOffset->{-.04,-.04}}},
{EhrmannCongruentSquaresPoint[t],"(Subscript[X, 1144])",Blue}
}
],PointSize[.025],LabelOffset->.04]
}],AspectRatio->Automatic,PlotRange->{{-.2,1.1},{-.1,.9}}]

Derivation

roots=Last/@List@@Roots[a^2/(a-L)+b^2/(b-L)+c^2/(c-L)==2Area/L,L,Cubics->False]

Table[ToSidelengths[roots]/.RandomTriangleRules[],{20}]

Root[-2 a Area b c+2 a Area b #1+2 a Area c #1+(a^2) b c #1+2 Area b c #1+a (b^2) c #1+a b (c^2) #1-2 a Area ((#1)^2)-(a^2) b ((#1)^2)-2 Area b ((#1)^2)-a (b^2) ((#1)^2)-(a^2) c ((#1)^2)-2 Area c ((#1)^2)-(b^2) c ((#1)^2)-a (c^2) ((#1)^2)-b (c^2) ((#1)^2)+(a^2) ((#1)^3)+2 Area ((#1)^3)+(b^2) ((#1)^3)+(c^2) ((#1)^3)&,1]//InputForm

t=Triangle[{{0,0},{1,0},{.3,.5}}];