Star of Lakshmi

Author

Eric W. Weisstein
October 23, 2014

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

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

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

Definitions

ineq=(-(1/2)≤y≤1/2&&-(1/2)≤x≤1/2)||(-1≤Sqrt[2] (x-y)≤1&&-1≤Sqrt[2] (x+y)≤1);

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

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

reg2=Polygon[a{{0,1/Sqrt[2]},{-(1/12) Sqrt[2-Sqrt[2]] (1+Sqrt[5]),1/12 Sqrt[2+Sqrt[2]] (1+Sqrt[5])},{-(1/2),1/2},{-(1/12) Sqrt[2+Sqrt[2]] (1+Sqrt[5]),1/12 Sqrt[2-Sqrt[2]] (1+Sqrt[5])},{-(1/Sqrt[2]),0},{-(1/12) Sqrt[2+Sqrt[2]] (1+Sqrt[5]),-(1/12) Sqrt[2-Sqrt[2]] (1+Sqrt[5])},{-(1/2),-(1/2)},{-(1/12) Sqrt[2-Sqrt[2]] (1+Sqrt[5]),-(1/12) Sqrt[2+Sqrt[2]] (1+Sqrt[5])},{0,-(1/Sqrt[2])},{1/12 Sqrt[2-Sqrt[2]] (1+Sqrt[5]),-(1/12) Sqrt[2+Sqrt[2]] (1+Sqrt[5])},{1/2,-(1/2)},{1/12 Sqrt[2+Sqrt[2]] (1+Sqrt[5]),-(1/12) Sqrt[2-Sqrt[2]] (1+Sqrt[5])},{1/Sqrt[2],0},{1/12 Sqrt[2+Sqrt[2]] (1+Sqrt[5]),1/12 Sqrt[2-Sqrt[2]] (1+Sqrt[5])},{1/2,1/2},{1/12 Sqrt[2-Sqrt[2]] (1+Sqrt[5]),1/12 Sqrt[2+Sqrt[2]] (1+Sqrt[5])}}];

reg3=With[{sq=Rectangle[-{1,1}a/2,{1,1}a/2]},RegionUnion[sq,TransformedRegion[sq,RotationTransform[Pi/4]]]];

reg4=RegionUnion[Rectangle[-{1,1}/2,{1,1}/2],Rotate[Rectangle[-{1,1}/2,{1,1}/2],π/4]];

assum=a>0;

Graphics

Diagram

LaminaData["FilledStarOfLakshmi","Diagram"]

DiscretizeRegion

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

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

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

DiscretizeGraphics[r1=Rectangle[{-(1/2),-(1/2)},{(1/2),(1/2)}]]

DiscretizeGraphics[r2=Polygon[{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0},{0,-(1/(Sqrt[2]))},{(1/(Sqrt[2])),0}}]]

DiscretizeGraphics/@{r1,r2}

DiscretizeRegion[#[r1,r2]]&/@{RegionIntersection,RegionUnion}

Polygram

Show[Graphics[{Red,Polygram[8,2]}],AspectRatio->Automatic]

Graphics[{Polygram[8,2]}]

Region

Entity["Lamina","FilledStarOfLakshmi"]["Region"][1]

RegionPlot[%]

Construction

Graphics

Area[rect=Rectangle[-{1,1}/2,{1,1}/2]]

Area[TransformedRegion[rect,RotationTransform[Pi/4]]]

Graphics[{rect,Rotate[rect,π/4]},ImageSize->Small]

Intersection and Union

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

<<Graphics`InequalityGraphics`

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

ineq={(1/2)-y>0&&(1/2)+x>0&&(1/2)+y>0&&(1/2)-x>0,(1/2)+(x/(Sqrt[2]))-(y/(Sqrt[2]))>0&&(1/2)+(x/(Sqrt[2]))+(y/(Sqrt[2]))>0&&(1/2)-(x/(Sqrt[2]))+(y/(Sqrt[2]))>0&&(1/2)-(x/(Sqrt[2]))-(y/(Sqrt[2]))>0};

RegionPlot[Or@@ineq,{x,-.7,.7},{y,-.7,.7}]

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

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

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

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

Intersections

Polygram[8,2,1/Sqrt[2]]/.Line[x_]:>Norm/@(Subtract@@@Partition[x,2,1])

Polygram[8,2,1/Sqrt[2]]

Intersections[Line[{{(1/2),(1/2)},{-(1/2),(1/2)}}],Line[{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0}}]]//Simplify

