Inner Inscribed Squares Triangle

Author

Eric W. Weisstein
November 8, 2005

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

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

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

Internally Externally

p1={((-2Area+ a c Cos[B])/a),c Cos[A],-c};
p2={c Cos[B],((-2Area+b c Cos[A])/b),-c};

ac=Intersections[Line[p2,{0,0,1}],Line[{0,1,0},{1,0,0}]]

ab=Intersections[Line[p1,{0,0,1}],Line[{0,1,0},{1,0,0}]]

l=PowerExpand[Sqrt[Factor[Distance[ac,ab]^2]]]

ca=Factor/@ToSidelengths[{α,β,γ}/.Solve[{Distance[{α,β,γ},ab]^2==l^2,Distance[{α,β,γ},ac]^2==2l^2,a α+b β+c γ==2Area},{α,β,γ}]];

ba=Factor/@ToSidelengths[{α,β,γ}/.Solve[{Distance[{α,β,γ},ac]^2==l^2,Distance[{α,β,γ},ab]^2==2l^2,a α+b β+c γ==2Area},{α,β,γ}]];

t=Triangle[{{0,0},{1,0},{.2,.7}}];
g1=Show[Graphics[{
{Green,
Cartesian[#[t]]&/@{Line[ac,p2],Line[p1,ab],Line[ba[[1]],{0,1,0}],Line[{1,0,0},ca[[1]]]}
},
t,
{Blue,ErectPolygons[t,4,-1][[3]]},
{Red,
Line[Coordinates[Cartesian[#[t]]]&/@{ac,ab,ca[[1]],ba[[1]],ac}]
},
PointLabels[Join[
Transpose[{VertexPoints[t],{"A","B","C"}}],
{
{Cartesian[p1[t]],"(Subscript[P, 1])",Blue},
{Cartesian[p2[t]],"(Subscript[P, 2])",Blue},
{Cartesian[ac[t]],"\!\(
\*InterpretationBox[\(A\_C\%\(\"\<-\>\"\)\),\nSubsuperscript[ A, C, \"-\"],\nEditable->False]\)",Red},
{Cartesian[ab[t]],"\!\(
\*InterpretationBox[\(A\_B\%\(\"\<-\>\"\)\),\nSubsuperscript[ A, B, \"-\"],\nEditable->False]\)",Red},
{Cartesian[ca[[1]][t]],"\!\(
\*InterpretationBox[\(C\_a\%\(\"\<-\>\"\)\),\nSubsuperscript[ C, a, \"-\"],\nEditable->False]\)",Red},
{Cartesian[ba[[1]][t]],"\!\(
\*InterpretationBox[\(B\_a\%\(\"\<-\>\"\)\),\nSubsuperscript[ B, a, \"-\"],\nEditable->False]\)",Red},
{Cartesian[{(SB-S)/a,(SA-S)/b,c}[t]],"(SuperMinus[Z])",Red}
}
]]
}],AspectRatio->Automatic,PlotRange->All]

{{a,(SC-S)/b,(SB-S)/c},{(SC-S)/a,b,(SA-S)/c},{(SB-S)/a,(SA-S)/b,c}}

bigsquares=NestList[RotateRight/@(#/.{a->b,b->c,c->a,A->B,B->C,C->A})&,{ac,ab,ca[[1]],ba[[1]],ac},2];

littlesquares=NestList[RotateRight/@(#/.{a->b,b->c,c->a,A->B,B->C,C->A})&,{{1,0,0},{0,1,0},p2,p1,{1,0,0}},2];

t=Triangle[{{0,0},{1,0},{.3,.7}}];
g2=Show[Graphics[{
{Blue,Line[Cartesian[#[t]][[1]]&/@#]&/@bigsquares},
{Green,Line[Cartesian[#[t]][[1]]&/@#]&/@littlesquares},
t,
{Red,InscribedSquaresTriangle[2][t]},
PointLabels[Join[
Transpose[{VertexPoints[t],{"A","B","C"}}],
Append[#,Red]&/@Transpose[{VertexPoints[InscribedSquaresTriangle[2][t]],{"(SuperMinus[X])","(SuperMinus[Y])","(SuperMinus[Z])"}}]
],LabelOffset->.2,PointSize[.015]]
}],AspectRatio->Automatic,PlotRange->All]

Show[GraphicsArray[{g1,g2}],ImageSize->500]

persp=Factor[Perspector[ReferenceTriangle,InscribedSquaresTriangle[2]]]

IncidentCenters[Take[KimberlingCenters,{450,500}],persp]

TriangleName[InscribedSquaresTriangle[2]]

Area

Factor[Area[InscribedSquaresTriangle[1]]]

FullSimplify[Factor[ToSidelengths[%]],TriangleQ[]]

Factor[Refine[ToAngles[%],TriangleQ[]&&Area>0]]

%//TraditionalForm

Side Lengths

FullSimplify[Sqrt[FullSimplify[ToSidelengths[Factor[SideLengths[InscribedSquaresTriangle[1]]^2]],TriangleQ[]]],TriangleQ[]]

Refine[ToAngles[%],Area>0&&TriangleQ[]]

%//ColumnForm//TraditionalForm

f=Factor[Coefficient[eqn=((b^2)+(c^2)-4 Δ) (a^4)-2 ((((b^2)-(c^2)))^2) (a^2)+((((b^2)-(c^2)))^2) ((b^2)+(c^2)+4 Δ),Δ]]

Factor[eqn-Δ f]

ToAngles[%]

Centers

(pts={#,KimberlingLookup[#[InscribedSquaresTriangle[1]]]}&/@Take[KimberlingCenters,100]);//Timing

{#[[1]],Name[#[[1]]],X[#[[2,1]]],Name[X[#[[2,1]]]]}&/@Cases[pts,_?(Last[#]=!={}&)]//TableForm