Replacing Rhombohedra in Hexecontahedron

EdgesOnFace[lice_]:=Module[{i},(*iz cikla dobimo veje*)
Append[Table[{lice[[i]],lice[[i+1]]},{i,1,Length[lice]-1}]
,{Last[lice],First[lice]}]];

EdgesOnFaces[cic_]:=Block[{edgs={},n=Length[cic],ed,i},(*vse veje iz ciklov*)
		Do[ed=EdgesOnFace[cic[[i]]];edgs=Union[edgs,ed],
			{i,1,n}];
		edgs=Union[Map[Sort,edgs,1]]];

FunFromCycle[a_List][x_]:=Module[{pos,dol,p1},dol=Length[a];
		pos=Position[a,x];If[pos=={},x,{p1}=First[pos];If[p1==dol,a[[1]],a[[p1+1]]]]]

CycleFromFun[f_]:=Module[{i,izac,cyc},
		i=1;
		While[f[i]==i,i=i+1];
		izac=i;
		cyc={i};
		While[f[i]!=izac ,cyc=Append[cyc,f[i]];i=f[i]];
cyc];

EdgesFromCycle[a_]:=Module[{dol=Length[a],i},If[(a=={} ),{},Join[Table[{a[[i]],a[[i+1]]},{i,1,dol-1}],{{a[[dol]],a[[1]]}}]]];

EdgesFromCycleObrat[a_]:=Module[{dol=Length[a],i},If[a=={},{},Join[Table[{a[[i+1]],a[[i]]},{i,1,dol-1}],{{a[[1]],a[[dol]]}}]]];

