Pentagram

Author

Eric W. Weisstein
January 25, 2019

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Polygons/Pentagram.nb.

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

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

Definitions

ineq=(2 a+5 x+3 Sqrt[5] x≥Sqrt[2 (5+Sqrt[5])] y&&((2 a+Sqrt[50+22 Sqrt[5]] y≥(5+Sqrt[5]) x&&Sqrt[5] a+2 Sqrt[5] x+2 Sqrt[5+2 Sqrt[5]] y≤a)||(Sqrt[5] a+2 Sqrt[5] x+2 Sqrt[5+2 Sqrt[5]] y≥a&&a+2 Sqrt[5] x≤Sqrt[5] a+2 Sqrt[5+2 Sqrt[5]] y&&2 Sqrt[5+2 Sqrt[5]] y≤a&&5 x+3 Sqrt[5] x+Sqrt[2 (5+Sqrt[5])] y≤2 a)))||(a+2 Sqrt[5] x≥Sqrt[5] a+2 Sqrt[5+2 Sqrt[5]] y&&2 a+(5+Sqrt[5]) x+Sqrt[50+22 Sqrt[5]] y≥0&&5 x+3 Sqrt[5] x+Sqrt[2 (5+Sqrt[5])] y≤2 a)||(Sqrt[2/(65+29 Sqrt[5])] a+Sqrt[5] y≥3 y&&((5 x+3 Sqrt[5] x+Sqrt[2 (5+Sqrt[5])] y≥2 a&&Sqrt[50-22 Sqrt[5]] x+y≤2 Sqrt[2/(65+29 Sqrt[5])] a+Sqrt[5] y)||(2 Sqrt[2/(65+29 Sqrt[5])] a+Sqrt[50-22 Sqrt[5]] x+Sqrt[5] y≥y&&2 a+5 x+3 Sqrt[5] x≤Sqrt[2 (5+Sqrt[5])] y)))||(2 Sqrt[5+2 Sqrt[5]] y≥a&&Sqrt[650-290 Sqrt[5]] a+10 Sqrt[5-2 Sqrt[5]] x+20 y≥10 Sqrt[5] y&&10 (Sqrt[5-2 Sqrt[5]] x+(-2+Sqrt[5]) y)≤Sqrt[650-290 Sqrt[5]] a);

implreg=ImplicitRegion[ineq,{x,y}];

assum=a>0;

