Canonical Polygon

Author

Eric W. Weisstein
February 1, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Combinatorics/CanonicalPolygon.nb.

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

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

Additional Authors

Keith Schneider
From "Canonical Polygons" from The Wolfram Demonstrations Project.  http://demonstrations.wolfram.com/CanonicalPolygons/

Code

Steps={{0,1},{0,-1},
{1,0},{-1,0},
{1,1},{1,-1},{-1,1},{-1,-1}};
NoConsecVecsQ[veclist_]:=Piecewise[{{(!(veclist[[1]]==veclist[[2]]||veclist[[1]]==-veclist[[2]]))&&NoConsecVecsQ[Delete[veclist,1]],Length[veclist]>1}},True];
NewCoord[oldcoord_,vec_]:={oldcoord+(1/2)vec,oldcoord+vec};
CoordList[thelist_,veclist_]:=(Piecewise[{{thelist, Length[veclist]==0}, {CoordList[Join[thelist,NewCoord[Last[thelist],veclist[[1]]]],Delete[veclist,1]], Length[veclist]>0}}]);
NotSelfIntersectingPathQ[veclist_]:=Length[CoordList[{{0,0}},veclist]]-Length[Union[CoordList[{{0,0}},veclist]]]==0;
NotSelfIntersectingQ[veclist_]:=Length[CoordList[{{0,0}},veclist]]-Length[Union[CoordList[{{0,0}},veclist]]]==1;
ClosedQ[veclist_]:=Table[Plus@@Transpose[veclist][[i]],{i,1,2}]=={0,0};
NoSameFirstLastQ[veclist_]:=First[veclist]≠Last[veclist]&&First[veclist]≠-Last[veclist];
GoodPathQ[veclist_]:=NoConsecVecsQ[veclist]&&NotSelfIntersectingPathQ[veclist];
GoodLoopQ[veclist_]:=ClosedQ[veclist]&&NoSameFirstLastQ[veclist]&&NoConsecVecsQ[veclist]&&NotSelfIntersectingQ[veclist];
R=(({{0, -1}, {1, 0}}));
S=(({{1, 0}, {0, -1}}));
D4Mats=Flatten[Table[MatrixPower[R,i].MatrixPower[S,j],{i,1,4},{j,1,2}],1];
RevTrace[n_]:=RevTrace[n]=-Table[KroneckerDelta[i+j,n+1],{i,1,n},{j,1,n}];
RotMat[n_]:=RotMat[n]=Table[KroneckerDelta[Mod[j-i,n],1],{i,1,n},{j,1,n}];
ReverseMats[n_]:=ReverseMats[n]=Table[MatrixPower[RevTrace[n],i],{i,1,2}];
RotationMats[n_]:=RotationMats[n]=Table[MatrixPower[RotMat[n],i],{i,1,n}];
TracingMats[n_]:=TracingMats[n]=Flatten[Table[MatrixPower[RotMat[n],i].MatrixPower[RevTrace[n],j],{i,1,n},{j,1,2}],1];
PathEquivalenceClass[veclist_]:=Flatten[Table[ReverseMats[Length[veclist]][[k]].veclist.D4Mats[[j]],{j,1,8},{k,1,2}],1];
PathEqClassRep[veclist_]:=Sort[PathEquivalenceClass[veclist]][[1]];
EquivalenceClass[veclist_,n_]:=Flatten[Table[TracingMats[n][[l]].veclist.D4Mats[[j]],{j,1,8},{l,1,2*n}],1];
EqClassRep[veclist_,n_]:=Sort[EquivalenceClass[veclist,n]][[1]];
Paths[1]=Union[Table[{PathEqClassRep[Steps[[i]]]},{i,1,Length[Steps]}]];
PotentialPaths[n_]:=PotentialPaths[n]=Select[Flatten[Table[Append[Paths[n-1][[i]],Steps[[j]]],{i,1,Length[Paths[n-1]]},{j,1,Length[Steps]}],1],GoodPathQ];
Paths[n_]:=Paths[n]=Union[Table[PathEqClassRep[PotentialPaths[n][[i]]],{i,1,Length[PotentialPaths[n]]}]];
OneStepQ[veclist_]:=Norm[Last[CoordList[{{0,0}},veclist]]]==1||Norm[Last[CoordList[{{0,0}},veclist]]]==(Sqrt[2]);
OneStepPaths[n_]:=OneStepPaths[n]=Select[Paths[n-1],OneStepQ];
PotentialLoops[n_]:=PotentialLoops[n]=Select[Table[Append[OneStepPaths[n][[i]], -Last[CoordList[{{0,0}},OneStepPaths[n][[i]]]]],{i,1,Length[OneStepPaths[n]]}],GoodLoopQ];
Loops[1]:={}
Loops[n_]:=Loops[n]=Union[Table[EqClassRep[PotentialLoops[n][[i]],n],{i,1,Length[PotentialLoops[n]]}]]

Enumerate

Length/@(AllTheCPs=Table[Loops[i],{i,3,9}])//Timing

