Torus Cannibal

Author

Eric W. Weisstein
January 1, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Topology/TorusCannibal.nb.

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

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

Additional Authors

Code by Anton A. Antonov
February 27, 2002

Code

<<Graphics`Shapes`

RemovePlates[tr_,m_,n_,{colMin_,colMax_},{rowMin_,rowMax_}]:=
Module[{tr1},
tr1=Partition[tr,n];
tr1=Fold[MapAt[Drop[#1,{rowMin,rowMax}]&,#1,#2]&,tr1,Range[colMin,colMax]]
]/;Length[tr]==m*n;

RemovePlatesN[tr_,m_,n_,{colMin_,colMax_},{rowMin_,rowMax_}]:=
Module[{tr1,colRange},
colRange=If[colMin<0,Join[Range[colMin,-1],Range[1,colMax]],Range[colMin,colMax]];
tr1=Partition[tr,n];
If[rowMax>0,
tr1=Fold[MapAt[Drop[#1,{1,rowMax}]&,#1,#2]&,tr1,colRange];
];
tr1=Fold[MapAt[Drop[#1,{rowMin,-1}]&,#1,#2]&,tr1,colRange]
]/;Length[tr]==m*n&&rowMin<0&&rowMax≥0;

Plots

The straight part

The list of straight slides

m=31;n=17;
tr=Torus[1,0.5,m,n];

pnts=Flatten[tr/.Polygon[s_]->s,1];
maxX=Max[#1[[1]]&/@pnts];
minX=Min[#1[[1]]&/@pnts];
maxY=Max[#1[[2]]&/@pnts];
minY=Min[#1[[2]]&/@pnts];
maxZ=Max[#1[[3]]&/@pnts];
minZ=Min[#1[[3]]&/@pnts];
maxAll=Max[{{minZ,maxZ},{minX,maxX},{minY,maxY}}];minAll=Min[{{minZ,maxZ},{minX,maxX},{minY,maxY}}];

m2=Floor[m/2];n2=Floor[n/2];

tbl={RemovePlatesN[tr,m,n,{m2,m2},{-1,1}]};

tbl1=Table[RemovePlatesN[tr,m,n,{m2-i,m2+i},{-i-1,i}],{i,1,n/2-1}];tbl=Join[tbl,tbl1];

iLast=Floor[n/2-1];
tbl1={RemovePlatesN[tr,m,n,{m2-iLast,m2+iLast},{-iLast-1,iLast}]};tbl=Join[tbl,tbl1];

tbl1=Table[RemovePlatesN[tr,m,n,{m2-i,m2+i},{-iLast-2,iLast}],{i,iLast+1,m2-1,2}];tbl=Join[tbl,tbl1];

Checks

tbl1=RotateShape[RotateShape[#1,0,π/2,0],0,0,-π/2]&/@tbl;Show[Graphics3D[#1],ViewPoint->{1.300, -2.400, 2.000},PlotRange->{{minAll,maxAll},{minAll,maxAll},{minAll,maxAll}}]&/@tbl1;

Other slides

tbl1={RemovePlatesN[tr,m,n,{1,m},{-iLast-2,iLast}]};tbl=Join[tbl,tbl1];

The reverse part

The list of reverse slides

tblS=RotateShape[RotateShape[#1,0,π/2,0],0,0,-π/2]&/@tbl;
trLast=tbl[[-1]];

m=51;n=31;
tr=RotateShape[Torus[1,0.5,m,n],-π/2,0,0];

m2=Floor[m/2];n2=Floor[n/2];

tbl={tr};

Check for coincidence

tr1=TranslateShape[tr,{0,1,0}];Show[Graphics3D[{tr1,trLast}],ViewPoint->{1.300, -2.400, 2.000},PlotRange->{{minAll,maxAll},{minAll,maxAll+1},{minAll,maxAll}}];

iLast=Floor[n/2-1];tbl={RemovePlatesN[tr,m,n,{-m2-1,m2-1},{-iLast-2,iLast-1}]};

iLast=Floor[n/2-1];tbl=Table[RemovePlatesN[tr,m,n,{-m2-1+i,m2-1-i},{-iLast-2,iLast-1}],{i,1,m2,2}];

tbl1=TranslateShape[#1,{0,1,0}]&/@tbl;Show[Graphics3D[#1],ViewPoint->{1.300, -2.400, 2.000},PlotRange->{{minAll,maxAll},{minAll,maxAll+1},{minAll,maxAll}}]&/@tbl1;

Final

Compose

tblR=TranslateShape[#1,{0,1,0}]&/@tbl;

trVictim=TranslateShape[Torus[0.9,0.3,20,16],{0,1,0}];

Checks

tblF=Join[tblS,tblR];
Show[Graphics3D[#1],ViewPoint->{1.300, -2.400, 2.000},PlotRange->{{minAll,maxAll},{minAll,maxAll+1},{minAll,maxAll}}]&/@tblF;

Show[Graphics3D[{trVictim,tblF[[1]]}],ViewPoint->{1.300, -2.400, 2.000},PlotRange->{{minAll,maxAll},{minAll,maxAll+1},{minAll,maxAll}}];

The animation

tblF=Join[tblS,tblR];
movie=Show[Graphics3D[{EdgeForm[Hue[0.7]],#1,EdgeForm[Hue[1.]],trVictim}],ViewPoint->{-1.656, -2.118, 2.054},PlotRange->{{minAll,maxAll},{minAll,maxAll+1},{minAll,maxAll}}, Boxed->False]&/@tblF;//Timing

Length[movie]

Show[GraphicsArray[Partition[Take[movie,{1,27,2}],4]],GraphicsSpacing->-.2]

Export of the animation

<<Utilities`GIF`;

Export[gifs<>"toruscan.gif",movie,"GIF",ImageSize->300]//Timing