verts=a{{1/2,1/2 Sqrt[1-2/Sqrt[5]]},{1/2 (-2+Sqrt[5]),1/2 Sqrt[1-2/Sqrt[5]]},{0,Root[1-5 #1^2+5 #1^4&,3]},{1-Sqrt[5]/2,1/2 Sqrt[1-2/Sqrt[5]]},{-(1/2),1/2 Sqrt[1-2/Sqrt[5]]},{1/4 (-3+Sqrt[5]),-(1/Sqrt[130+58 Sqrt[5]])},{1/4 (1-Sqrt[5]),Root[1-20 #1^2+80 #1^4&,1]},{0,Root[1-25 #1^2+5 #1^4&,2]},{1/4 (-1+Sqrt[5]),Root[1-20 #1^2+80 #1^4&,1]},{1/4 (3-Sqrt[5]),-(1/Sqrt[130+58 Sqrt[5]])}};

reg=Polygon[verts];

Polygon

?Winding*

Options[Polygon]

Graphics[Polygon[CirclePoints[5],{1,3,5,2,4}]]

Graphics[WindingPolygon[CirclePoints[5][[{1,3,5,2,4}]]]]

Graphics[WindingPolygon[CirclePoints[5][[{1,3,5,2,4}]],#]]&/@{"EvenOddRule","NonzeroRule","TwoRule"}

Plots

Diagram

LaminaData["FilledPentagram","Diagram"]

DiscretizeRegion

Block[{a=1},Show[DiscretizeRegion[#],Axes->True,Ticks->None]]&/@{reg,implreg}

Filling/Winding

Define a pentagon with tip-to-tip distance of (Sqrt[(1/2)(5+(Sqrt[5]))])

pentagram=Table[Through[{Sin,Cos}[4π k/5]],{k,5}];

EuclideanDistance@@@Partition[pentagram,2,1,1]//FullSimplify//Union

Area[Polygon[pentagram]]//FullSimplify

N[%]

pentagramlines=Line[Append[pentagram,pentagram[[1]]]];

wound=Table[WindingPolygon[pentagram,wrule],{wrule,{"EvenOddRule","NonzeroRule","TwoRule"}}];

pentagonfillings=Show[Graphics[{{LightBlue,#},pentagramlines}]]&/@wound

Area/@wound

%[[1]]+%[[3]]==%[[2]]

Polygram

Graphics[Polygon@@@Polygram[5,2,1,π/2]]

Polygon

Graphics[poly=Polygon[Table[Through[{Sin,Cos}[4π k/5]],{k,5}]]]

SimplePolygonPartition

polys=Graphics`PolygonUtils`SimplePolygonPartition[Polygon[Table[Through[{Sin,Cos}[4π k/5]],{k,5}]],FillingMethod->"OddEvenRule"];
Graphics[{EdgeForm[Brown],Yellow,Opacity[0.5],polys}]

polys=Graphics`PolygonUtils`SimplePolygonPartition[Polygon[Table[Through[{Sin,Cos}[4π k/5]],{k,5}]]];
Graphics[{EdgeForm[Brown],Yellow,Opacity[0.5],polys}]

Graphics[{
poly=Join@@Transpose[{(Sqrt[(1/10)(5-(Sqrt[5]))])Through[{Cos,Sin}[2π(#+1/4)/5]]&/@Range[0,4],
(Sqrt[(1/10)(25-11(Sqrt[5]))])Through[{Cos,Sin}[2π(#-1/4+1)/5]]&/@Range[0,4]}]//Join//Polygon
}]

FullSimplify[poly]

pts=FullSimplify[poly[[1]]];

Graphics[MapIndexed[{Point[#],Text[#2[[1]],#1+.04{1,1}]}&,pts]]

pts[[{9,3}]]//N

Mean[%]

Area (unit tip-to-tip length)

vars={a,b,r,R,ρ,x,y};
ColumnForm[solns=ToRules[Reduce[
And@@{
r^2+(b/2)^2==R^2,
2a+b==1,
r^2+(a+b/2)^2==ρ^2,
(ρ-r)^2+(b/2)^2==a^2,
(ρ+R+y)^2+x^2==1,
x^2+y^2==a^2,
(y+R)^2+x^2==ρ^2
}&&#>0&/@And@@vars,vars]
]//FullSimplify//ToRadicals]

N[solns]//Column

2a+b/.solns//FullSimplify

Unfilled pentagram

Tips only

pentagonfillings[[1]]

FullSimplify[5(1/2)b(ρ-r)/.solns]

N[%]

Filled pentagram

Tips Plus Central Pentagon

pentagonfillings[[3]]

FullSimplify[5(1/2)b(ρ-r)+Area[RegularPolygon[R,5]]/.solns]

N[%]

Circumscribed Pentagon Minus Triangles  (filled pentagram)

FullSimplify[Area[RegularPolygon[ρ,5]]-5 x y/.solns]

N[%]

Put Sqrt in numerator

((5(Sqrt[130-58 (Sqrt[5])]))/(Sqrt[Expand[(130+58 (Sqrt[5]))(130-58 (Sqrt[5]))]]))//ExpandAll

ByteCount/@{(1/4) (Sqrt[650-290 (Sqrt[5])]),(5/(Sqrt[130+58 (Sqrt[5])]))}

Simplify`SimplifyCount/@{(1/4) (Sqrt[650-290 (Sqrt[5])]),(5/(Sqrt[130+58 (Sqrt[5])]))}

FullSimplify[(1/4) (Sqrt[650-290 (Sqrt[5])])-(5/(Sqrt[130+58 (Sqrt[5])]))]

Equations

Inequalities

With[{R=(Sqrt[(1/10)(25-11(Sqrt[5]))])},Graphics[inner=Polygon[R Table[Through[{Cos,Sin}[2Pi n/5-π/2]],{n,0,4}]]]
]

With[{ρ=(Sqrt[(1/10)(5-(Sqrt[5]))]),R=(Sqrt[(1/10)(25-11(Sqrt[5]))])},Graphics[tips=Table[Polygon[{
R Through[{Cos,Sin}[2Pi n/5-π/2]],
R Through[{Cos,Sin}[2Pi (n+1)/5-π/2]], ρ Through[{Cos,Sin}[2Pi  n/5+π/5-π/2]]
}],{n,0,4}]]]

Graphics[{tips,inner}]

FullSimplify[Inequalities[inner,{x,y}]||Or@@(Inequalities[#,{x,y}]&/@tips)]

ToRadicals[%]

ineq[x_,y_]:=(2+(5+3 (Sqrt[5])) x≥(Sqrt[2 (5+(Sqrt[5]))]) y&&((2+(Sqrt[50+22 (Sqrt[5])]) y≥(5+(Sqrt[5])) x&&(Sqrt[5])+2 (Sqrt[5]) x+2 (Sqrt[5+2 (Sqrt[5])]) y≤1)||((Sqrt[5])+2 (Sqrt[5]) x+2 (Sqrt[5+2 (Sqrt[5])]) y≥1&&1+2 (Sqrt[5]) x≤(Sqrt[5])+2 (Sqrt[5+2 (Sqrt[5])]) y&&2 (Sqrt[5+2 (Sqrt[5])]) y≤1&&5 x+3 (Sqrt[5]) x+(Sqrt[2 (5+(Sqrt[5]))]) y≤2)))||(1+2 (Sqrt[5]) x≥(Sqrt[5])+2 (Sqrt[5+2 (Sqrt[5])]) y&&2+(5+(Sqrt[5])) x+(Sqrt[50+22 (Sqrt[5])]) y≥0&&(5+3 (Sqrt[5])) x+(Sqrt[2 (5+(Sqrt[5]))]) y≤2)||((Sqrt[(2/(65+29 (Sqrt[5])))])+(Sqrt[5]) y≥3 y&&(((5+3 (Sqrt[5])) x+(Sqrt[2 (5+(Sqrt[5]))]) y≥2&&-2 (Sqrt[(2/(65+29 (Sqrt[5])))])+(Sqrt[50-22 (Sqrt[5])]) x+y≤(Sqrt[5]) y)||(2 (Sqrt[(2/(65+29 (Sqrt[5])))])+(Sqrt[50-22 (Sqrt[5])]) x+(Sqrt[5]) y≥y&&2+(5+3 (Sqrt[5])) x≤(Sqrt[2 (5+(Sqrt[5]))]) y)))||(2 (Sqrt[5+2 (Sqrt[5])]) y≥1&&(Sqrt[650-290 (Sqrt[5])])+10 (Sqrt[5-2 (Sqrt[5])]) x≥10 (-2+(Sqrt[5])) y&&10 ((Sqrt[5-2 (Sqrt[5])]) x+(-2+(Sqrt[5])) y)≤(Sqrt[650-290 (Sqrt[5])]))

Simplify[ineq[x,y]/.{x->x/a,y->y/a},a>0]

RegionPlot[ineq[x,y],{x,-.5,.5},{y,-.5,.6},MaxRecursion->5,AspectRatio->Automatic]

Properties

Area

Area

Assuming[assum,FullSimplify[Area[reg/.a->1]]]//Timing

Assuming[assum,FullSimplify[Area[implreg]]]//Timing

Assuming[assum,FullSimplify[Area[implreg/.a->1]]]//Timing

NIntegrate

NIntegrate[Boole[ineq[x,y]],{x,-.5,.5},{y,-.5,.6},Method->"QuasiMonteCarlo",PrecisionGoal->3,MaxPoints->10^7]//Timing

(1/4)(Sqrt[650-290(Sqrt[5])])//N

RegionMeasure

Assuming[assum,FullSimplify[RegionMeasure[reg/.a->1]]]//Timing

Assuming[assum,FullSimplify[RegionMeasure[implreg/.a->1]]]//Timing

Integrate

Integrate[Boole[ineq[x,y]],{x,-∞,∞},{y,-∞,∞}]//FullSimplify//Timing

FullSimplify[(5/(Sqrt[130+58 (Sqrt[5])]))-(1/4)(Sqrt[650-290(Sqrt[5])])]

AreaInertiaTensor

Integrate[AreaInertiaTensor[{x,y}]Boole[ineq[x,y]],{x,-∞,∞},{y,-∞,∞}]//FullSimplify//Timing

Centroid

NIntegrate

NIntegrate[{x,y}Boole[ineq[x,y]],{x,-.5,.5},{y,-.5,.6},Method->"QuasiMonteCarlo",PrecisionGoal->3,MaxPoints->10^7]//Timing

Integrate

Integrate[{x,y}Boole[ineq[x,y]],{x,-∞,∞},{y,-∞,∞}]//Timing

FullSimplify[Last[%22]]

RegionCentroid

Assuming[assum,FullSimplify[RegionCentroid[reg/.a->1]]]

Assuming[assum,FullSimplify[RegionCentroid[implreg/.a->1]]]

Circumradius

Show[{
RegionPlot[ineq[x,y],{x,-.55,.55},{y,-.55,.55},MaxRecursion->6,AspectRatio->Automatic],
Graphics[Circle[{0,0},Sqrt[1/10 (5-Sqrt[5])]]]
}]

Dimensions

vars={a,b,r,R,ρ,x,y};
ColumnForm[solns=ToRules[Reduce[
And@@{
r^2+(b/2)^2==R^2,
2a+b==1,
r^2+(a+b/2)^2==ρ^2,
(ρ-r)^2+(b/2)^2==a^2,
(ρ+R+y)^2+x^2==1,
x^2+y^2==a^2,
(y+R)^2+x^2==ρ^2
}&&#>0&/@And@@vars,vars]
]//ToRadicals]

solns//N

FullSimplify[a/b/.solns]

Show[Graphics[{
{Thickness[.01],Polygram[5,2,ρ,Pi/10]},
Line[{{0,0},ρ Through[{Cos,Sin}[Pi/10]]}],
Line[{{0,ρ},{0,-x-R},{y,-x-R}}],
Line[{{0,0},R Through[{Cos,Sin}[3Pi/10]]}],
Dashing[{.02}],Circle[{0,0},ρ]
}/.solns],
AspectRatio->Automatic]

EdgeLengths

s=FullSimplify[Norm/@(Subtract@@@Partition[verts,2,1,1]),assum]

GeneralizedDiameter

FullSimplify[2a+b/.{a->(1/2)(3-(Sqrt[5])),b->(Sqrt[5])-2}]

Inradius

Show[{
RegionPlot[ineq[x,y],{x,-.5,.5},{y,-.5,.6},MaxRecursion->5,AspectRatio->Automatic],
Graphics[Circle[{0,0},1/2 Sqrt[1/5(5-2Sqrt[5])]]]
}]

Perimeter

Total[s]//FullSimplify

10 (1/2)(3-(Sqrt[5]))

RadiiOfGyration

FullSimplify[(Sqrt[((Tr[{{(41/(24 (Sqrt[13498+(30182/(Sqrt[5]))]))),0},{0,(41/(24 (Sqrt[13498+(30182/(Sqrt[5]))])))}},List])/(5/(Sqrt[130+58 (Sqrt[5])])))])]

Pentagram point and line picking

Monte Carlo

maxx=(1/2)(3-(Sqrt[5]))+(1/2)((Sqrt[5])-2);
minx=-maxx;
maxy=(Sqrt[(1/10)(5-(Sqrt[5]))]);
miny=-((1/2)(Sqrt[(1/2)(25-11(Sqrt[5]))])+(Sqrt[(1/10)(25-11(Sqrt[5]))]));

Length[pts=Select[Table[{RandomReal[{minx,maxx}],RandomReal[{miny,maxy}]},{10^4},{2}],And@@ineq@@@#&]]//Timing

Graphics[Point[Take[Flatten[pts,1],All]]]

((((((1/4)(Sqrt[650-290(Sqrt[5])]))/((maxx-minx)(maxy-miny)))))^2)//N

Through[{Min,Mean,Max}[ds=Norm/@(Subtract@@@pts)]]

Histogram[ds]

Length[pts=Select[Table[{RandomReal[{minx,maxx}],RandomReal[{miny,maxy}]},{10^6},{2}],And@@ineq@@@#&]]//Timing

Through[{Min,Mean,Max}[ds=Norm/@(Subtract@@@pts)]]

Histogram[ds]

Golden pentagram

Pentagram[s_,{x_,y_}]:=Module[{i,p=2Pi/5,h=-.25},
		{
		Line[Table[{x,y}+s{Cos[(i+h)p],Sin[(i+h)p]},{i,0,10,2}]],
		Line[Table[{x,y}+s{Cos[(i+h)p],Sin[(i+h)p]},{i,0,5}]]
			}
];

PentagramSeries[n_]:=Module[
		{c={-Sqrt[50+22Sqrt[5]]/4,(1+Sqrt[5])/4},g=1/GoldenRatio,k,
		p=2Pi/5},
		Table[Pentagram[g^k,{{Cos[p i],Sin[p i]},{-Sin[p i],Cos[p i]}}.c(1-g^k)],{k,0,n},{i,0,4}]
]

Show[GraphicsArray[{
			Show[Graphics[PentagramSeries[0]],
	AspectRatio->Automatic,PlotRange->All,DisplayFunction->Identity],
	Show[Graphics[PentagramSeries[10]],
	AspectRatio->Automatic,PlotRange->All,DisplayFunction->Identity]
		}]]