Length/@(AllTheCPs=Table[Loops[i],{i,10}])//Timing

Length/@(AllTheCPs=Table[Loops[i],{i,12}])//Timing

Length/@(AllTheCPs=Table[Loops[i],{i,13}])//Timing

Length/@(AllTheCPs=Table[Loops[i],{i,14}])//Timing

Ran overnight (I think ran out of memory)

Length/@(AllTheCPs=Table[Loops[i],{i,15}])//Timing

Graphic

Convex

offset[l_List,v_]:=#+v&/@l

path[l0_List]:=Module[{p={{0,0}},i,l},
l=l0 /. {n->{0,1},ne->{1,1},e->{1,0},se->{1,-1},s->{0,-1},sw->{-1,-1},w->{-1,0},nw->{-1,1}};
Do[AppendTo[p,p[[-1]]+l[[i]]],{i,Length[l]}];
p
]

p=path/@cp;

cp:={{e,s,nw},{e,s,w,n},{ne,se,sw,nw},{ne,e,sw,w},{ne,e,s,sw,nw},{ne,e,se,sw,w,nw},{e,se,s,w,nw,n},{n,ne,e,se,s,sw,w,nw}};

dx={1,1,0,1,0,0,0,0};
dy={0,0,-1,-1,0,0,1,0};

Show[Graphics[{
SquareGrid[{{3,-6},{20,1}}],
Thickness[.007],
Table[Line[p[[i+4j]]] /. Line[x_]:>Line[offset[x,4{i,-j}+{dx[[i+4j]],dy[[i+4j]]}]],{i,4},{j,0,1}]
},AspectRatio->Automatic]]

All from Kyrmse (Incomplete)

cop[3]:={{e,s,nw}}
cop[4]:={{e,s,w,n},{ne,se,sw,nw},{ne,e,sw,w}}
cop[5]:={{ne,e,s,sw,nw},{e,ne,s,sw,nw},{e,n,se,sw,nw}}
cop[6]:={{ne,e,se,sw,w,nw},{e,se,s,w,nw,n},{e,ne,se,w,sw,nw},{n,e,s,sw,w,ne},{e,ne,se,sw,w,nw}}
cop[7]:={{e,n,se,s,w,nw},{nw,e,se,sw,w,ne},{e,n,e,s,sw,nw},{e,nw,e,se,sw,nw}}

off[3]:={{1,-1}}
off[4]:={{1,0},{0,-1},{0,-1}}
off[5]:={{0,0},{0,0},{0,0}}
off[6]:={{0,0},{0,1},{0,0},{1,0},{0,0}}
off[7]:={{0,0},{1,0},{0,0},{0,0}}

Show[Graphics[{
SquareGrid[{{3,-30},{24,-12}}],
Thickness[.007],Table[
Line[offset[path[cop[j][[i]]],{4i,-4j}+off[j][[i]]]],
{j,3,7},{i,Length[cop[j]]}]
},AspectRatio->Automatic]
]

5All

All from Keith Schneider (correct)

Length/@(AllTheCPs=Table[Loops[i],{i,8}])//Timing

PlaceAtOrigin[l_]:=(#-Min/@Transpose[l])&/@l

ShiftX[l_,x_]:=(#+x)&/@l

PolygonRow[l_,wmax_:50,pad_:1]:=Module[{p=PlaceAtOrigin/@l,i0=1,i=1,x=0,polys={},n=Length[l]},
If[Length[p]===1,
polys={p},
While[i<n,
While[(x+=Max[p[[i]][[All,1]]])≤wmax&&i<n,i++];
AppendTo[polys,p[[i0;;i]]];
i0=i+1;x=0;
]
];
polys
]

PolygonArrayPlot[l_,wmax_:50,pad_:1]:=Module[{ps=Flatten[PolygonRow[#,wmax,pad]&/@l,1],widths,heights,i},
widths=Most/@Map[Max[#[[All,1]]]&,ps,{2}];
heights=Accumulate[(Max[#[[All,2]]]&/@(Flatten[#,1]&/@ps))+pad];
Table[MapIndexed[ShiftX[#,{Prepend[Accumulate[widths[[i]]+pad],0][[#2[[1]]]],-heights[[i]]}]&,ps[[i]]],{i,Length[ps]}]
]

AllTheCPs[[4]]

Length[%]

PolygonRow[AllTheCPs[[4]]]

Length/@%

Table[FoldList[Plus,{0,0},#]&/@AllTheCPs[[n]],{n,2,4}]

Graphics[{Red,Opacity[.7],Map[Polygon,PolygonArrayPlot[
Table[FoldList[Plus,{0,0},#]&/@AllTheCPs[[n]],{n,8}],
25,1],{2}]},GridLines->{Range[0,50],Range[2,-50,-1]},ImageSize->400]

Counts

seq={0,0,1,3,3,9,13,52,140,501,1763,6786,25571};

FindSequenceFunction/@NestList[Rest,seq,3]

FindLinearRecurrence/@NestList[Rest,seq,3]