FacesOfEdge[{a_,b_},c1_]:=Module[{f,v,e},
	f=Length[c1];v=Length[Union[Flatten[c1]]];e=f+v-2;
	Select[Range[f],(Length[Intersection[c1[[#]],{a,b}]]==2)&]];

CycleFromEdges[b_]:=Module[{cyc,dol=Length[b],pos,e,f,d,k,j,i,zadnji,prva},If[b=={},{},
	{e,f}=b[[1]];
			cyc={e,f};
			;d=Delete[b,1];
	Do[zadnji=Last[cyc];prva=Table[d[[j]][[1]],{j,1,Length[d]}];
				pos=First[Flatten[Position[prva,zadnji]]];
				cyc=Append[cyc,d[[pos]][[2]]];d=Delete[d,pos],{k,1,dol-2}];
		cyc]];

VsotaCiklovPosebna[cikli_]:=Module[{veje},
veje=Flatten[	Map[EdgesFromCycle,cikli]	,1];
CycleFromEdges[Select[veje,MemberQ[veje,#]&&!MemberQ[veje,Reverse[#]]&]]];

RelacijeSosedstva={SosednjaCiklaQ,SosednjaCiklaQ1,SosednjaCiklaQ2};

HexacontN={{{13,36,9,40},{13,40,2,33},{13,33,1,36},{14,33,2,41},{14,41,12,37},{14,37,1,33},{15,35,6,51},{15,51,5,34},{15,34,1,35},{16,34,5,52},{16,52,9,36},{16,36,1,34},{17,37,12,55},{17,55,6,35},{17,35,1,37},{18,39,8,56},{18,56,7,38},{18,38,2,39},{19,38,7,58},{19,58,12,41},{19,41,2,38},{20,40,9,59},{20,59,8,39},{20,39,2,40},{21,45,10,49},{21,49,4,42},{21,42,3,45},{22,42,4,50},{22,50,11,46},{22,46,3,42},{23,43,7,56},{23,56,8,44},{23,44,3,43},{24,46,11,57},{24,57,7,43},{24,43,3,46},{25,44,8,60},{25,60,10,45},{25,45,3,44},{26,47,5,51},{26,51,6,48},{26,48,4,47},{27,49,10,53},{27,53,5,47},{27,47,4,49},{28,48,6,54},{28,54,11,50},{28,50,4,48},{29,53,10,61},{29,61,9,52},{29,52,5,53},{30,55,12,62},{30,62,11,54},{30,54,6,55},{31,57,11,62},{31,62,12,58},{31,58,7,57},{32,59,9,61},{32,61,10,60},{32,60,8,59}},{{0,1.6180339887498949`,1.`},{0,1.6180339887498949`,-1.`},{0,-1.6180339887498949`,-1.`},{0,-1.6180339887498949`,1.`},{1.`,0,1.6180339887498949`},{-1.`,0,1.6180339887498949`},{-1.`,0,-1.6180339887498949`},{1.`,0,-1.6180339887498949`},{1.6180339887498949`,1.`,0},{1.6180339887498949`,-1.`,0},{-1.6180339887498949`,-1.`,0},{-1.6180339887498949`,1.`,0},{1.6180339887498949`,4.2360679774997898`,0},{-1.6180339887498949`,4.2360679774997898`,0},{0,1.6180339887498949`,4.2360679774997898`},{2.6180339887498949`,2.6180339887498949`,2.6180339887498949`},{-2.6180339887498949`,2.6180339887498949`,2.6180339887498949`},{0,1.6180339887498949`,-4.2360679774997898`},{-2.6180339887498949`,2.6180339887498949`,-2.6180339887498949`},{2.6180339887498949`,2.6180339887498949`,-2.6180339887498949`},{1.6180339887498949`,-4.2360679774997898`,0},{-1.6180339887498949`,-4.2360679774997898`,0},{0,-1.6180339887498949`,-4.2360679774997898`},{-2.6180339887498949`,-2.6180339887498949`,-2.6180339887498949`},{2.6180339887498949`,-2.6180339887498949`,-2.6180339887498949`},{0,-1.6180339887498949`,4.2360679774997898`},{2.6180339887498949`,-2.6180339887498949`,2.6180339887498949`},{-2.6180339887498949`,-2.6180339887498949`,2.6180339887498949`},{4.2360679774997898`,0,1.6180339887498949`},{-4.2360679774997898`,0,1.6180339887498949`},{-4.2360679774997898`,0,-1.6180339887498949`},{4.2360679774997898`,0,-1.6180339887498949`},{0,3.2360679774997898`,0},{1.`,1.6180339887498949`,2.6180339887498949`},{-1.`,1.6180339887498949`,2.6180339887498949`},{1.6180339887498949`,2.6180339887498949`,1.`},{-1.6180339887498949`,2.6180339887498949`,1.`},{-1.`,1.6180339887498949`,-2.6180339887498949`},{1.`,1.6180339887498949`,-2.6180339887498949`},{1.6180339887498949`,2.6180339887498949`,-1.`},{-1.6180339887498949`,2.6180339887498949`,-1.`},{0,-3.2360679774997898`,0},{-1.`,-1.6180339887498949`,-2.6180339887498949`},{1.`,-1.6180339887498949`,-2.6180339887498949`},{1.6180339887498949`,-2.6180339887498949`,-1.`},{-1.6180339887498949`,-2.6180339887498949`,-1.`},{1.`,-1.6180339887498949`,2.6180339887498949`},{-1.`,-1.6180339887498949`,2.6180339887498949`},{1.6180339887498949`,-2.6180339887498949`,1.`},{-1.6180339887498949`,-2.6180339887498949`,1.`},{0,0,3.2360679774997898`},{2.6180339887498949`,1.`,1.6180339887498949`},{2.6180339887498949`,-1.`,1.6180339887498949`},{-2.6180339887498949`,-1.`,1.6180339887498949`},{-2.6180339887498949`,1.`,1.6180339887498949`},{0,0,-3.2360679774997898`},{-2.6180339887498949`,-1.`,-1.6180339887498949`},{-2.6180339887498949`,1.`,-1.6180339887498949`},{2.6180339887498949`,1.`,-1.6180339887498949`},{2.6180339887498949`,-1.`,-1.6180339887498949`},{3.2360679774997898`,0,0},{-3.2360679774997898`,0,0}}};

IzrezOblateBarva[solid_,tocke_,barva1_,barva2_,sp_]:=Block[{c1,pove,f,dre,gra,stran1,stran,pove1,m,drevo,edg,ed1,i,ran,pot1,zatt,
		alledges,lica3,tr2,cikli,urej,urejen,veje,slika1,slika2,gra1,dre1,vertcoor1,vertcoor2,vm,linijaset,maksi,maksihue,c1tek,ii,etek,ftek,vtek,gr1,adj,troval,kk,stirival,n,petval,stirval,izbor,spisek2,v,e,edgs,n2,Sosednja2,sloji2,cikli2,sloj2,ciksloja,cikel2,cikslojaPlus,skupne,fakrot,cikliNovi,slojpet,cikslojapet,vercoor,cikosta,ciklinovi,graf2,text,grafOst},
c1=solid[[1]];
f=Length[c1];edgs=EdgesOnFaces[c1];
v=Length[Union[Flatten[c1]]];e=Length[edgs];
c1tek=c1;
petval=Range[12];
stirval=Range[33,62];	
	vertcoor1=solid[[2]];
		izbor=tocke;spisek2={3};
		n2=Length[spisek2]+1;	Sosednja2=Table[RelacijeSosedstva[[spisek2[[i]]]],{i,1,n2-1}];
			sloji2=Array[sloj2,n2];cikli2=Array[cikel2,n2];
	sloj2[1]=	Table[Select[Range[f],MemberQ[c1[[#]],izbor[[i]]]&],{i,1,Length[izbor]}];
		ciksloja=Map[c1[[#]]&,sloj2[1],{2}];
		cikel2[1]=Map[VsotaCiklovPosebna,ciksloja];
Do[
			sloj2[m]=	Table[Select[Range[f],Sosednja2[[m-1]][cikel2[m-1][[i]],c1[[#]]]&],{i,1,Length[izbor]}];	ciksloja=Map[c1[[#]]&,sloj2[m],{2}];
			cikslojaPlus=Table[Prepend[ciksloja[[i]],cikel2[m-1][[i]]],{i,1,Length[izbor]}];
				cikel2[m]=Map[VsotaCiklovPosebna,cikslojaPlus]
				,{m,2,n2}];skupne=Flatten[Table[First[Select[Intersection[cikel2[1][[i]],cikel2[2][[i]]],MemberQ[petval,#]&]],{i,1,Length[izbor]}]];
fakrot=Table[First[Flatten[Position[cikel2[1][[i]],skupne[[i]]]]],{i,1,Length[izbor]}];
	cikel2[1]=Table[RotateLeft[cikel2[1][[i]],fakrot[[i]]-1],{i,1,Length[izbor]}];fakrot=Table[First[Flatten[Position[cikel2[2][[i]],skupne[[i]]]]],{i,1,Length[izbor]}];
	cikel2[2]=Table[RotateLeft[cikel2[2][[i]],fakrot[[i]]-1],{i,1,Length[izbor]}];
	cikliNovi=Table[{{cikel2[1][[i]][[8]],
						cikel2[1][[i]][[1]],	cikel2[1][[i]][[2]],cikel2[1][[i]][[3]]},{cikel2[1][[i]][[3]],
						cikel2[2][[i]][[2]],	cikel2[2][[i]][[3]],	izbor[[i]]},{cikel2[2][[i]][[7]],
						cikel2[1][[i]][[8]],	cikel2[1][[i]][[3]],izbor[[i]]},{cikel2[2][[i]][[3]],cikel2[1][[i]][[4]],
						cikel2[1][[i]][[7]],izbor[[i]]		},{cikel2[1][[i]][[7]],
						cikel2[1][[i]][[6]],	cikel2[2][[i]][[7]],izbor[[i]]},{cikel2[1][[i]][[4]],
						cikel2[1][[i]][[5]],	cikel2[1][[i]][[6]],cikel2[1][[i]][[7]]}},{i,1,Length[izbor]}];
		vercoor=vertcoor1;
	slojpet=Union[Flatten[sloj2[1]],Flatten[sloj2[2]]];cikslojapet=Map[c1[[#]]&,slojpet];
Do[vercoor=ReplacePart[vercoor,vercoor[[ cikel2[1][[i]][[8]] ]]+vercoor[[ cikel2[1][[i]][[2]] ]]-vercoor[[ cikel2[1][[i]][[1]] ]], cikel2[1][[i]][[3]] ];
	vercoor=ReplacePart[vercoor,vercoor[[ cikel2[1][[i]][[4]] ]]+vercoor[[ cikel2[1][[i]][[6]] ]]-vercoor[[ cikel2[1][[i]][[5]] ]], cikel2[1][[i]][[7]] ];	
	vercoor=ReplacePart[vercoor,-vercoor[[ cikel2[1][[i]][[2]] ]]+vercoor[[ cikel2[1][[i]][[3]] ]]+vercoor[[ cikel2[2][[i]][[3]] ]], izbor[[i]]],{i,1,Length[izbor]}] ;	
cikosta=Complement[c1,cikslojapet];
	ciklinovi=Flatten[cikliNovi,1];			graf2={barva1,	Map[Polygon,	Map[vercoor[[#]]&,cikosta,{1}]]};	
	text=Table[Text[Style[i-32,16],solid[[2,i]]],{i,33,62}];		
grafOst={barva2,	Map[Polygon,	Map[vercoor[[#]]&,ciklinovi,{1}]]};Graphics3D[{graf2,grafOst,If[sp,text,{}]}	,AspectRatio->Automatic,Boxed->False,Lighting->"Neutral",PlotRange->10,SphericalRegion->True,Background->White,ImageSize->{450,420},ViewAngle->10Degree]];

sosede={{36,37,40,41},{35,36,51,52},{34,37,51,55},{33,34,40,52},{33,35,41,55},{39,41,56,58},{38,40,56,59},{33,36,39,59},{33,37,38,58},{45,46,49,50},{44,46,56,57},{43,45,56,60},{42,44,49,60},{42,43,50,57},{48,49,51,53},{47,50,51,54},{42,45,47,53},{42,46,48,54},{34,35,47,48},{34,36,53,61},{47,49,52,61},{48,50,55,62},{35,37,54,62},{38,39,43,44},{43,46,58,62},{38,41,57,62},{39,40,60,61},{44,45,59,61},{52,53,59,60},{54,55,57,58}};

sosede1=Table[Union[{32+i},sosede[[i]]],{i,1,30}];

padem[x_]:=StringJoin[ToString[x]," "];

sosede2=sosede-32;

Manipulate[
z=Sort[x];
y=Sort[Complement[Range[30],Union[Flatten[Table[sosede2[[z[[i]]]],{i,1,Length[z]}]]]]];Column[{IzrezOblateBarva[HexacontN,x+32,LightBlue,Orange,sp]},Alignment->Center],
Row[{
Dynamic@Control[{y,Range[30],ControlType->None}],
Dynamic@Control[{z,Range[30],ControlType->None}]}],
Dynamic@Column[{
Row[{"show points of 2-fold rotational symmetry",
Control[{{sp,False,""},{True,False}}]}],
Control[{{x,{},""},Take[y,15],ControlType->TogglerBar,Appearance->"Row"}],
Control[{{x,{},""},Drop[y,15],ControlType->TogglerBar,Appearance->"Row"}]
}]
,SaveDefinitions->True,ContentSize->{580,450}, Alignment-> Center]

The rhombic hexecontahedron consists of 30 acute golden rhombohedra. Two adjacent acute rhombohedra can be replaced by two obtuse rhombohedra.

Contributed by: Izidor Hafner