Expanding Ball of 30 Octahedra

GrSolid[solid_]:=Module[
		{died=solid,gr0,gr1},
		gr0=Map[died[[2]][[#]]&,died[[1]]];gr1=Map[Polygon,gr0]];

dodek={{{4,5,2},{4,2,6},{1,5,4},{1,4,6},{1,3,5},{1,6,3},{2,3,5},{3,2,6}},{{-(Sqrt[(2/(5+(Sqrt[5])))]),0,((1+(Sqrt[5]))/(Sqrt[2 (5+(Sqrt[5]))]))},{(Sqrt[(2/(5+(Sqrt[5])))]),0,-((1+(Sqrt[5]))/(Sqrt[2 (5+(Sqrt[5]))]))},{-(Sqrt[(2/(5+(Sqrt[5])))]),0,-((1+(Sqrt[5]))/(Sqrt[2 (5+(Sqrt[5]))]))},{(Sqrt[(2/(5+(Sqrt[5])))]),0,((1+(Sqrt[5]))/(Sqrt[2 (5+(Sqrt[5]))]))},{0,-(Sqrt[(2/(5+(Sqrt[5])))])-((1+(Sqrt[5]))/(Sqrt[2 (5+(Sqrt[5]))])),0},{0,(Sqrt[(2/(5+(Sqrt[5])))])+((1+(Sqrt[5]))/(Sqrt[2 (5+(Sqrt[5]))])),0}}};

d2=2 Sqrt[2/(5+Sqrt[5])];d1=GoldenRatio d2;
dokoor4=Table[{0,0,d1/2}+dodek[[2]][[i]],{i,1,Length[dodek[[2]]]}]//N;dodekpremak={dodek[[1]],dokoor4};

telo={{{1,2,3,4},{1,5,6,2},{2,9,10,3},{2,15,16,9},{3,10,11,4},{4,8,5,1},{4,23,24,8},{5,21,22,6},{5,25,26,21},{6,22,15,2},{8,24,25,5},{9,16,17,10},{10,31,32,11},{11,32,23,4},{12,19,20,24},{13,19,7,28},{14,28,29,16},{16,29,30,17},{17,30,31,10},{20,19,13,26},{21,26,27,22},{22,14,16,15},{22,27,28,14},{23,32,12,24},{24,20,26,25},{26,13,28,27},{29,28,7,30},{30,7,19,18},{31,30,18,32},{32,18,19,12}},{{1.3763819204711736`,-0.5257311121191336`,0.`},{1.3763819204711736`,0.`,-0.85065080835204`},{1.3763819204711736`,0.5257311121191336`,0.`},{1.3763819204711736`,0.`,0.85065080835204`},{0.85065080835204`,-1.3763819204711736`,0.`},{0.85065080835204`,-0.85065080835204`,-0.85065080835204`},{-1.3763819204711742`,0.5257311121191336`,0.`},{0.85065080835204`,-0.85065080835204`,0.85065080835204`},{0.85065080835204`,0.85065080835204`,-0.85065080835204`},{0.85065080835204`,1.3763819204711736`,0.`},{0.85065080835204`,0.85065080835204`,0.85065080835204`},{-0.5257311121191338`,0.`,1.3763819204711731`},{-1.3763819204711742`,-0.5257311121191336`,0.`},{-0.5257311121191338`,0.`,-1.3763819204711731`},{0.5257311121191334`,0.`,-1.3763819204711731`},{-2.220446049250313`*^-16,0.85065080835204`,-1.3763819204711731`},{-2.220446049250313`*^-16,1.3763819204711736`,-0.5257311121191331`},{-0.8506508083520404`,0.85065080835204`,0.85065080835204`},{-1.3763819204711742`,0.`,0.85065080835204`},{-0.8506508083520404`,-0.85065080835204`,0.85065080835204`},{-2.220446049250313`*^-16,-1.3763819204711736`,-0.5257311121191331`},{-2.220446049250313`*^-16,-0.85065080835204`,-1.3763819204711731`},{0.5257311121191334`,0.`,1.3763819204711731`},{-2.220446049250313`*^-16,-0.85065080835204`,1.3763819204711731`},{-2.220446049250313`*^-16,-1.3763819204711736`,0.5257311121191331`},{-0.8506508083520404`,-1.3763819204711736`,0.`},{-0.8506508083520404`,-0.85065080835204`,-0.85065080835204`},{-1.3763819204711742`,0.`,-0.85065080835204`},{-0.8506508083520404`,0.85065080835204`,-0.85065080835204`},{-0.8506508083520404`,1.3763819204711736`,0.`},{-2.220446049250313`*^-16,1.3763819204711736`,0.5257311121191331`},{-2.220446049250313`*^-16,0.85065080835204`,1.3763819204711731`}}};

dokoorB=dodek[[2]].{{0,0,1},{1,0,0},{0,1,0}};

dokoorBB=Table[{0,0,d2/2}+dokoorB[[i]],{i,1,Length[dokoorB]}];

dodekzavrten={dodek[[1]],dokoorBB};
everage[list_]:=Total[list]/Length[list];

ort[r_]:=r/Norm[r];

Iztriakontadodeka2[solid_]:=
	Module[
		{c1,f,edgs,v,e,adj,sttroval,d2,d1,tabe5,tabel6,vtek,etek,gr1,troval,vx,vy,vz,novcenter2,B,do6koor,do5koor,grdo3},
	d2=2 Sqrt[2/(5+Sqrt[5])];d1=GoldenRatio d2;
c1=solid[[1]];
	f=Length[c1];	
		v=Length[Union[Flatten[c1]]];vertcoor1=solid[[2]];troval=Select[Range[32],Abs[Norm[solid[[2,#]]]-Norm[solid[[2,7]]]]<0.001&];sttroval=Length[troval];
	radijvec[i_]:=Map[vertcoor1[[#]]&,c1[[i]]];	
vx=Table[If[MemberQ[troval,c1[[i]][[1]]],ort[radijvec[i][[3]]-radijvec[i][[1]]],ort[radijvec[i][[2]]-radijvec[i][[4]]]],{i,1,f}];vy=Table[If[MemberQ[troval,c1[[i]][[1]]],ort[radijvec[i][[4]]-radijvec[i][[2]]],ort[radijvec[i][[3]]-radijvec[i][[1]]]],{i,1,f}];
	vz=MapThread[Cross,{vx,vy}];
	novcenter2=Table[(radijvec[i][[1]]+radijvec[i][[3]])/2,{i,1,f}];
		B=Table[{vx[[i]],vy[[i]],vz[[i]]},{i,1,f}];(*Print[B];*)do6koor=Table[dokoor4  . B[[i]],{i,1,f}];(*Print["do6koor",do6koor];*)
do5koor=Table[Table[novcenter2[[j]]+do6koor[[j]][[i]],{i,1,Length[do6koor[[j]]]}],{j,1,f}];(*Print[do5koor];*)
		grdo3=Table[GrSolid[{dodek[[1]],do5koor[[i]]}],{i,1,30}]];

troval=Select[Range[32],Abs[Norm[telo[[2,#]]]-Norm[telo[[2,7]]]]<0.001&];

petval=Select[Range[32],Abs[Norm[telo[[2,#]]]-Norm[telo[[2,2]]]]<0.001&];
around5=Table[Select[Range[30],MemberQ[telo[[1,#]],petval[[i]]]&],{i,1,12}];
around3=Table[Select[Range[30],MemberQ[telo[[1,#]],troval[[i]]]&],{i,1,20}];

tria1=Iztriakontadodeka2[telo];
twofold=Table[everage[Map[telo[[2,#]]&,telo[[1,i]]]],{i,1,30}];

Manipulate[Graphics3D[{RGBColor[1, 0.654902, 0.309804],If[MemberQ[x,1],Table[Translate[tria1[[around3[[i]]]],-k2 telo[[2,troval[[i]]]]],{i,1,20}]],RGBColor[0, 0.443137, 0.219608],If[MemberQ[x,2],Table[Translate[tria1[[around5[[i]]]],k telo[[2,petval[[i]]]]],{i,1,12}]],RGBColor[0, 1, 1],If[MemberQ[x,3],Table[Translate[tria1[[i]],k3 twofold[[i]]],{i,1,30}]]},Lighting->"Neutral",ViewAngle->12 Degree,Boxed->False,PlotRange->8,SphericalRegion->True,ImageSize->{500,420}],Control[{{x,{1,2},""},{1->"3-fold",2->"5-fold",3->"2-fold"},ControlType->TogglerBar}],{{k,0,"translate along 5-fold axes"},-2GoldenRatio, GoldenRatio,Appearance->"Labeled",Enabled->MemberQ[x,2]},{{k2,0,"translate along 3-fold axes"},-2,4.236067977499786`,Appearance->"Labeled",Enabled->MemberQ[x,1]},Control[{{k3,0,"translate along 2-fold axes",Enabled->MemberQ[x,3]},-1,4.236067977499786`,Appearance->"Labeled",Enabled->MemberQ[x,3]}],Row[{Button["model 1",x={1,2};k=GoldenRatio;k2=4.236067977499786`,ImageSize->100],Button["model 2",x={1,2};k=GoldenRatio;k2=-1,ImageSize->100],Button["model 3",x={2,3};k=-2GoldenRatio;k3=1.16,ImageSize->100],Button["model 4",x={1,3};k2=-2;k3=2,ImageSize->100]}],SaveDefinitions->True]

A ball of 30 octahedra is expanded along chosen axes of rotational symmetry.

Contributed by: Izidor Hafner