Polygon Triangle Picking

Author

Eric W. Weisstein
August 5, 2010

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputationalGeometry/PolygonTrianglePicking.nb.

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

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

Code

Alikoski[n_]:=Module[{ω=2Pi/n},
(9Cos[ω]^2+52Cos[ω]+44)/(36n^2Sin[ω]^2)
]
RegularPolygonArea[n_]:=(1/4)n (a^(2 ))Cot[(π/n)]

Table

Unit Area

Grid[RootReduce[Table[{n,area=Alikoski[n],N[area]},{n,3,10}]],Dividers->All,Alignment->{{Decimal,Center,Decimal},Automatic}]//TraditionalForm

Regular Polygon with Unit Edge Length

Grid[Table[{n,area=Alikoski[n]RegularPolygonArea[n],N[area/a^2]},{n,3,10}]//FullSimplify,Dividers->All,Alignment->{{Decimal,Center,Decimal},Automatic}]//TraditionalForm

Table[{n,TrigToExp[Alikoski[n]]},{n,3,15}]//RootReduce//Timing

v=Table[TrigToExp[Alikoski[n]],{n,3,20}]//RootReduce;//Timing

v=Table[TrigToExp[Alikoski[n]],{n,3,30}]//RootReduce;//Timing

Switch[#,
_Rational,1,
_?(FreeQ[#,Root]&),2,
_Root,Exponent[#[[1]][x],x]
]&/@v

Table[EulerPhi[n]/2,{n,3,30}]

2+Position[Table[EulerPhi[n]/2,{n,3,10^4}],1]//Flatten

Plot

Plot[Alikoski[n],{n,3,10},PlotStyle->Red,Epilog->{Red,PointSize[.025],Point/@MapIndexed[{2+#2[[1]],#1}&,Alikoski/@Range[3,10]]},
AxesLabel->TraditionalForm/@{n,Subscript[Overscript[A,"_"],n]}]

Limit

Limit[Alikoski[n],n->Infinity]

Triangulate

<<Calculus`Integration`
<<Graphics`InequalityGraphics`
<<Graphics`Colors`

PolygonTriangles[n_]:=Polygon[{{0,0},Sequence@@#}]&/@Partition[Through[{Cos,Sin}[2Pi #/n]]&/@Range[n],2,1,1]

Triangle

ineq[{x_,y_}]:=Inequalities[#,{x,y}]&/@PolygonTriangles[3]

ineq[{x,y}]

Show[MapIndexed[InequalityPlot[#1,{x},{y},AspectRatio->Automatic,DisplayFunction->Identity,Fills->{Red,Green,Blue}[[#2[[1]]]]]&,ineq[{x,y}]],DisplayFunction->$DisplayFunction
]

Area[Triangle[{{x1,y1},{x2,y2},{x3,y3}}]]

Normalization

Integrate[Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3}]

111

Timing[i1=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->4]]

Length[i111=Calculus`Integration`Private`DebugIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3}]]//Timing

i=i111;
Do[
Print[{n,TimeConstrained[i[[n]]/.HoldForm[Integrate[x__]]:>IntegrateWithAssumptions[x],60]//Timing}],
{n,Length[i]}
]

i=i111;
Do[
Print[{n,TimeConstrained[i[[n]]/.HoldForm[Integrate[x__]]:>IntegrateWithAssumptions[x],500]//Timing}],
{n,Length[i]}
]

112

Timing[i2=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[2]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->4]]

123

Timing[i3=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[2]]&&ineq[{x3,y3}][[3]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3]]

Combine Them

(((3i1+3i2+i3) )/((3 (Sqrt[3]))/64))((Sqrt[3])/12)

(((Sqrt[3])/4))^3

Square

ineq[{x_,y_}]:=Inequalities[#,{x,y}]&/@PolygonTriangles[4]

ineq[{x,y}]

Show[MapIndexed[InequalityPlot[#1,{x},{y},AspectRatio->Automatic,DisplayFunction->Identity,Fills->{Red,Green,Blue,Yellow}[[#2[[1]]]]]&,ineq[{x,y}]
],
DisplayFunction->$DisplayFunction
]

Normalization

Integrate[Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3}]

111

Timing[i1=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7,MaxPoints->10^6]]

Length[i111=Calculus`Integration`Private`DebugIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3}]]//Timing

i=i111;
Do[
Print[{n,TimeConstrained[i[[n]]/.HoldForm[Integrate[x__]]:>IntegrateWithAssumptions2[x],60]//Timing}],
{n,Length[i]}
]

i=i111;
Do[
Print[{n,TimeConstrained[i[[n]]/.HoldForm[Integrate[x__]]:>IntegrateWithAssumptions[x],300]//Timing}],
{n,Length[i]}
]

i=i111;
Do[
Print[{n,TimeConstrained[i[[n]]/.HoldForm[Integrate[x__]]:>IntegrateWithAssumptions2[x],300]//Timing}],
{n,Length[i]}
]

112

Timing[i2=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[2]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

113

Timing[i3=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[3]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

123

Timing[i4=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[2]]&&ineq[{x3,y3}][[3]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

Combine Them

(4i1+8i2+4i3+4i4)/8*2

11/144.

Solve[1==a/Sqrt[2],a]

(Sqrt[2])^2

Pentagon

ineq[{x_,y_}]:=Inequalities[#,{x,y}]&/@PolygonTriangles[5]

Show[MapIndexed[InequalityPlot[#1,{x},{y},AspectRatio->Automatic,DisplayFunction->Identity,Fills->{Red,Yellow,Green,Blue,Purple}[[#2[[1]]]]]&,ineq[{x,y}]
],
DisplayFunction->$DisplayFunction
]

Normalization

Integrate[Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3}]

NIntegrate[Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]//Timing

111

Timing[i1=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

Length[i111=Calculus`Integration`Private`DebugIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[1]]],{x1},{x2},{x3},{y1},{y2},{y3}]]//Timing

i=i111;
Do[
Print[{n,TimeConstrained[i[[n]]/.HoldForm[Integrate[x__]]:>IntegrateWithAssumptions2[x],60]//Timing}],
{n,Length[i]}
]

112

Timing[i2=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[2]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

113

Timing[i3=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[1]]&&ineq[{x3,y3}][[3]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

123

Timing[i4=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[2]]&&ineq[{x3,y3}][[3]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

124

Timing[i5=NIntegrate[(1/2) Abs[-x2 y1+x3 y1+x1 y2-x3 y2-x1 y3+x2 y3]Boole[ineq[{x1,y1}][[1]]&&ineq[{x2,y2}][[2]]&&ineq[{x3,y3}][[4]]],{x1},{x2},{x3},{y1},{y2},{y3},Method->QuasiMonteCarlo,PrecisionGoal->3,MaxPoints->10^7]]

Combine Them

{i1,i2,i3,i4,i5}

Solve[1==(1/10)a(Sqrt[50+10(Sqrt[5])]),a]

(5i1+10i2+10i3+5i4+5i5)0.1075071128139045` ((1/4)((((Sqrt[(10/(5+(Sqrt[5])))])))^2)(Sqrt[25+10(Sqrt[5])]))

(1/180)(9+2(Sqrt[5]))//N

%/%32

(5i1+10i2+10i3+5i4+5i5)0.1075071128139045`