Octahedral Rotational Symmetry Types

telo={{{1,2,6,3},{1,3,4},{1,4,10,5},{1,5,8,2},{2,8,14,7},{2,7,6},{3,6,13,9},{3,9,11,4},{4,11,18,10},{5,10,12},{5,12,16,8},{6,7,15,13},{7,14,21,15},{8,16,14},{9,13,20,17},{9,17,11},{10,18,19,12},{11,17,23,18},{12,19,22,16},{13,15,20},{14,16,22,21},{15,21,24,20},{17,20,24,23},{18,23,19},{19,23,24,22},{21,22,24}},{{0,0,1.070722470767624376655853050002438148`25.},{0.7148134886731865118969339433075535`24.0541,0,0.79717519142130514249890775828788602`24.2452},{-0.104682011774381474868280416504999049`23.689700000000002,0.70710678118654752440084436210484465`23.9554,0.79717519142130514249890775828787783`23.9231},{-0.6841528372927201901346065961244372`23.8472,0.20710678118654752440084436210484775`23.5209,0.79717519142130514249890775828786964`23.5554},{-0.10468201177438147486828041650499791`23.055000000000003,-0.70710678118654752440084436210483815`23.7556,0.79717519142130514249890775828785994`23.3918},{0.61013147689880503702865352680254852`23.5063,0.70710678118654752440084436210484318`23.3612,0.52362791207498590834196246657332809`23.4396},{1.0415595816293134460830735677782037`23.094200000000004,0.2071067811865475244008443620971024`22.4561,0.1367736396731596170784726458572722`22.2049},{0.6101314768988050370286535267968321`22.5322,-0.707106781186547524400844362105912`21.7788,0.5236279120749859083419624665784311`22.4528},{-0.357406744336593255948466971645135`21.669200000000004,0.9999999999999999999999999999841438`22.6166,0.136773639673159617078472645851343`21.5338},{-0.7888348490671016650028870126143983`22.712,-0.499999999999999999999999999985747`22.6372,0.5236279120749859083419624665557987`22.8742},{-0.936877569854931971214793151238698`22.3683,0.499999999999999999999999999998153`22.070199999999996,0.136773639673159617078472645861702`21.4132},{-0.357406744336593255948466971654212`21.627200000000006,-0.999999999999999999999999999962413`22.2228,0.13677363967315961707847264586608`21.1713},{0.357406744336593255948466971635383`21.4201,0.999999999999999999999999999942599`21.6241,-0.136773639673159617078472645888392`20.743500000000004},{0.936877569854931971214793151219976`22.0089,-0.50000000000000000000000000000007`21.545900000000003,-0.136773639673159617078472645840368`21.2644},{0.78883484906710166500288701253348`21.295,0.49999999999999999999999999993588`20.6742,-0.52362791207498590834196246653652`20.9658},{0.35740674433659325594846697164504`20.2614,-1.00000000000000000000000000000635`20.4994,-0.1367736396731596170784726458418`19.478799999999996},{-0.6101314768988050370286535267752`19.965099999999996,0.70710678118654752440084436210255`20.8577,-0.5236279120749859083419624665747`20.1194},{-1.041559581629313446083073567771132`22.0318,-0.207106781186547524400844362093338`21.2545,-0.136773639673159617078472645856861`21.218100000000003},{-0.6101314768988050370286535268178`20.225899999999992,-0.7071067811865475244008443621087`20.1913,-0.5236279120749859083419624665639`20.1265},{0.1046820117743814748682804165002`18.6433,0.7071067811865475244008443620776`20.0923,-0.7971751914213051424989077583147`19.599299999999996},{0.68415283729272019013460659607524`20.975399999999997,-0.20710678118654752440084436216069`20.0867,-0.79717519142130514249890775823437`20.92899999999999},{0.10468201177438147486828041652`17.5943,-0.70710678118654752440084436211`18.3851,-0.79717519142130514249890775822`18.6724},{-0.71481348867318651189693348224`18.3114,0``24.099747605794914,-0.79717519142130514249890775829`18.7257},{0``24.297948775127356,0``28.,-1.07072247076762437665585304983`17.976299999999995}}};