Graphics[{Red,Line[{{(1/2),(1/2)},{-(1/2),(1/2)},{-(1/2),-(1/2)}}],Blue,Line[{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0},{0,-(1/(Sqrt[2]))}}]}]

Intersections[Line[{{-(1/2),(1/2)},{-(1/2),-(1/2)}}],Line[{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0}}]]//Simplify

N[%]

Show[Graphics[{
Line[{{(1/2),(1/2)},{-(1/2),(1/2)}}],
Line[{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0}}],
PointSize[.02],
{Red,pta=Point[{-(1/2),(1/2)}]},
{Green,ptb=Point[{(1/2)-(1/(Sqrt[2])),(1/2)}]},
{Blue,ptc=Point[{(1/2),(1/2)}]}
}],AspectRatio->Automatic]

ab=Norm[Subtract@@(First/@{pta,ptb})]

bm=Simplify[2((1/2)-ab)]

Simplify[2ab+bm]

Vertices

Graphics[{Black,Polygon[{{0,1/Sqrt[2]},{(1/2)-(1/(Sqrt[2])),(1/2)},{-(1/2),1/2},{-(1/2),(1/(Sqrt[2]))-(1/2)},{-(1/Sqrt[2]),0},{-(1/2),(1/2)-(1/(Sqrt[2]))},{-(1/2),-(1/2)},{(1/2)-(1/(Sqrt[2])),-(1/2)},{0,-(1/Sqrt[2])},{(1/(Sqrt[2]))-(1/2),-(1/2)},{1/2,-(1/2)},{(1/2),(1/2)-(1/(Sqrt[2]))},{1/Sqrt[2],0},{(1/2),(1/(Sqrt[2]))-(1/2)},{1/2,1/2},{(1/(Sqrt[2]))-(1/2),(1/2)}}],
Red,PointSize[.02],Point[{-(1/2),(1/2)-(1/(Sqrt[2]))}],
Opacity[.7],Blue,Polygon[{{(1/2),(1/2)},{-(1/2),(1/2)},{-(1/2),-(1/2)},{(1/2),-(1/2)},{(1/2),(1/2)}}],
Green,Polygon[{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0},{0,-(1/(Sqrt[2]))},{(1/(Sqrt[2])),0},{0,(1/(Sqrt[2]))}}]
},Axes->True]

Area[Polygon[{{0,1/Sqrt[2]},{(1/2)-(1/(Sqrt[2])),(1/2)},{-(1/2),1/2},{-(1/2),(1/(Sqrt[2]))-(1/2)},{-(1/Sqrt[2]),0},{-(1/2),(1/2)-(1/(Sqrt[2]))},{-(1/2),-(1/2)},{(1/2)-(1/(Sqrt[2])),-(1/2)},{0,-(1/Sqrt[2])},{(1/(Sqrt[2]))-(1/2),-(1/2)},{1/2,-(1/2)},{(1/2),(1/2)-(1/(Sqrt[2]))},{1/Sqrt[2],0},{(1/2),(1/(Sqrt[2]))-(1/2)},{1/2,1/2},{(1/(Sqrt[2]))-(1/2),(1/2)}}]]//FullSimplify

Properties

Region

Polygram[8,2,1/(Sqrt[2])]

1./(Sqrt[2])

