0. small programs

Clear["*Global`*"]

(*t=τ(golden ratio). For "show", just add //N, then all numbers turn to N*)
t=(1+Sqrt[5])/2;

length[x_,y_]:=FullSimplify[Sqrt[Total[(x-y)^2]]];
Nlength[x_,y_]:=Sqrt[Total[(N[x]-N[y])^2]];
myrule={1.618033988749895`->"τ",1.6180339887498951`->"τ",-1.618033988749895`->"-τ",-1.6180339887498951`->"-τ",0.6180339887498948`->"(τ^(-1))",-0.6180339887498948`->"-(τ^(-1))",1.0000000000000002`->"1",-1.0000000000000002`->"-1",2/(1+Sqrt[5])->"(τ^(-1))",(1+Sqrt[5])/2->"τ",-2/(1+Sqrt[5])->"-(τ^(-1))",-(1+Sqrt[5])/2->"-τ",(-1+Sqrt[5])/2->"(τ^(-1))",(1-Sqrt[5])/2->"-(τ^(-1))",1.6180339887498951`->"τ"};



(*aとbを τ:1に内分する点*)
Clear[a,b];
naibun[a_,b_]=1/(1+t) a+t/(1+t) b;

(*xを頂点とし，「正三角形」yを底辺とする正四面体が存在するかチェックする述語関数*)
NtetraQ[x_,y_List]:=(Nlength[x,y[[1]]]^2+2Sqrt[5]-6)^2+(Nlength[x,y[[2]]]^2+2Sqrt[5]-6)^2+(Nlength[x,y[[3]]]^2+2Sqrt[5]-6)^2<0.000001;

tetraQ[x_,y_List]:=(length[x,y[[1]]]^2+2Sqrt[5]-6)^2+(length[x,y[[2]]]^2+2Sqrt[5]-6)^2+(length[x,y[[3]]]^2+2Sqrt[5]-6)^2==0;

icosahedronQ[x_,y_,z_,w_]:=((length[x,y]^2+2Sqrt[5]-6)^2==0)&&((length[x,z]^2+2Sqrt[5]-6)^2==0)&&((length[x,w]^2+2Sqrt[5]-6)^2==0)&&((length[y,z]^2+2Sqrt[5]-6)^2==0)&&((length[y,w]^2+2Sqrt[5]-6)^2==0)&&((length[z,w]^2+2Sqrt[5]-6)^2==0);

icosahedronQ[x_,{y_,z_,w_}]:=icosahedronQ[x,y,z,w]
icosahedronQ[{x_,y_,z_,w_}]:=icosahedronQ[x,y,z,w]

findfuta[x_]:=Select[futa,length[#,x]^2==(Sqrt[5]-1)^2&]

proj[mode_Integer,x_List]:=Switch[mode,
1,Table[Drop[x[[k]],{4}],{k,1,Length[x]}],
2,Table[Drop[x[[k]],{3}],{k,1,Length[x]}],
3,Table[1/(x[[k,4]]) Drop[x[[k]],{4}],{k,1,Length[x]}]
];

1. 正24胞体の胞(正8面体)の辺を1:τに内分する点を使い,  頂点の座標を作成するプログラム．(c1111などは各正8面体から作られる12個の頂点. cells24はその総和．また cells24//Union//Flatten = vecs24)

正24胞体の座標を作成してから　600胞体の座標を作成するプログラム.（直接作成するプログラムは 「 点と辺makingOld.nb」参照)

(*vertices of Octas(24 cells) tetrasC の作成に使う.*)

cellOctaA[x_List]:=(
mixed:=Partition[Riffle[x,{0,0,0,0}],2];
combi={{1,1,2,2},{2,2,1,1},{1,2,1,2},{2,1,2,1},{1,2,2,1},{2,1,1,2}};
Table[Table[mixed[[i,combi[[k,i]]]],{i,1,4}],{k,1,6}])

cellOctaB[x_List]:=(pos:=Position[x,0];
posc:=If[MemberQ[x,1],Position[x,1],Position[x,-1]];cellOctaB0:=Table[{ReplacePart[x,k->1],ReplacePart[x,k->-1]},{k,pos}];
If[EvenQ[posc[[1,1]]],Flatten[cellOctaB0[[{1,3,2}]],1],Flatten[cellOctaB0,1]]);
(*600胞体の座標をうまく作るために 偶奇で場合わけ*)

o1111=cellOctaA[{1,1,1,1}];o1112=cellOctaA[{1,1,1,-1}];o1121=cellOctaA[{1,1,-1,1}];
o1122=cellOctaA[{1,1,-1,-1}];o1211=cellOctaA[{1,-1,1,1}];o1212=cellOctaA[{1,-1,1,-1}];
o1221=cellOctaA[{1,-1,-1,1}];o1222=cellOctaA[{1,-1,-1,-1}];o2111=cellOctaA[{-1,1,1,1}];
o2112=cellOctaA[{-1,1,1,-1}];o2121=cellOctaA[{-1,1,-1,1}];o2122=cellOctaA[{-1,1,-1,-1}];
o2211=cellOctaA[{-1,-1,1,1}];o2212=cellOctaA[{-1,-1,1,-1}];o2221=cellOctaA[{-1,-1,-1,1}];
o2222=cellOctaA[{-1,-1,-1,-1}];
o1000=cellOctaB[{1,0,0,0}];o0100=cellOctaB[{0,1,0,0}];o0010=cellOctaB[{0,0,1,0}];o0001=cellOctaB[{0,0,0,1}];o2000=cellOctaB[{-1,0,0,0}];o0200=cellOctaB[{0,-1,0,0}];o0020=cellOctaB[{0,0,-1,0}];o0002=cellOctaB[{0,0,0,-1}];

octas={o1111,o1112,o1121,o1122,o1211,o1212,o1221,o1222,
o2111,o2112,o2121,o2122,o2211,o2212,o2221,o2222,o1000,o0100,o0010,o0001,o2000,o0200,o0020,o0002};

Clear[a,b];
naibun[a_,b_]=1/(1+t) a+t/(1+t) b;

creatCell[x_List]:=(
parted:=t*Partition[x,2];
FullSimplify[{
naibun[parted[[3,2]],parted[[2,2]]],
naibun[parted[[2,2]],parted[[1,1]]],
naibun[parted[[3,1]],parted[[2,2]]],
naibun[parted[[2,2]],parted[[1,2]]],
naibun[parted[[1,2]],parted[[3,2]]],
naibun[parted[[1,1]],parted[[3,2]]],
naibun[parted[[2,1]],parted[[1,1]]],
naibun[parted[[1,1]],parted[[3,1]]],
naibun[parted[[1,2]],parted[[3,1]]],
naibun[parted[[2,1]],parted[[1,2]]],
naibun[parted[[3,2]],parted[[2,1]]],
naibun[parted[[3,1]],parted[[2,1]]]}])

(*cells24 は 正20面体上の頂点の集合．(ダブルカウントあり). futa はそれ以外の頂点の集合.*)
cells24=Map[creatCell,octas];

{c1111,c1112,c1121,c1122,c1211,c1212,c1221,c1222,
c2111,c2112,c2121,c2122,c2211,c2212,c2221,c2222,c1000,c0100,c0010,c0001,c2000,c0200,c0020,c0002}=cells24;


futa1={{1,1,1,1},{1,1,1,-1},{1,1,-1,1},{1,1,-1,-1},
{1,-1,1,1},{1,-1,1,-1},{1,-1,-1,1},{1,-1,-1,-1},
{-1,1,1,1},{-1,1,1,-1},{-1,1,-1,1},{-1,1,-1,-1},
{-1,-1,1,1},{-1,-1,1,-1},{-1,-1,-1,1},{-1,-1,-1,-1}
};

futa2={{2,0,0,0},{0,2,0,0},{0,0,2,0},{0,0,0,2},{-2,0,0,0},{0,-2,0,0},{0,0,-2,0},{0,0,0,-2}};
futa=Flatten[{futa1,futa2},1];

vecs24=Union[Flatten[cells24,1]];

2. [TetrasAの作成] 正24胞体の正8面体胞 を使い,  正20面体の表面を作成．（c1111上の三角形が t1111．その総和がtriangles24. )  さらに，蓋をして 正四面体の胞: tetrasAを 24*20=480室作る.

triangleQ[x_List]:=(Abs[Nlength[x[[1]],x[[2]]]^2+2Sqrt[5]-6]<0.0001&&Abs[Nlength[x[[2]],x[[3]]]^2+2Sqrt[5]-6]<0.0001&&Abs[Nlength[x[[3]],x[[1]]]^2+2Sqrt[5]-6]<0.0001);

icosahedron[x_List]:=(
north=x[[1]];
grp1=x[[{2,3,4,5,6,2}]];
grp2=x[[{7,8,9,10,11,7}]];
south=x[[12]];
paired1=Partition[grp1,2,1];
paired2=Partition[grp2,2,1];
triangles1= Map[Prepend[#,north]&,paired1];
triangles4= Map[Prepend[#,south]&,paired2];
triangles2=Table[Append[paired1[[i]],grp2[[i+1]]],{i,1,5}];
triangles3=Table[Append[paired2[[i]],grp1[[i]]],{i,1,5}];
Return[Flatten[{triangles1,triangles2,triangles3,triangles4},1]])


triangles24=Map[icosahedron,cells24];
{t1111,t1112,t1121,t1122,t1211,t1212,t1221,t1222,
t2111,t2112,t2121,t2122,t2211,t2212,t2221,t2222,t1000,t0100,t0010,t0001,t2000,t0200,t0020,t0002}=triangles24;(*definition of t1111...t0004*)

tetrasA0:=Table[Map[Append[#,futa[[k]]]&,triangles24[[k]]],{k,1,24}];
tetrasA:=Flatten[tetrasA0,1];

3. [TetrasBの作成]  正20面体の表面の三角形と，他の正20面体の頂点から作られる正四面体胞tetrasB (96個)を作成．

[方法1] 正攻法.線分PQを20面体Vの△ABCに一番近い正8面体上線分とする.　PQを共有するV以外の正8面体V1,V2は，PQから最も遠い点Rを共有する．最後にPRをτ:1に内分する点が△ABCに対応する正四面体の頂点.

Clear[x,y,z];
findOcta[x_,y_,z_]:=Intersection[Select[octas,MemberQ[#,x]& ],Select[octas,MemberQ[#,y]&],Select[octas,MemberQ[#,z]&]]
findAGpOutofseg[{{index11_,index12_}},{{index21_,index22_}}]:=Complement[{1,2,3},{index11},{index21}][[1]];
change1And2[{{index1_,index2_}}]={{index1,3-index2}};


findTetra[closest_,othersideofseg_,currentOcta_]:=(
OctaParted:=Partition[currentOcta,2];
cgp:=findAGpOutofseg[Position[OctaParted,closest],Position[OctaParted,othersideofseg]];
outofseg1=Extract[OctaParted,{cgp,1}];
outofseg2=Extract[OctaParted,{cgp,2}];
nearbyOcta:=Complement[findOcta[closest,othersideofseg,outofseg1],{currentOcta}][[1]];
nearbyPaired:=Partition[nearbyOcta,2];
oppositePtPos:=Position[nearbyPaired,outofseg1]//change1And2;
oppositeOfoutofseg=Extract[nearbyPaired,oppositePtPos][[1]];
V4:=naibun[oppositeOfoutofseg,closest];
V1:=naibun[outofseg1,closest];
V2:=naibun[outofseg2,closest];
V3:=naibun[closest,othersideofseg];
t*{V1,V2,V3,V4}//FullSimplify
)


tetrasB0=Table[{
findTetra[octas[[k,1]],octas[[k,5]],octas[[k]]],
findTetra[octas[[k,1]],octas[[k,6]],octas[[k]]],
findTetra[octas[[k,2]],octas[[k,5]],octas[[k]]],
findTetra[octas[[k,2]],octas[[k,6]],octas[[k]]],
findTetra[octas[[k,3]],octas[[k,1]],octas[[k]]],
findTetra[octas[[k,3]],octas[[k,2]],octas[[k]]],
findTetra[octas[[k,4]],octas[[k,1]],octas[[k]]],
findTetra[octas[[k,4]],octas[[k,2]],octas[[k]]],
findTetra[octas[[k,5]],octas[[k,3]],octas[[k]]],
findTetra[octas[[k,5]],octas[[k,4]],octas[[k]]],
findTetra[octas[[k,6]],octas[[k,3]],octas[[k]]],
findTetra[octas[[k,6]],octas[[k,4]],octas[[k]]]},
{k,1,24}]//Map[Sort,#,2]&;

tetrasB=Union[Flatten[tetrasB0,1]];

4. [TetrasCの作成] 正20面体A,B,C,D,E,Fからそれぞれ1つの辺(2点)をえらんで作られる正四面体胞tetrasC(24個)を作成.

(*vertices of Octas(24 cells)*)
VofOctas=Module[{base,p,q},
base={{p,q,0,0},{p,0,q,0},{p,0,0,q},{0,p,q,0},{0,p,0,q},{0,0,p,q}};
t*Flatten[{base/.{p->1,q->1},base/.{p->1,q->-1},base/.{p->-1,q->1},base/.{p->-1,q->-1}},1]];
(*length between each vertice of tetrahedron and each vertice of 24 cells is sqrt(3-sqrt(5)).*)
tetrasC=Table[Select[vecs24,Abs[Nlength[#,VofOctas[[k]]]^2-3+Sqrt[5]]<0.001&],{k,1,24}];
%/.myrule;

5.  tetras を 1つのスレッドでつなげるタイプ(snake型)のデータ作成

octa(正8角形)を,1つのスレッドに並べる.

Clear[x,y,in,out]

kyotu[x_,y_]:=Table[Position[x,Intersection[x,y][[k]]],{k,1,3}]//Flatten//Sort;
farenoughQ[in_List,out_List]:=Length[Intersection[in,out]]<=1
contact[ver_]:=Switch[ver,{1,3,5},16,{1,3,6},15,{1,4,5},6,{1,4,6},5,{2,3,5},18,{2,3,6},14,{2,4,5},7,{2,4,6},3]

Octas=octas;
surface={1,3,5};
myoctas0={octas[[1]]};
Octas0=Complement[Octas,myoctas0];
While[Length[Octas]>0,
Catch[
myoctas=myoctas0;
Octas=Octas0;
surface={1,3,5};
Do[(
nextix=RandomSample[Range[Length[Octas]]];
Octas=Part[Octas,nextix];
nextset=Select[Octas,Length[Intersection[Last[myoctas],#]]==3&&
farenoughQ[kyotu[Last[myoctas],#],surface]&, 1];
(* Last[myocta] における nextocta の位置 *)
If[nextset=={},Throw["sippai"]];
nextocta=nextset[[1]];
surface=kyotu[nextocta,Last[myoctas]];(* nextocta における surfaceの位置 *)
AppendTo[myoctas,nextocta];
Octas=Complement[Octas,{nextocta}];)
,{23}]
]
]

inoutsurfaces0=Table[{contact[kyotu[myoctas[[k]],myoctas[[k+1]]]],contact[kyotu[myoctas[[k+1]],myoctas[[k]]]]},{k,1,23}];
inoutsurfaces=inoutsurfaces0//Flatten//Prepend[#,16]&//Partition[#,2]&//Append[#,{Last[inoutsurfaces0][[2]]}]&
order=Map[Position[octas,#][[1,1]]&,myoctas]

5-1. 24胞体に含まれる正4角形の胞tetrasAの展開．developement1[[k]]とdevelopement1[[k+1]]が共通の面を持つ様に並べ替える．

tetras=Join[tetrasA,tetrasB,tetrasC];
Clear[in,out,x,n];

(*絶対消去しない事! オリジナルのプログラムだが，時間が非常に掛かるので　直後のプログラムを利用.*)
openOcta[n_Integer,in_Integer,out_Integer]:=(
(*resourse=Join[tetrasA0[[nofOcta]],tetrasB0[[nofOcta]],tetrasC]//Complement[#,mytetra]&;*)
resourse=tetrasA0[[n]];(*//Complement[#,mytetra]&;*)
openocta={tetrasA0[[n,in]]};
remain=Complement[resourse,openocta];
While[(Length[Intersection[remain,tetrasA0[[n]]]]>0)||(Last[openocta]≠tetrasA0[[n,out]]),
Catch[
openocta={tetrasA0[[n,in]]};
remain=Complement[resourse,openocta];
While[Length[Intersection[remain,tetrasA0[[n]]]]>0,(
shuffled=RandomSample[remain];
next=Select[shuffled,Length[Intersection[Last[openocta][[{1,2,3}]],# [[{1,2,3}]]]]==2&,1];
If[next=={},Throw["sippai"]];
AppendTo[openocta,next[[1]]];
remain=Complement[remain,next];)
](*end of while2*)
](*end of catch*);
](*end of while1*)
;openocta
)



pass0603={6,12,17,18,13,7,2,1,5,4,9,15,10,11,16,20,19,14,8,3};
pass0705={7,13,8,14,19,18,17,12,6,1,2,3,4,9,15,20,16,11,10,5};
pass1405={14,9,15,10,11,6,1,2,7,12,17,16,20,19,18,13,8,3,4,5};
pass1406={14,19,20,15,9,4,3,8,13,18,17,16,11,10,5,1,2,7,12,6};
pass1407={14,19,20,15,9,4,5,10,11,16,17,18,13,8,3,2,1,6,12,7};
pass1503={15,10,11,6,1,5,4,9,14,8,13,18,19,20,16,17,12,7,2,3};
pass1506={15,9,4,3,2,7,12,17,18,13,8,14,19,20,16,11,10,5,1,6};
pass1507={15,20,19,14,9,4,5,10,11,16,17,18,13,8,3,2,1,6,12,7};
pass1603={16,11,10,15,20,19,18,17,12,6,1,5,4,9,14,8,13,7,2,3};
pass1605={16,17,12,7,2,3,4,9,14,8,13,18,19,20,15,10,11,6,1,5};
pass1607={16,20,19,14,8,3,2,1,5,4,9,15,10,11,6,12,17,18,13,7};
pass1614={16,11,10,5,4,3,8,13,7,2,1,6,12,17,18,19,20,15,9,14};
pass1803={18,13,7,2,1,6,12,17,16,11,10,5,4,9,15,20,19,14,8,3};
pass1805={18,17,16,20,19,14,8,13,7,12,6,11,10,15,9,4,3,2,1,5};
pass1806={18,19,20,15,9,14,8,13,7,12,17,16,11,10,5,4,3,2,1,6};
pass1815={18,13,7,12,17,16,20,19,14,8,3,2,1,6,11,10,5,4,9,15};



passes={pass0603,pass0705,pass1405,pass1406,pass1407,pass1503,pass1506,pass1507,pass1603,pass1605,pass1607,pass1614,pass1803,pass1805,pass1806,pass1815};

openOcta2[n_Integer,in_Integer,out_Integer]:=(
pass=If[in>out,Select[passes,First[#]==in&&Last[#]==out&][[1]],Select[passes,First[#]==out&&Last[#]==in&][[1]]//Reverse];
tetrasA0[[n]][[pass]]);


Clear[in,out,x,n];
openOcta[n_Integer,in_Integer]:=(
resourse=tetrasA0[[n]];(*//Complement[#,mytetra]&;*)
openocta={tetrasA0[[n,in]]};
remain=Complement[resourse,openocta];
While[(Length[Intersection[remain,tetrasA0[[n]]]]>0),
Catch[
openocta={tetrasA0[[n,in]]};
remain=Complement[resourse,openocta];
While[Length[Intersection[remain,tetrasA0[[n]]]]>0,(
shuffled=RandomSample[remain];
next=Select[shuffled,Length[Intersection[Last[openocta][[{1,2,3}]],#[[{1,2,3}]]]]==2&,1];
If[next=={},Throw["sippai"]];
AppendTo[openocta,next[[1]]];
remain=Complement[remain,next];)
](*end of while2*)
](*end of catch*);
](*end of while1*)
;
openocta
)

(*openOcta2は速い. openOctaの方を使うと 3分ぐらい掛かる!  「気長に」待て! *)

developementA0=Append[Table[openOcta2[order[[i]],inoutsurfaces[[i,1]],inoutsurfaces[[i,2]]],{i,1,23}],
openOcta[order[[24]],inoutsurfaces[[24,1]]] ];

5-2. 24胞体の周りにある正4角形の胞tetrasB&Cの展開．openocta[[k]]とopenocta[[k+1]]が共通の面を持つ様に並べ替える．tetrasAから出て tetrasCまたはtetrasBを通って 繋げられるだけつなげる．(最大tetraA->tetraB->tetraC->tetraBの4個)． それをtetrasB(96個)&tetrasC(24個)が無くなるまで繰り返す．

developementBC0={};
remainB=tetrasB;
remainR=resourse=Join[tetrasB,tetrasC];
While[Length[remainR]>0,
Catch[
newtetraB=RandomChoice[remainB];
newtetraA=Select[tetrasA,Length[Intersection[newtetraB,#]]==3&,1][[1]];
developementBC0=Join[developementBC0,{newtetraA,newtetraB}];
(*openocta=AppendTo[openocta,new];*)
remainB=Complement[tetrasB,developementBC0];
remainR=Complement[resourse,developementBC0];
Do[
shuffled=RandomSample[remainR];
next=Select[shuffled,Length[Intersection[Last[developementBC0],#]]==3&,1];
If[next=={},Throw["kono step no owari"]];
AppendTo[developementBC0,next[[1]]];
remainR=Complement[remainR,next]
,{5}](*end of Do. 3回目以降は，Throw で終わるので 回数は,本当は 3で良い.*)
](*end of catch*)
]


Clear[x]
tetrapos[x_]:=If[Position[tetrasB0,x]≠{},Position[tetrasB0,x],If[MemberQ[tetrasC,x],Position[tetrasC,x],Position[tetrasA0,x]]];

5-3. developementA[[k]]とdevelopementA[[k+1]]で共通な三点が，developementA[[k]]の対応する3点の真下に来るように 「mysort[a,b]」を使う．findnum[x,y]は，xの中で , yと異なる要素(1個)の位置を見つける．

mysort[x_,y_]:=(
common:=Intersection[x,y];
xd=Complement[x,common][[1]];
yd=Complement[y,common][[1]];
If[Length[common]==3,x/.xd->yd,y]
)

findnum[x_,y_]:=(
common:=Intersection[x,y];
xd=Complement[x,common][[1]];
If[Length[common]==3,Position[x,xd][[1,1]],0]
)

developementAf=Flatten[developementA0,1];
developementA={developementAf[[1]]};
Do[AppendTo[developementA,mysort[developementA[[k]],developementAf[[k+1]]]],{k,479}]

numA=Table[findnum[developementA[[k]],developementA[[k+1]]],{k,479}];

developementBC={developementBC0[[1]]};
Do[AppendTo[developementBC,mysort[developementBC[[k]],developementBC0[[k+1]]]],{k,Length[developementBC0]-1}];
numBC=Table[findnum[developementBC[[k]],developementBC[[k+1]]],{k,Length[developementBC]-1}];
PrependTo[numBC,0];

5-4.  5-3を利用して，正四面体600個の，3次元空間内に於ける (x,y,z)リストを作成する．

(*get the next polyhedron; For example n=4, x={A,B,C,D} then OE=2/3(OA+OB+OC)-OD*)
(*ｘで表される四面体のn(n=1,2,3,4)番目の頂点を対称移動した四面体x'を作成する*)
Clear[x,y,n]
getNext[x_List,n_Integer]:=ReplacePart[x,n->(2/3 Total[Drop[x,{n}]]-x[[n]])];

polyA0={{Sqrt[3],-1,0},{-Sqrt[3],-1,0},{0,2,0},{0,0,2 Sqrt[2]}};
(*スタートの四面体. 変更可能*)

Clear[k,n,polyA,polyBC]
polyA[k_]:=polyA[k]=getNext[polyA[k-1],numA[[k-1]]]//FullSimplify;
polyA[1]=polyA0//N;(*//Nを追加すると，実行速度が速くなる*)
polyAs=Table[polyA[k],{k,1,480}];

polyBC[k_]:=polyBC[k]=If[numBC[[k]]≠0,getNext[polyBC[k-1],numBC[[k]]],Position[developementAf,developementBC[[k]]][[1,1]]//polyA[#]&];

polyBCs0=Table[polyBC[k],{k,1,Length[developementBC]}];
polyBCs=Delete[polyBCs0,Position[numBC,0]];

polys=Join[polyAs,polyBCs];

(*x,y,z range*)
Xcords=Flatten[polys,1][[All,1]];
Ycords=Flatten[polys,1][[All,2]];
Zcords=Flatten[polys,1][[All,3]];
myrange={{Min[Xcords],Max[Xcords]},{Min[Ycords],Max[Ycords]},{Min[Zcords],Max[Zcords]}};
body[x_List]:={Polygon[{x[[2]],x[[3]],x[[4]]}],Polygon[{x[[1]],x[[2]],x[[3]]}],
Polygon[{x[[1]],x[[2]],x[[4]]}],Polygon[{x[[1]],x[[3]],x[[4]]}]};

Animate[Graphics3D[{body[polyA0],Table[body[polys[[i]]],{i,1,k}]},Boxed->False,PlotRange->myrange],{{k,1,Style["cell",Bold]},1,600}]