barve={RGBColor[1,0,0],RGBColor[1,1,0],RGBColor[0,0,1],RGBColor[0,1,0],RGBColor[0.230003`,0.370006`,0.170003`],RGBColor[1,0.5`,0.5`],RGBColor[0.559999`,0.370006`,0.599994`],RGBColor[0.529405`,0.807794`,0.921598`],RGBColor[1.`,0.490005`,0.250008`],RGBColor[0.889996`,0.810007`,0.340007`],RGBColor[1.`,0.498001`,0.3137`],RGBColor[1.`,1.`,0.941206`],RGBColor[1,0.5`,0],RGBColor[0.501961`,0.501961`,0],RGBColor[0.501961`,0,0.25098`],GrayLevel[0.501961`],RGBColor[0,0.501961`,0.752941`],RGBColor[0.25098`,0,0.501961`],Hue[0.9523809523809523`],Hue[0.9090909090909091`],Hue[0.8695652173913044`],Hue[0.8333333333333334`],Hue[0.8`],Hue[0.7692307692307692`],Hue[0.7407407407407407`],Hue[0.7142857142857143`],Hue[0.6896551724137931`],Hue[0.6666666666666666`],Hue[0.6451612903225806`],Hue[0.625`],Hue[0.6060606060606061`],Hue[0.588235294117647`]};

index={{1,2,1,3,1,2,3,1,3,2,1,1,3,2,1,2,1,1,3,2,1,1,3,2,1,2},{1,2,1,3,1,4,3,1,3,4,1,1,3,2,1,4,1,1,3,2,1,1,3,2,1,4},{1,2,1,3,1,2,4,5,4,2,1,5,4,2,1,2,5,1,4,2,5,1,3,2,1,2},{1,2,1,3,1,2,4,5,4,2,1,5,4,2,6,7,5,6,4,7,5,6,8,7,6,7},{1,2,3,4,3,5,6,7,8,5,1,7,8,2,1,5,7,3,6,2,7,3,4,2,1,5},{1,2,3,4,5,6,7,8,7,6,5,3,4,9,8,10,1,8,4,2,5,1,7,2,3,6},{1,2,3,4,3,5,6,7,8,5,1,9,8,2,10,11,9,12,6,13,7,12,14,13,10,11},{1,2,3,4,5,2,4,5,4,2,5,3,4,6,5,6,1,5,4,2,5,1,4,2,3,2}};

mainaxis={{0.33020077587407276271021755621355313866`21.999821218885653,-0.38268343236508977172845998403044754059`21.774242741230115,0.86285620946101681810884008195217264635`22.040645032372353},{0.65089081819590116571677214942844233413`19.707362234914026,-0.75434447948457154119734193449026791001`19.69714692982457,0.08547250469841843332720315463180473078`19.431056835466627},{0.33020077587407276271021755621355313866`21.999821218885653,-0.38268343236508977172845998403044754059`21.774242741230115,0.86285620946101681810884008195217264635`22.040645032372353},{0.33020077587407276271021755621355313866`21.999821218885653,-0.38268343236508977172845998403044754059`21.774242741230115,0.86285620946101681810884008195217264635`22.040645032372353},{0.33020077587407276271021755621355313866`21.999821218885653,-0.38268343236508977172845998403044754059`21.774242741230115,0.86285620946101681810884008195217264635`22.040645032372353},{0.65089081819590116571677214942844233413`19.707362234914026,-0.75434447948457154119734193449026791001`19.69714692982457,0.08547250469841843332720315463180473078`19.431056835466627},{0.33020077587407276271021755621355313866`21.999821218885653,-0.38268343236508977172845998403044754059`21.774242741230115,0.86285620946101681810884008195217264635`22.040645032372353},{0.65089081819590116571677214942844233413`19.707362234914026,-0.75434447948457154119734193449026791001`19.69714692982457,0.08547250469841843332720315463180473078`19.431056835466627}};

secondaxis={{0.65089081819590116571677214942844233413`19.707362234914026,-0.75434447948457154119734193449026791001`19.69714692982457,0.08547250469841843332720315463180473078`19.431056835466627},{0.33020077587407276271021755621355313866`21.999821218885653,-0.38268343236508977172845998403044754059`21.774242741230115,0.86285620946101681810884008195217264635`22.040645032372353},{0.5636879836476889526043350721`18.58761422746486,-0.65328148243818826392805782885`18.598644720647666,-0.50544946512442356216016903852`18.651808266246718},{},{0.93394883109446475957738040415157822589`20.443348775611852,0``20.804570895651757,-0.35740674433659325594846697163929562246`20.276280097822507},{},{},{0.42691434397452933552761225991`18.423451390423615,0.27059805007309849220082647417`18.431969637370024,-0.86285620946101681811191676844`18.141003661990556}};

RandomKsublist[set_,k_]:=Module[{sub={},rest=set,new},
Do[new=rest[[Random[Integer,{1,Length[rest]}]]];sub=AppendTo[sub,new];rest=Complement[rest,{new}],{k}];sub];

rules={
1->Style["O", Italic],
2->Style["T", Italic],
3->Style[Subscript["D","4"],Italic],
4->Style[Subscript["C","4"],Italic],
5->Style[Subscript["D","2"],Italic],

6->Style[Subscript["C","3"],Italic],
7->Style[Subscript["C","2"],Italic],

8->Style[Subscript["D","3"],Italic]
};

Manipulate[SeedRandom[ranint];If[secondaxis[[nn]]=={},showp=False];With[{ax=If[showp,If[secondaxis[[nn]]=={},mainaxis[[nn]],secondaxis[[nn]]],mainaxis[[nn]]]},With[{graf=Table[{barve1[[index[[nn,i]]]],Polygon[Map[telo[[2,#]]&,telo[[1,i]]]]},{i,1,Length[telo[[1]]]}]},Column[{
Graphics3D[{If[showa,{RGBColor[0, 0, 0],Thickness[0.01],Line[1.4{mainaxis[[nn]],-mainaxis[[nn]]}]}],If[showp,If[secondaxis[[nn]]=={},{},{RGBColor[1, 0, 0],Thickness[0.01],Line[1.4{secondaxis[[nn]],-secondaxis[[nn]]}]}]],Rotate[graf,k 2Pi,ax]},PlotRange->1.4,Boxed->False,Lighting->"Neutral",SphericalRegion->True,ImageSize->{500,400}, ViewAngle-> Pi/9]}, Alignment-> Center]]],
{barve1,{RandomKsublist[barve,32]},ControlType->None},

{{ranint,Random[Integer,100]},ControlType->None},
Row[{Control[{{showa,False,"show (one) principal axis"},{True,False},Enabled->k==0}],Spacer[15], Control[{{showp,False,"show (one) secondary axis if there is one"},{True,False},Enabled->!(secondaxis[[nn]]=={})&&k==0}]}],Row[{"choose group: ", Control[{{nn,1,""},
rules,
Appearance->"Left",ControlType->RadioButtonBar,Enabled->k==0}]}],{{k,0,"rotate"},0,1,Enabled->Xor[showa ,showp],Appearance->"Labeled"},
TrackedSymbols:>{nn,barve1,showp,showa,k},SaveDefinitions->True, SynchronousInitialization-> False, AutorunSequencing-> {1,2},ContentSize->{540,520}]

The subgroups of octahedral rotational group can be illustrated by properly coloring faces of the small rhombicuboctahedron.

Contributed by: Izidor Hafner