This is a sangaku geometry problem with simple look but with quite lengthy algebra if you follow the video.
Out[]=
I think it is even harder to create more than 2 circles with manual computation. With WL’s FindRoot function we can find general cases quite fast and numerically stable.
Solution to the original problem
Solution to the original problem
Assume we have a unit square with its left-bottom corner sitting at . The point {x,0} divides the bottom side into two subdivisions. We are going to solve for the exact location of the point so that the and share the incircles with the same size:
{0,0}
Triangle[{{0,0},{x,0},{1,1}}]
Triangle[{{1,0},{x,0},{1,1}}]
Solve[TriangleMeasurement[Triangle[{{0,0},{x,0},{1,1}}],"Inradius"]==TriangleMeasurement[Triangle[{{1,0},{x,0},{1,1}}],"Inradius"],x,PositiveReals]
Out[]=
x
Surprisingly this problem can be solved symbolically and simplified to a nice expression:
sol=FullSimplify[x/.%[[1]]]
Out[]=
1-
-+
1
2
1
2
Visualize the solution altogether with the triangles and their incircles:
In[]:=
tri1=Triangle[{{0,0},{sol,0},{1,1}}];tri2=Triangle[{{1,0},{sol,0},{1,1}}];
Graphics[{Line[{{0,0},{1,1}}],Line[{{1,1},{sol,0}}],{Transparent,EdgeForm[Thick],Rectangle[]},{Green,TriangleConstruct[tri1,"Incircle"],TriangleConstruct[tri2,"Incircle"]}/.Circle->Disk,{Dashed,InfiniteLine[{0,TriangleMeasurement[tri1,"Inradius"]*2},{1,0}]}}]
Out[]=
More than 2 incircles
More than 2 incircles
Use FindRoot to effectively generate Numerically generate many incircles of the same radii.Instead of using subdivision point, the variables used here are the length of bases of the subdivisions of the triangles with same inradii. So they have an constraint that their sum is equal to one.
In[]:=
Clear[incirlces]
In[]:=
incirlces[n_Integer]:=Module[{vars,eq},If[n<=1,Abort[],vars={0}~Join~Table[Unique["mySymbol"],{n}];eq={Equal@@Table[TriangleMeasurement[Triangle[{{v[[1]],0},{v[[2]],0},{1,1.}}],"Inradius"],{v,Partition[Accumulate@vars,2,1]}],Total[vars]==1};vars/.With[{eq1=eq,vars1=vars},FindRoot[eq1,Transpose[{Rest@vars1,ConstantArray[1/n,n]}]]]]]
Say we would like to have 6 identical incircles:
sol=incirlces[6]
Out[]=
{0,0.197681,0.180337,0.166892,0.157054,0.150611,0.147424}
Use the subdivisions to generate 6 triangles. The vertices on the bases are the accumulated total of the subdivitions:
triList=Table[Triangle[{{v[[1]],0},{v[[2]],0},{1,1}}],{v,Partition[Accumulate@sol,2,1]}];
Put the triangles and corresponding incircles altogether:
Graphics[{{Transparent,{EdgeForm[Thick],Rectangle[]},Transparent,{EdgeForm[Thin],triList}},{Green,TriangleConstruct[#,"Incircle"]&/@triList}/.Circle->Disk,{Dashed,InfiniteLine[{0,TriangleMeasurement[triList[[1]],"Inradius"]*2},{1,0}]}},PlotRange{{-0.1,1.1},{-0.05,1.05}}]
Out[]=
Discard the internal symbols
In[]:=
Remove["mySymbol*"]