Graphics[MapIndexed[Text[#2[[1]],#+.03{1,1}]&,p=Join[{{(1/2),(1/2)},{-(1/2),(1/2)},{-(1/2),-(1/2)},{(1/2),-(1/2)}},{{0,(1/(Sqrt[2]))},{-(1/(Sqrt[2])),0},{0,-(1/(Sqrt[2]))},{(1/(Sqrt[2])),0}}]]]

Norm[Subtract@@p[[{5,6}]]]

(1/2)(1/3)Csc[π/10]//FullSimplify

Graphics[{Polygram[8,2,1/(Sqrt[2])],Red,RegularPolygon[8,(1/6) (1+(Sqrt[5])),π/8]}]

Polygram[8,2,1/(Sqrt[2])][[All,1]]

RegularPolygon[8,(1/6) (1+(Sqrt[5])),π/8]

p=Join[Join@@Most/@Polygram[8,2,1/(Sqrt[2])][[All,1]],RegularPolygon[8,(1/6) (1+(Sqrt[5])),π/8][[1]]];

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

p[[{8,5}]]

Graphics[poly=Polygon[p[[{5,11,2,12,6,13,3,14,7,15,4,16,8,9,1,10}]]]]

poly//FunctionExpand//FullSimplify

Inequalities

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

ineq[x_,y_]:=(-(1/2)<y<(1/2)&&-(1/2)<x<(1/2))||(-1<(Sqrt[2]) (x-y)<1&&-1<(Sqrt[2]) (x+y)<1)

RegionPlot[ineq[x,y],{x,-1/(Sqrt[2]),1/(Sqrt[2])},{y,-1/(Sqrt[2]),1/(Sqrt[2])},MaxRecursion->5,AspectRatio->Automatic]

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

Area

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

Assuming[assum,Simplify@Area[reg]]

Assuming[assum,Simplify@Area[implreg]]

Assuming[assum,Simplify@Area[reg2]]

Assuming[assum,Simplify@Area[reg3]]

Assuming[assum,Simplify@Area[reg3/.a->1]]

Assuming[assum,Simplify@Area[reg4]]

reg=Entity["Lamina","FilledStarOfLakshmi"]["Region"][a]

Area[reg]

Area[reg/.a->1]//Factor

impreg=Entity["Lamina","FilledStarOfLakshmi"]["ImplicitRegion"][a]

impreg=ImplicitRegion[(Abs[y]≤a/2&&Abs[x]≤a/2)||(Abs[x-y]≤a/Sqrt[2]&&Abs[x+y]≤a/Sqrt[2]),{x,y}]

Area[impreg]

Simplify[%,a>0]

Assuming[a>0,Area[impreg]]

bug(338451)

AreaInertiaTensor

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

Centroid

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

Assuming[assum,Simplify@RegionCentroid[reg]]

Assuming[assum,Simplify@RegionCentroid[implreg]]

GeneralizedDiameter

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

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

Inequality

rect=Rectangle[-{1,1}/2,{1,1}/2];

regsq=TransformedRegion[rect,RotationTransform[Pi/4]];

RegionMember[regsq,{x,y}]

Assuming[assum,RegionMember[reg,{x,y}]]

RegionMember[reg/.a->1,{x,y}]//FullSimplify

RegionMember[implreg/.a->1,{x,y}]//FullSimplify

RegionMember[reg2/.a->1,{x,y}]//FullSimplify

RegionMember[reg3/.a->1,{x,y}]//FullSimplify

Perimeter

Entity["Lamina","FilledStarOfLakshmi"]["Perimeter"][a]

%//N

reg=Entity["Lamina","FilledStarOfLakshmi"]["Region"][1]

Perimeter[reg]

bug(338449)

Region[RegionBoundary[reg]]

Region[RegionBoundary[reg]]//ArcLength

N[%]

16 (1-2^(-1/2))//FullSimplify

reg=Entity["Lamina","FilledStarOfLakshmi"]["Region"][a]

RegionBoundary[reg]

Region[%]

...hang: bug(338448)

RadiiOfGyration

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

Length Distribution

Monte Carlo

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

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

Graphics[{{Red,Point[pts[[All,1]]]},{Blue,Point[pts[[All,2]]]}}]

(((((4-2 (Sqrt[2]))/((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]