Hexagram

Author

Eric W. Weisstein
May 10, 2020

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

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

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

Deifnitions

ineq=(Sqrt[3] a+3 Sqrt[3] x+3 y≥0&&3 Sqrt[3] x≤Sqrt[3] a+3 y&&6 y≤Sqrt[3] a)||(Sqrt[3] a+6 y≥0&&3 (Sqrt[3] x+y)≤Sqrt[3] a&&Sqrt[3] (a+3 x)≥3 y);

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

reg=Polygon[a{{0,1/Sqrt[3]},{-(1/6),1/(2 Sqrt[3])},{-(1/2),1/(2 Sqrt[3])},{-(1/3),0},{-(1/2),-(1/(2 Sqrt[3]))},{-(1/6),-(1/(2 Sqrt[3]))},{0,-(1/Sqrt[3])},{1/6,-(1/(2 Sqrt[3]))},{1/2,-(1/(2 Sqrt[3]))},{1/3,0},{1/2,1/(2 Sqrt[3])},{1/6,1/(2 Sqrt[3])}}];

reg2=RegionUnion@@(Triangle/@Transpose[Partition[a{{0,1/Sqrt[3]},{-(1/6),1/(2 Sqrt[3])},{-(1/2),1/(2 Sqrt[3])},{-(1/3),0},{-(1/2),-(1/(2 Sqrt[3]))},{-(1/6),-(1/(2 Sqrt[3]))},{0,-(1/Sqrt[3])},{1/6,-(1/(2 Sqrt[3]))},{1/2,-(1/(2 Sqrt[3]))},{1/3,0},{1/2,1/(2 Sqrt[3])},{1/6,1/(2 Sqrt[3])}},4]][[{1,3}]]);

assum=a>0;

Plots

Diagram

LaminaData["FilledHexagram","Diagram"]

DiscretizeRegion

Block[{a=1},Show[DiscretizeRegion[reg],ImageSize->Small]]

Block[{a=1},Show[DiscretizeRegion[reg2],ImageSize->Small]]

Block[{a=1},Show[DiscretizeRegion[implreg],ImageSize->Small]]

Line

Graphics[{Red,Polygram[6,2]}]

Filled

Graphics[Polygon@@@Polygram[6,2,1/(Sqrt[3]),Pi/2]]

Annotated Diagram

ClosedLine[l_List?MatrixQ]:=Line[Append[l,First[l]]]

