Napoleon's theorem states that the centers of the three equilateral triangles constructed on the sides of any triangle are themselves the vertices of an equilateral triangle. The theorem is often attributed to Napoleon Bonaparte, but the problem had already been previously posed a number of times without any attribution to the French ruler (see e.g. Grünbaum's paper for more details).
There have been a number of previous Wolfram Demonstrations on Napoleon's theorem (e.g. this and this), but the code for the relevant Manipulate is simple enough (and apparently different enough from previous entries) to show off in this note:
Manipulate[Graphics[{{ColorData[97,1],Polygon[pt]},With[{sides=Partition[pt,2,1,1]},{{ColorData[97,3],Map[Polygon[Append[#,Mean[#]+Sqrt[3]Apply[EuclideanDistance,#]Normalize[Cross[#[[1]]-#[[2]]]]/2]]&,sides]},{Directive[FaceForm[],EdgeForm[Directive[AbsoluteThickness[4],ColorData[97,4]]]],Polygon[(Mean/@sides)+(EuclideanDistance@@@sides)(Normalize[Cross[#1-#2]]&@@@sides)/(2Sqrt[3])]}}]},PlotRange2.25],{{pt,N[CirclePoints[3]]},Locator}]
Out[]=
Somewhat less well-known is the generalization due to Barlotti: if a polygon with n sides is affine regular (i.e., the affine transformation of a regular polygon), the centers of the regular n-gons constructed from the sides are also the vertices of a regular n-gon. (More information can be found in the paper of Gerber, and the paper of Andreescu et al.) There is an applet demonstration of Napoleon-Barlotti in the Cut The Knot site, but it is also quite simple to write some code for this generalization.
Consider the following subroutine (the observant will notice similarities between this generalization and the original triangular case):
In[]:=
napoleonCenters[pts_?MatrixQ]:=Module[{n=Length[pts],lens,sides},sides=Partition[pts,2,1,1];lens=EuclideanDistance@@@sides;(Mean/@sides)+(lensCot[π/n]/2)(Normalize[Cross[#1-#2]]&@@@sides)]
Here is a demonstration of Napoleon-Barlotti for a manifestly affine regular polygon; I randomly generate a transformation matrix and use AffineTransform to transform the vertices of a regular polygon (here generated using CirclePoints):
With[{n=7,af=AffineTransform[RandomVariate[NormalDistribution[],{2,2}]]},Graphics[{{ColorData[97,1],Polygon[af[CirclePoints[n]]]},{FaceForm[],EdgeForm[ColorData[97,4]],Polygon[napoleonCenters[af[CirclePoints[n]]]]}}]]
Out[]=
(Note that I have elected to not display the regular polygons hanging off the sides of the starting polygon; it should not be too difficult to visualize those as well, if wanted.)
On the other hand, for a random convex polygon, we are not likely to see a regular n-gon from the Napoleon-Barlotti procedure:
poly=RandomPolygon[{"Convex",5}]
Out[]=
Polygon
Graphics[{{ColorData[97,1],poly},{FaceForm[],EdgeForm[ColorData[97,4]],Polygon[napoleonCenters[PolygonCoordinates[poly]]]}}]
Out[]=
We can use FindGeometricTransform to confirm that the starting polygon departs quite a fair bit from being affine regular, as evidenced by the not very small error:
{err,tf}=FindGeometricTransform[PolygonCoordinates[poly],CirclePoints[5],TransformationClass"Affine"]
Out[]=
0.121178,TransformationFunction
-0.308658 | 0.0354895 | 0.228734 |
-0.0144127 | -0.238281 | 0.201938 |
0. | 0. | 1. |
Manipulate[Graphics[{{ColorData[97,1],Polygon[pt]},{FaceForm[],EdgeForm[ColorData[97,4]],Polygon[napoleonCenters[pt]]}},PlotRange1.75],{{pt,N[CirclePoints[4]]},Locator,LocatorAutoCreateTrue},SaveDefinitionsTrue]
Out[]=
CITE THIS NOTEBOOK
CITE THIS NOTEBOOK
Napoleon-Barlotti theorem: affine regular polygons & regular n-gon centers
by J. M.
Wolfram Community, STAFF PICKS, March 14, 2025
https://community.wolfram.com/groups/-/m/t/3416619
by J. M.
Wolfram Community, STAFF PICKS, March 14, 2025
https://community.wolfram.com/groups/-/m/t/3416619