Hexagram=ClosedLine/@Transpose[Partition[Through[{Sin,Cos}[Pi #/3]]&/@Range[0,5],2]];

Show[GraphicsArray[
Graphics[
#,AspectRatio->Automatic]&/@{
Hexagram,
{
{Red,Circle[{0,0},1]},
{Blue,Circle[{0,0},1/Sqrt[3]]},
{Green,Circle[{0,0},1/2]},
Hexagram
}
}]]

RegionPlot

Block[{a=1},RegionPlot[ineq,{x,-a,a},{y,-a,a},AspectRatio->Automatic]]

Area

Map[Norm,Map[Subtract@@#&,(Partition[#,2,1]&/@First/@Polygram[6,2,1/(Sqrt[3])]),{2}],{2}]//FullSimplify

ineq=Inequalities[#,{x,y}]&/@Polygon@@@Polygram[6,2,1/(Sqrt[3]),Pi/2]

Show[GraphicsArray[Block[{$DisplayFunction=Identity},InequalityPlot[#@@ineq,{x,-∞,∞},{y,-∞,∞},Ticks->None,PlotRange->.6{{-1,1},{-1,1}}]&/@{And,Or}
]]]

Integrate[Boole[And@@ineq],{x,-∞,∞},{y,-∞,∞}]

Integrate[Boole[Or@@ineq],{x,-∞,∞},{y,-∞,∞}]

Unicursal Hexagram

Show[Graphics[{
Text[#,1.1Through[{Cos,Sin}[2Pi #/6]]]&/@Range[6],
Circle[{0,0},1],
{Red,
Line[Through[{Cos,Sin}[2Pi #/6]]&/@{1,4,6,2,5,3,1}]
}
}],AspectRatio->Automatic]

Equation

Inequalities

FullSimplify[Or@@{(1/(2 (Sqrt[3])))+(((Sqrt[3]) x)/2)+(y/2)>0&&(1/(2 (Sqrt[3])))-(((Sqrt[3]) x)/2)+(y/2)>0&&(1/(2 (Sqrt[3])))-y>0,(1/(2 (Sqrt[3])))+y>0&&(1/(2 (Sqrt[3])))-(((Sqrt[3]) x)/2)-(y/2)>0&&(1/(2 (Sqrt[3])))+(((Sqrt[3]) x)/2)-(y/2)>0}]

ineq[x_,y_]:=((1/(Sqrt[3]))+(Sqrt[3]) x+y>0&&(Sqrt[3]) x<(1/(Sqrt[3]))+y&&6 y<(Sqrt[3]))||((Sqrt[3])+6 y>0&&3 ((Sqrt[3]) x+y)<(Sqrt[3])&&(Sqrt[3]) (1+3 x)>3 y)

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

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

Filled Hexagram Properties

Area

Area

Assuming[assum,Simplify@Area[reg]]

Assuming[assum,Simplify@Area[reg2]]

Assuming[assum,Simplify@Area[implreg]]

Integrate

Area[ineq[x,y],{x,y}]

2 6(1/4)(Sqrt[3])((((1/3)))^2)

NIntegrate

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

RegionMeasure

Assuming[assum,Simplify@RegionMeasure[reg]]

AreaInertiaTensor

AreaInertiaTensor[ineq[x,y],{x,y}]

Centroid

Integrate

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

RegionCentroid

Assuming[assum,Simplify@RegionCentroid[implreg]]

Circumradius

Norm/@Flatten[First/@{Line[{{-(1/2),(1/(2 (Sqrt[3])))},{0,-(1/(Sqrt[3]))},{(1/2),(1/(2 (Sqrt[3])))},{-(1/2),(1/(2 (Sqrt[3])))}}],Line[{{-(1/2),-(1/(2 (Sqrt[3])))},{(1/2),-(1/(2 (Sqrt[3])))},{0,(1/(Sqrt[3]))},{-(1/2),-(1/(2 (Sqrt[3])))}}]},1]//Union

1./(Sqrt[3])

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

GeneralizedDiameter

in=ineq[x1,y1]&&ineq[x2,y2]

Maximize[{Sqrt[(x1-x2)^2+(y1-y2)^2],in},{x1,x2,y1,y2}]//Timing

Perimeter

2/3 6

RadiiOfGyration

FullSimplify[RadiiOfGyration[ineq[x,y],{x,y}]]//Timing

Region

Polygram[6,2,1/(Sqrt[3]),Pi/2]

1./(Sqrt[3])

RegularPolygon[3,1,π/6]

Graphics[{RegularPolygon[3,1,π/6],Red,RegularPolygon[3,1,-π/6],Blue,RegularPolygon[6,1/(Sqrt[3])]}]

p=Flatten[{RegularPolygon[3,1,π/6],RegularPolygon[3,1,-π/6],RegularPolygon[6,1/(Sqrt[3])]}[[All,1]],1]

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

n=Norm[Subtract@@p[[{1,3}]]]

Graphics[poly=Polygon[p[[{5,9,2,10,6,11,3,12,4,7,1,8}]]/n]]

poly

Length Distribution

Monte Carlo

maxx=(1/2);
minx=-maxx;
maxy=(1/(Sqrt[3]));
miny=-maxy;

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

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

(((((1/(Sqrt[3]))/((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]

3D

Weird front/back behavior asked about on l-graphics 2020-05-10

Take[2{#1,#2,0}&@@@(v1={{(Sqrt[3]),0,(1/2)},{((Sqrt[3])/2),(1/2),(1/2)},{((Sqrt[3])/2),(3/2),(1/2)},{0,1,(1/2)},{-((Sqrt[3])/2),(3/2),(1/2)},{-((Sqrt[3])/2),(1/2),(1/2)},{-(Sqrt[3]),0,(1/2)},{-((Sqrt[3])/2),-(1/2),(1/2)},{-((Sqrt[3])/2),-(3/2),(1/2)},{0,-1,(1/2)},{((Sqrt[3])/2),-(3/2),(1/2)},{((Sqrt[3])/2),-(1/2),(1/2)},{(Sqrt[3]),0,-(1/2)},{((Sqrt[3])/2),(1/2),-(1/2)},{((Sqrt[3])/2),(3/2),-(1/2)},{0,1,-(1/2)},{-((Sqrt[3])/2),(3/2),-(1/2)},{-((Sqrt[3])/2),(1/2),-(1/2)},{-(Sqrt[3]),0,-(1/2)},{-((Sqrt[3])/2),-(1/2),-(1/2)},{-((Sqrt[3])/2),-(3/2),-(1/2)},{0,-1,-(1/2)},{((Sqrt[3])/2),-(3/2),-(1/2)},{((Sqrt[3])/2),-(1/2),-(1/2)}}),12]

v={{2 (Sqrt[3]),0,0},{(Sqrt[3]),1,0},{(Sqrt[3]),3,0},{0,2,0},{-(Sqrt[3]),3,0},{-(Sqrt[3]),1,0},{-2 (Sqrt[3]),0,0},{-(Sqrt[3]),-1,0},{-(Sqrt[3]),-3,0},{0,-2,0},{(Sqrt[3]),-3,0},{(Sqrt[3]),-1,0}};

Graphics3D[{FaceForm[Green,Red],Polygon[#]}]&/@{v,Reverse[v]}

Graphics3D[{FaceForm[Green,Red],Polygon[#]}]&/@NestList[RotateRight,v,11]//Take[#,8]&

Graphics3D[{FaceForm[Green,Red],Polygon[#]}]&/@NestList[RotateRight,Reverse[v],11]//Take[#,8]&