wulffShapeVisualizer

User interface Source

Version 02 Feb 2026

This has a bunch of repetitive stuff, I couldn’t figure out how to do it programmatically.  I couldn’t iconize it because that irreversibly destroys the formatting. So, the interface code looks long a tedious, but it really isn’t.

wulffShapeVisualizer =
DynamicModule[
{γ,col,i,j,k, active, a=1,b=1,c=1, αAngle=π/2,βAngle=π/2,γAngle=π/2,style,activeList={1},activeγ={1},activeCol={ColorData[54][1]},activeDirections={{1,0,0}}, wulffShapeData,wulffData,pointGroup, styleValue, schematicView= "Info"},
style[string_]:= Style[ToString[string],{FontSize->12, FontFamily->"Courier New", FontWeight->Bold}];
styleValue[string_,val_]:= Style[ToString[string]<>ToString[val],{FontSize->12, FontFamily->"Courier New", FontWeight->Bold}];
γ[1]=1;
active[1]=True;


Manipulate[
Manipulate[
(*calculation*********************************)
activeList= Flatten[Position[{active[1],active[2],active[3],active[4],active[5],active[6],active[7],active[8],active[9],active[10],active[11],active[12]},True]];
activeγ = Pick[{γ[1],γ[2],γ[3],γ[4],γ[5],γ[6],γ[7],γ[8],γ[9],γ[10],γ[11],γ[12]},{active[1],active[2],active[3],active[4],active[5],active[6],active[7],active[8],active[9],active[10],active[11],active[12]}];
activeCol = Pick[{col[1],col[2],col[3],col[4],col[5],col[6],col[7],col[8],col[9],col[10],col[11],col[12]},{active[1],active[2],active[3],active[4],active[5],active[6],active[7],active[8],active[9],active[10],active[11],active[12]}];
activeDirections=Pick[{{i[1],j[1],k[1]},{i[2],j[2],k[2]},{i[3],j[3],k[3]},{i[4],j[4],k[4]},{i[5],j[5],k[5]},{i[6],j[6],k[6]},{i[7],j[7],k[7]},{i[8],j[8],k[8]},{i[9],j[9],k[9]},{i[10],j[10],k[10]},{i[11],j[11],k[11]},{i[12],j[12],k[12]}},{active[1],active[2],active[3],active[4],active[5],active[6],active[7],active[8],active[9],active[10],active[11],active[12]}];
wulffData=getNormalsDataStructure[lattice,pointGroup,{{a,b,c},{αAngle,βAngle,γAngle}}][Transpose[MapThread[{#1,#2,#3}&,{activeDirections,activeγ,activeCol}]]];


Which[
Length[wulffData]!= 0,
wulffShapeData = wulffShapeConstruction[wulffData],
True,
wulffShapeData= \[LeftAssociation]"Valid Shape"->False\[RightAssociation]
];



(*display*********************************)
Which[
wulffShapeData["Valid Shape"],
Which[
viewType=="Graphics",
wulffShapeData["Graphic"],
viewType== "Information",
wulffCalculationSummary[wulffShapeData,wulffData],
True,
Style[infoText,{FontSize->12,FontFamily->"Arial"}]
],
True,
Style[errorText,{FontSize->12,FontFamily->"Arial"}]
]

,

Dynamic[
Which[
lattice=="Orthorhombic",
Grid[{
{Style["a=1",12],
Control[{{b,1.1,Dynamic[styleValue["b/a=",b]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}],
Control[{{c,1.2,Dynamic[styleValue["c/a=",c]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}]},
{Style["α=(π/2)",12],Style["β=(π/2)",12],Style["γ=(π/2)",12]}
}, Alignment->Center, Spacings->{2,1}
],

lattice=="Hexagonal",
Grid[{
{Style["a=1",12],
Style["b=a",12],
Control[{{c,1.2,Dynamic[styleValue["c/a=",c]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}]
},
{Style["α=(π/2)",12],Style["β=(π/2)",12],Style["γ=((3  π)/2)"]}
}, Alignment->Center, Spacings->{2,1}
],

lattice=="Rhombohedral",
Grid[{
{Style["a=1",12],
Style["b=a",12],
Style["c=a",12]
},
{Control[{{αAngle,1.4,Dynamic[styleValue["α=",αAngle]]},0.01,π/2,Labeled->True,AppearanceElements->{"InputField"}}],
βAngle=αAngle;Style[StringJoin[{"β=",ToString[αAngle]}],12],
γAngle=αAngle;Style[StringJoin[{"γ=",ToString[αAngle]}],12]
}
}, Alignment->Center, Spacings->{2,1}
],

lattice=="Tetragonal",
Grid[{
{Style["a=1",12],
Style["b=a",12],
Control[{{c,1.2,Dynamic[styleValue["c/a=",c]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}]
},
{Style["α=(π/2)",12],Style["β=(π/2)",12],Style["γ=(π/2)"]}
}, Alignment->Center, Spacings->{2,1}
],

lattice=="Cubic",
Grid[{
{Style["a=1",12],
Style["b=a",12],
Style["c=a",12]
},
{Style["α=(π/2)",12],Style["β=(π/2)",12],Style["γ=(π/2)",12]}
}, Alignment->Center, Spacings->{2,1}
],

lattice=="Monoclinic",
Grid[{
{
Style["a=1",12],
Control[{{b,1.1,Dynamic[styleValue["b/a=",b]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}],Control[{{c,1.2,Dynamic[styleValue["c/a=",c]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}]
},

{
Style["α=(π/2)",12],
Control[{{βAngle,1.2,Dynamic[styleValue["β=",βAngle]]},0.01,0.99π/2,Labeled->True,AppearanceElements->{"InputField"}}],
Style["γ=(π/2)",12]
}
},
Alignment->Center,Spacings->{2,1}],
lattice=="Triclinic",
Grid[
{
{Style["a=1",12],
Control[{{b,1.1,Dynamic[styleValue["b/a=",b]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}],
Control[{{c,1.2,Dynamic[styleValue["c/a=",c]]},0.05`,10,Labeled->True,AppearanceElements->{"InputField"}}]
},
{
Control[{{αAngle,1.2,Dynamic[styleValue["α=",αAngle]]},0.01,0.99π/2,Labeled->True,AppearanceElements->{"InputField"}}],
Control[{{βAngle,1.1,Dynamic[styleValue["β=",βAngle]]},0.01,0.99π/2,Labeled->True,AppearanceElements->{"InputField"}}],
Control[{{γAngle,0.9,Dynamic[styleValue["γ=",γAngle]]},0.01,0.99π/2,Labeled->True,AppearanceElements->{"InputField"}}]
}
}
,
Alignment->Center,Spacings->{2,1}]
]
],
Delimiter,
Dynamic[
Row[
{
Control[{{pointGroup,latticeSystem[lattice]["Point Groups"][[1]],Style["Point Group",13]},Thread[latticeSystem[lattice]["Point Groups"]->groupLabels/@latticeSystem[lattice]["Point Groups"]
]}],"\t",

OpenerView[{Style["Point Group and Plane Info",12],Column[
{RadioButtonBar[Dynamic[schematicView],{"Info"->Style["(hkl)-Plane and Count",10],"Show Planes"->Style["Show Plane",10],"Show Equivalent Planes"->Style["Show Equivalent Planes",10]}],
Dynamic[
Which[
schematicView=="Info",With[{facetInfo= Map[Length,wulffData["Miller Equivalent Directions"]]},
Grid[Transpose@MapThread[{Style[#1,12],Style[ToString[#2]<>" planes",12]}&,{Keys[facetInfo],Values[facetInfo]}],Alignment->Left,Frame->All]
],
schematicView=="Show Planes",With[{schematic=drawPlaneSchematic[lattice,{{1,b,c},{αAngle,βAngle,γAngle}},activeDirections,activeCol]},
schematic
],
True,
drawAllPlanesSchematic[lattice,{{1,b,c},{αAngle,βAngle,γAngle}},wulffShapeData["Colors And Directions"]]
]
]
}
]},
Method->Active
]

}
]
],
Delimiter,
Dynamic[
Grid[
{
{"",
Rasterize[
Cell[TextData[{"γ[",overbarFormat[i[1]]," ",overbarFormat[j[1]],overbarFormat[k[1]],"]","/",go," = 1 "}],"Text",FontSize->14,Background->GrayLevel[0.9625]
]
],

Control[{{i[1],1,""},Range[-5,5]}],
Control[{{j[1],0,""},Range[-5,5]}],
Control[{{k[1],0,""},Range[-5,5]}],
Control[{{col[1],ColorData[54][1],""},Red}]
}

,
{
Control[{{active[2],True,""},{True,False}}],
Control[{{γ[2],1.0,Dynamic[Row@{ijkFormat[{i[2],j[2],k[2]}][γ[2]]}]},1,2, AppearanceElements->{"InputField"}}],
Control[{{i[2],1,""},Range[-5,5]}],
Control[{{j[2],1,""},Range[-5,5]}],
Control[{{k[2],1,""},Range[-5,5]}],
Control[{{col[2],ColorData[54][2],""},Red}]
},

{
Control[{{active[3],True,""},{True,False}}],
Control[{{γ[3],1.0,Dynamic[Row@{ijkFormat[{i[3],j[3],k[3]}][γ[3]]}]},1,2, AppearanceElements->{"InputField"}}],
Control[{{i[3],1,""},Range[-5,5]}],
Control[{{j[3],1,""},Range[-5,5]}],
Control[{{k[3],0,""},Range[-5,5]}],
Control[{{col[3],ColorData[54][3],""},Red}]
},

{
Control[{{active[4],True,""},{True,False}}],
Control[{{γ[4],1.0,Dynamic[Row@{ijkFormat[{i[4],j[4],k[4]}][γ[4]]}]},1,2, AppearanceElements->{"InputField"}}],
Control[{{i[4],-1,""},Range[-5,5]}],
Control[{{j[4],-2,""},Range[-5,5]}],
Control[{{k[4],-1,""},Range[-5,5]}],
Control[{{col[4],ColorData[54][4],""},Red}]
}
}
]
],
Dynamic[OpenerView[{Style["Surface Tensions (facets 5-8)",14],
Dynamic[Column[
{Row[{Control[{{active[5],False,""},{True,False}}],Control[{{γ[5],1.0,Dynamic[Row@{ijkFormat[{i[5],j[5],k[5]}][γ[5]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[5],1,""},Range[-5,5]}],Control[{{j[5],-1,""},Range[-5,5]}],Control[{{k[5],1,""},Range[-5,5]}],Control[{{col[5],ColorData[24][5],""},Red}]}],

Row[{Control[{{active[6],False,""},{True,False}}],Control[{{γ[6],1.0,Dynamic[Row@{ijkFormat[{i[6],j[6],k[6]}][γ[6]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[6],1,""},Range[-5,5]}],Control[{{j[6],-1,""},Range[-5,5]}],Control[{{k[6],1,""},Range[-5,5]}],Control[{{col[6],ColorData[24][6],""},Red}]}]
,

Row[{Control[{{active[7],False,""},{True,False}}],Control[{{γ[7],1.0,Dynamic[Row@{ijkFormat[{i[7],j[7],k[7]}][γ[7]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[7],1,""},Range[-5,5]}],Control[{{j[7],-1,""},Range[-5,5]}],Control[{{k[7],1,""},Range[-5,5]}],Control[{{col[7],ColorData[24][7],""},Red}]}]
,

Row[{Control[{{active[8],False,""},{True,False}}],Control[{{γ[8],1.0,Dynamic[Row@{ijkFormat[{i[8],j[8],k[8]}][γ[8]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[8],1,""},Range[-5,5]}],Control[{{j[8],-1,""},Range[-5,5]}],Control[{{k[8],1,""},Range[-5,5]}],Control[{{col[8],ColorData[24][8],""},Red}]}]

}]]}]],

Dynamic[OpenerView[{Style["Surface Tensions (facets 9-12)",14],Dynamic[Column[{
Row[{Control[{{active[9],False,""},{True,False}}],Control[{{γ[9],1.0,Dynamic[Row@{ijkFormat[{i[9],j[9],k[9]}][γ[9]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[9],1,""},Range[-5,5]}],Control[{{j[9],-1,""},Range[-5,5]}],Control[{{k[9],1,""},Range[-5,5]}],Control[{{col[9],ColorData[24][9],""},Red}]}]
,

Row[{Control[{{active[10],False,""},{True,False}}],Control[{{γ[10],1.0,Dynamic[Row@{ijkFormat[{i[10],j[10],k[10]}][γ[10]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[10],1,""},Range[-5,5]}],Control[{{j[10],-1,""},Range[-5,5]}],Control[{{k[10],1,""},Range[-5,5]}],Control[{{col[10],ColorData[24][10],""},Red}]}]
,

Row[{Control[{{active[11],False,""},{True,False}}],Control[{{γ[11],1.0,Dynamic[Row@{ijkFormat[{i[11],j[11],k[11]}][γ[11]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[11],1,""},Range[-5,5]}],Control[{{j[11],-1,""},Range[-5,5]}],Control[{{k[11],1,""},Range[-5,5]}],Control[{{col[11],ColorData[24][11],""},Red}]}]
,

Row[{Control[{{active[12],False,""},{True,False}}],Control[{{γ[12],1.0,Dynamic[Row@{ijkFormat[{i[12],j[12],k[12]}][γ[12]]}]},1,2, AppearanceElements->{"InputField"}}],Control[{{i[12],1,""},Range[-5,5]}],Control[{{j[12],-1,""},Range[-5,5]}],Control[{{k[12],1,""},Range[-5,5]}],Control[{{col[12],ColorData[24][12],""},Red}]}]

}]]}]],
Delimiter,
{{viewType,"Graphics",Style["View:",14]},{"Graphics"->Style["Wulff Shape",12],"Information"->Style["Info",12],
"About"->Style["About",12]}, ControlType->RadioButtonBar}
]
,
{{lattice,"Cubic"},allLatticeTypes}
],
SaveDefinitions->True
];

Source

Formatting Functions

go =Cell[BoxData[FormBox[SubscriptBox["γ","o"],TraditionalForm]],FormatType->TraditionalForm];

overbarFormat[n_]:= Which[n>= 0, ToString[n],True,Cell[BoxData[FormBox[OverscriptBox[ToString[Abs[n]],"_"],TraditionalForm]],FormatType->TraditionalForm]]

ijkFormat[ijk:{i_,j_, k_}][γ_]:=
Rasterize[
Cell[TextData[{"γ[",overbarFormat[i]," ",overbarFormat[j],overbarFormat[k],"]","/",go ,"= ",ToString[NumberForm[γ,{3,3}]]}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
]

fractionFormat[{n_,d_}]:= Cell[BoxData[FormBox[FractionBox[n,d],TraditionalForm]],FormatType->TraditionalForm]

groupLabels  =
<|
"1"->Rasterize[
Cell[TextData[{overbarFormat[1]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-1"->Rasterize[
Cell[TextData[{overbarFormat[-1]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"2"->Rasterize[
Cell[TextData[{overbarFormat[2]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"m"->Rasterize[
Cell[TextData[{"m"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"2/m"->Rasterize[
Cell[TextData[{fractionFormat[{"2","m"}]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"222"->Rasterize[
Cell[TextData[{"222"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"mm2"->Rasterize[
Cell[TextData[{"mm2"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"mmm"->Rasterize[
Cell[TextData[{"mmm"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"4"->Rasterize[
Cell[TextData[{"4"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-4"->Rasterize[
Cell[TextData[{overbarFormat[-4]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"4/m"->Rasterize[
Cell[TextData[{fractionFormat[{"4","m"}]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"422"->Rasterize[
Cell[TextData[{"442"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"4mm"->Rasterize[
Cell[TextData[{"4mm"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-42m"->Rasterize[
Cell[TextData[{overbarFormat[-4],"m2"}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"4/mmm"->Rasterize[
Cell[TextData[{fractionFormat[{4,"m"}],fractionFormat[{2,"m"}],fractionFormat[{2,"m"}]}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"3"->Rasterize[
Cell[TextData[{"3"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-3"->Rasterize[
Cell[TextData[{overbarFormat[-3]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"32"->Rasterize[
Cell[TextData[{"32"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"3m"->Rasterize[
Cell[TextData[{"3m"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-3m"->Rasterize[
Cell[TextData[{overbarFormat[-3],fractionFormat[{2,"m"}]}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"6"->Rasterize[
Cell[TextData[{"6"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-6"->Rasterize[
Cell[TextData[{overbarFormat[-6]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"6/m"->Rasterize[
Cell[TextData[{fractionFormat[{"6","m"}]}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"622"->Rasterize[
Cell[TextData[{"622"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"6mm"->Rasterize[
Cell[TextData[{"6mm"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-6m2"->Rasterize[
Cell[TextData[{overbarFormat[-6],"m2"}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"6/mmm"->Rasterize[
Cell[TextData[{fractionFormat[{6,"m"}],fractionFormat[{2,"m"}],fractionFormat[{2,"m"}]}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"23"->Rasterize[
Cell[TextData[{"23"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"m-3"->Rasterize[
Cell[TextData[{fractionFormat[{2,"m"}],overbarFormat[-3]}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"432"->Rasterize[
Cell[TextData[{"432"}],"Text",FontSize->12,Background->GrayLevel[0.9625]
]
],
"-432"->Rasterize[
Cell[TextData[{overbarFormat[-4],"32"}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
],
"m-3m"->Rasterize[
Cell[TextData[{fractionFormat[{4,"m"}],overbarFormat[-3],fractionFormat[{2,"m"}]}],"Text",FontSize->10,Background->GrayLevel[0.9625]
]
]
|>;

Display functions

bravaisLatticeGraphic[lattice_,spec:{{a_,b_,c_},angles:{α_,β_,γ_}}]:=
Block[{
corners,
planeNormals,
maxCorner },
corners = reciprocalLatticeVector[lattice][spec][#]&/@Tuples[{-1,1},3];
<|"Max Dimension"->Max[Abs[corners]],
"Graphic"->
GraphicsComplex[
corners,
{Opacity[0.02],FaceForm[],EdgeForm[Directive[Black,Thickness[0.01]]],
Polygon[{1,3,7,5}],
Polygon[{2,6,8,4}],
Polygon[{1,5,6,2}],
Polygon[{4,8,7,3}],
Polygon[{4,3,1,2}],
Polygon[{5,7,8,6}]
}
]
|>
]

infinitePlane[transformationFunctionLatticeToCartesian_][dir:{h_,k_,l_}]:= With[{n=transformationFunctionLatticeToCartesian.Normalize[dir] },
Hyperplane[n,n]
]

planeGraphic[lattice_,spec:{{a_,b_,c_},angles:{α_,β_,γ_}},dir:{h_,k_,l_},color_]:=
With[{normal =reciprocalLatticeVector[lattice][spec][dir]},
{color,Hyperplane[normal,normal]}
]

drawPlaneSchematic[lattice_,spec:{{a_,b_,c_},angles:{α_,β_,γ_}},directions_,colors_]:=Block[{corners,planeNormals,maxCorner},corners=(reciprocalLatticeVector[lattice][spec][#1]&)/@Tuples[{-1,1},3];
planeNormals=(reciprocalLatticeVector[lattice][spec][#1]&)/@directions;Graphics3D[{
{
GraphicsComplex[corners,
{Opacity[0.2`],FaceForm[],EdgeForm[Directive[Black,Thickness[0.01`]]],Polygon[{1,3,7,5}],
Polygon[{2,6,8,4}],
Polygon[{1,5,6,2}],
Polygon[{4,8,7,3}],
Polygon[{4,3,1,2}],
Polygon[{5,7,8,6}]}]
},
{Opacity[0.625`],
MapThread[{#1,Hyperplane[#2,#2]}&,{colors,planeNormals}]},Black,(Arrow[Tube[{{0,0,0},#1},0.01`]]&)/@planeNormals,
Sphere[{0,0,0},0.01`]},
PlotRange->2 Abs[Max[Flatten[corners]]] {{-1,1},{-1,1},{-1,1}},
Boxed->False,
ImageSize->150,
SphericalRegion->True]]

drawAllPlanesSchematic[lattice_,spec:{{a_,b_,c_},angles:{α_,β_,γ_}},colorsAndDirections_]:=
With[{bravais =bravaisLatticeGraphic[lattice,spec]},
Graphics3D[
{bravais["Graphic"],
Opacity[0.1],
Map[planeGraphic[lattice,spec,Last[#],First[#]]&,Flatten[dWulffData["Colors and Directions"],1]]
},
PlotRange->1.5 bravais["Max Dimension"] {{-1,1},{-1,1},{-1,1}},
Boxed->False,
ImageSize->150,
SphericalRegion->True
]
]

Symmetry operators

identity = IdentityMatrix[3];
inversion=-IdentityMatrix[3];
c2X=RotationMatrix[((2 π)/2),{1,0,0}];
c2Y=RotationMatrix[((2 π)/2),{0,1,0}];
c2Z= RotationMatrix[((2 π)/2),{0,0,1}];
c3Z= RotationMatrix[((2 π)/3),{0,0,1}];
c4Z= RotationMatrix[((2 π)/4),{0,0,1}];
c6Z= RotationMatrix[((2 π)/6),{0,0,1}];
s4Z= RotationMatrix[((2 π)/4),{0,0,1}];

σV=ReflectionMatrix[{0,1,0}];  (*mirror in xz*)
σH=ReflectionMatrix[{0,0,1}];  (*mirror in xy*)
(σD = RotationMatrix[((2 π)/8),{0,0,1}].σV.RotationMatrix[-((2 π)/8),{0,0,1}])//MatrixForm

symmetryGenerators=<|"1"->{identity},(*identity only*)
"-1"->{identity,inversion},
"2"->{identity,c2Z},
"m"->{identity,σV},
"2/m"->{identity,c2Z,σH},
"222"->{identity,c2X,c2Y},
"mm2"->{identity,c2Z,σV},
"mmm"->{identity,c2X,c2Y,σH},
"4"->{identity,c4Z},
"-4"->{identity,s4Z},
"4/m"->{identity,c4Z,σH},
"422"->{identity,c4Z,c2X},
"4mm"->{identity,c4Z,σV},
"-42m"->{identity,s4Z,σD},
"4/mmm"->{identity,c4Z,c2X,σH},
"3"->{identity,c3Z},
"-3"->{identity,c3Z,inversion},(*or S6 if preferred*)"32"->{identity,c3Z,c2X},
"3m"->{identity,c3Z,σV},
"-3m"->{identity,c3Z,σH},(*D3d*)
"6"->{identity,c6Z},
"-6"->{identity,c6Z,inversion},(*S6*)
"6/m"->{identity,c6Z,σH},
"622"->{identity,c6Z,c2X},
"6mm"->{identity,c6Z,σV},
"-6m2"->{identity,c6Z,σV,σH},
"6/mmm"->{identity,c6Z,c2X,σH},
"23"->{identity,
RotationMatrix[((2π)/3),{1,1,1}],c2X},
"m-3"->{identity,RotationMatrix[((2π)/3),{1,1,1}],c2X,inversion},"432"->{identity,c4Z,RotationMatrix[((2π)/3),{1,1,1}]},"-432"->{identity,RotationMatrix[((2π)/3),{1,1,1}],σD},"m-3m"->{identity,c4Z,RotationMatrix[((2π)/3),{1,1,1}],σH}|>;

allLatticeTypes = {"Triclinic","Monoclinic","Orthorhombic","Tetragonal","Rhombohedral","Hexagonal","Cubic"}

Generating all symmetries for crystallographic groups

impliedSymmetries[listOfSymmetryMatrices_]:= SortBy[
Union@Flatten[
Outer[Simplify[#1.#2] &,listOfSymmetryMatrices,listOfSymmetryMatrices,1 ], 1],
(#- IdentityMatrix[3])^2 &
]

For example

(*impliedSymmetries[ groupMatrixOperations["6/m"]]*)

(*impliedSymmetries[groupMatrixOperations["mmm"]]*)

(*impliedSymmetries[symmetryGenerators["-3m"]]*)

Generate list of all operations in a point group.

allSymmetryOperations[groupName_String]:=(*allSymmetryOperations[groupName]= *)
FixedPoint[
impliedSymmetries[#]&,symmetryGenerators[groupName]]

For example

(*allSymmetryOperations["432"]*)

Functions to find of all equivalent normals for the  Point Groups

Writing a function to find the result of applying each of the implied symmetry operations to a given normal (i..e, the list of all equivalent normals.

Here we have the function generated a memoized function.

These functions are called by a helper function like equivalentDirections[“6/mmm”][{1, 2, 1}]

This won’t work unless groupName is one the symmetries.  It would be better to check that for bullet proof code.

Clear[equivalentDirectionsFunction];
equivalentDirectionsFunction[groupName_]:= equivalentDirectionsFunction[groupName]=
 Block[
{$x,$y,$z, directions},
directions = Union[#.{$x,$y,$z}&/@allSymmetryOperations[groupName]];
Function[{$x,$y,$z},Evaluate[Simplify[directions]]]
]

Clear[equivalentNormalsFunction];
equivalentNormalsFunction[groupName_][x_,y_,z_]:= ((equivalentDirectionsFunction[groupName][x,y,z])/(Sqrt[(x^(2 )) + (y^2) + (z^2)]))

For example

(*equivalentDirectionsFunction["6/m"]*)

Create  a function which takes a group and calls the function on a normal.  This produces all equivalent normals of the argument

equivalentDirections[groupName_][n:{n1_,n2_, n3_}]:= Simplify[Union[equivalentDirectionsFunction[groupName][n1,n2,n3]]]

equivalentNormals[groupName_][n:{n1_,n2_, n3_}]:= Simplify[Union[equivalentNormalsFunction[groupName][n1,n2,n3]]]

For example

(*equivalentDirections["6/mmm"][{1,0,0}]*)

(*Graphics3D[{
Arrow[{{0,0,0},#}]&/@equivalentDirections["-6"][{1,0,1}]
}
]*)

Conventional Lattice Parameters

Bravais Lattice Summary Text

Triclinic

conventionalLatticeVectors["Triclinic"][{{a_,b_, c_},{α_,β_, γ_}}]:=
With[{zTerm = ((Cos[α]- Cos[β]Cos[γ])/(Sin[γ]))},
{
a{1,0,0},
b{Cos[γ],Sin[γ],0},
c{Cos[β],zTerm, (Sqrt[1 - ((Cos[β])^2) -(zTerm^2)])}
}
]

Monoclinic

conventionalLatticeVectors["Monoclinic"][{{a_,b_, c_},{α_,β_, γ_}}]:=
{
a{1,0,0},
b{0,1,0},
c{Cos[β],0, Sin[β]}
}

Orthorhombic

conventionalLatticeVectors["Orthorhombic"][{{a_,b_, c_},{α_,β_, γ_}}]:=
{
a{1,0,0},
b{0,1,0},
c{0,0, 1}
}

Tetragonal

conventionalLatticeVectors["Tetragonal"][{{a_,b_, c_},{α_,β_, γ_}}]:=
{
a{1,0,0},
a{0,1,0},
c{0,0, 1}
}

Cubic

conventionalLatticeVectors["Cubic"][{{a_,b_, c_},{α_,β_, γ_}}]:=
{
a{1,0,0},
a{0,1,0},
a{0,0, 1}
}

Hexagonal

conventionalLatticeVectors["Hexagonal"][{{a_,b_, c_},{α_,β_, γ_}}]:=
{
a{1,0,0},
a{(1/2),((Sqrt[3])/2),0},
c{0,0, 1}
}

Rhombohedral

Simplify[conventionalLatticeVectors["Triclinic"][{{a,a,a},{α,α,α}}]]

conventionalLatticeVectors["Rhombohedral"][{{a_,b_, c_},{α_,β_, γ_}}]:=
{{a,0,0},{a Cos[α],a Sin[α],0},{a Cos[α],a Cos[α] Tan[(α/2)],a (Sqrt[(1+2 Cos[α]) ((Tan[(α/2)])^2)])}}

Lattice Systems and Point Groups

latticeSystem = 
<|"Triclinic"->\[LeftAssociation]"Point Groups"->{"1","-1"},"Transform to Cartesian"->triclinicToCartesian,"Cartesian to Lattice"->cartesianToTriclinic\[RightAssociation],

"Monoclinic"->\[LeftAssociation]"Point Groups"->{"2","2/m","m"},"Transform to Cartesian"->monoclincToCartesian,"Cartesian to Lattice"->cartesianToMonoclinic\[RightAssociation],

"Orthorhombic"->\[LeftAssociation]"Point Groups"->{"222","mmm","mm2"},"Transform to Cartesian"->orthorhombicToCartesian,"Cartesian to Lattice"->cartesianToOrthorhombic\[RightAssociation],

"Tetragonal"->\[LeftAssociation]"Point Groups"->{"4","-4","4/m","422","4mm","-42m","4/mmm"},"Transform to Cartesian"->tetragonalToCartesian,"Cartesian to Lattice"->cartesianToTetragonal\[RightAssociation],

"Rhombohedral"->\[LeftAssociation]"Point Groups"->{"3","-3","32","3m","-3m"},"Transform to Cartesian"->rhombohedralToCartesian,"Cartesian to Lattice"->cartesianToRhombohedral\[RightAssociation],

"Hexagonal"->\[LeftAssociation]"Point Groups"->{"6","-6","6/m","622","6mm","-6m2","6/mmm"},"Transform to Cartesian"->hexagonalToCartesian,"Cartesian to Lattice"->cartesianToHexagonal\[RightAssociation],

"Cubic"->\[LeftAssociation]"Point Groups"->{"23","m-3","432","-432","m-3m"},"Transform to Cartesian"->cubicToCartesian,"Cartesian to Lattice"->cartesianToCubic\[RightAssociation]
|>;

pointGroupNames = Flatten@Values[latticeSystem][[All,"Point Groups"]]

Reciprocal Lattice Vectors

Leaving off factor of 2π   for reciprocal lattice vectors here
General formula comes from:
Choose the most general direct vectors in Cartesian:
).
Then the reciprocal basis is always

with ).
So



The Hexagonal and Rhombohedral are chosen for the conventional cell

Summary Table

Triclinic

reciprocalLatticeVector["Triclinic"][spec:{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=
(h/a){1,-Cot[γ],(Csc[γ] (Cos[α] Cot[γ]-Cos[β] Csc[γ]))/( √(1-((Cos[β])^2)-(((Cos[β] Cot[γ]-Cos[α] Csc[γ]))^2)))} +(k/b){0,Csc[γ],(Csc[γ] (Cos[β] Cot[γ]-Cos[α] Csc[γ]))/(√(1-((Cos[β])^2)-(((Cos[β] Cot[γ]-Cos[α] Csc[γ]))^2)))}+(l/c){0,0,1/( √(1-((Cos[β])^2)-(((Cos[β] Cot[γ]-Cos[α] Csc[γ]))^2)))}

Monoclinic

reciprocalLatticeVector["Monoclinic"][{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=

{(h/a),(k/b),(l/(c Sin[β]))- ((h Cos[β])/(a Sin[β]))}

Orthorhombic

reciprocalLatticeVector["Orthorhombic"][{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=
{
(h/a),(k/b), (l/c)
}

Tetragonal

reciprocalLatticeVector["Tetragonal"][{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=
{
(h/a),(k/a), (l/c)
}

Cubic

reciprocalLatticeVector["Cubic"][{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=
(1/a){h,k,l}

Hexagonal

reciprocalLatticeVector["Triclinic"][{{a,b, c},{π/2,π/2, 2π/3}}][{h,k,l}]

reciprocalLatticeVector["Hexagonal"][{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=
{
(h/a),((2k-h)/((Sqrt[3])a)), (l/c)
}

Rhombohedral

Simplify[reciprocalLatticeVector["Triclinic"][{{a,a,a},{α,α,α}}][{h,k,l}]]

reciprocalLatticeVector["Rhombohedral"][{{a_,b_, c_},{α_,β_, γ_}}][{h_,k_,l_}]:=
{(h/a),((-h Cot[α]+k Csc[α])/a),(((l-(h+k-l) Cos[α]) ((Sec[(α/2)])^2))/(2 a (Sqrt[(1+2 Cos[α]) ((Tan[(α/2)])^2)])))}

reporting functions

wulffCalculationSummary[wulffShapeData_, normalsData_]:=
Block[{facetAreasAssoc,γAssoc,countAssoc,facetContributionToEnergy,facetEnergy,facetGraphics},
facetAreasAssoc= Association[DeleteDuplicatesBy[wulffShapeData["Polygon Areas"],First[#]&]];
γAssoc=wulffShapeData["Original γ"];
countAssoc =With[{wsd= wulffShapeData["Normal Families"]},Association[(#->Count[Values[wsd],#])&/@Union[Values[wsd]]]];
facetContributionToEnergy = <|Map[#1-> countAssoc[#1]γAssoc[#]facetAreasAssoc[#]&,Keys[ γAssoc]]|>;
facetEnergy= <|Map[#1-> γAssoc[#]facetAreasAssoc[#]&,Keys[ γAssoc]]|>;
facetGraphics= facetGraphics =extractFlatFacetGraphics[wulffShapeData];
Column[
{Grid[
Prepend[
{#,
wulffShapeData["Original γ"][#],
facetAreasAssoc[#],
wulffShapeData["Facet Counts"][#],
facetEnergy[#],
facetEnergy[#] wulffShapeData["Facet Counts"][#]
,
facetGraphics[#]
}&/@Keys[facetAreasAssoc],
Style[#,{FontSize->14, FontFamily->"Arial"}]&/@{"Facet","Specfic\nSurface\nTension", "Area","Number","Facet Energy","Facet\nContribution\nto\nEnergy",""}
]
,
Frame->All
],
Grid[
Prepend[
{#,
normalsData["Miller Equivalent Directions"][#]}&/@Keys[facetAreasAssoc],
Style[#,{FontSize->14, FontFamily->"Arial"}]&/@{"Facet","Equivalent\nFacets"}
],
Frame->All, Alignment->Left
]
}
]
]

Draw Facets in the plane

makeFlatPolygon[coordinates_, normal_]:=Block[
{flatPolygon},
flatPolygon= 
Which[
AllSameBy[Last/@coordinates,Round[#,.00001]&],
Most/@coordinates,
AllSameBy[coordinates[[All,2]],Round[#,.00001]&],
coordinates[[All,{1,3}]],
AllSameBy[First/@coordinates,Round[#,.00001]&],
Rest/@coordinates,
True,
Most/@(RotationTransform[{normal,{0,0,1}}][coordinates])
];
flatPolygon - Threaded[Mean[flatPolygon]]
]

getFacetStructure[wulffShape_]:=
Association[MapThread[#1->
<|"Polygon"->#2,
 "Flat Polygon Coordinates"-> (*Echo@*)makeFlatPolygon[#2,#1],
"Normal"->#3, "Color"->#4|>&,{wulffShape["Normals"]/.Normal[wulffShape["Normal Families"]],wulffShape["Facets"], wulffShape["Normals"],wulffShape["Normal Colors"]/@wulffShape["Normals"]}]
]

extractFlatFacetGraphics[wulffShape_]:=
Block[
{
facetStruct =getFacetStructure[wulffShape],
maxCoordinate
 },
maxCoordinate = Max[Abs[Flatten[Values[facetStruct][[All,"Flat Polygon Coordinates"]]]]];
Association[
MapThread[#1->Graphics[{#2,Polygon[#3]},
ImageSize->100,PlotRange->maxCoordinate{{-1,1},{-1,1}}]&,
{Keys[facetStruct],
Flatten[Values[facetStruct][[All,"Color"]]],
Values[facetStruct][[All,"Flat Polygon Coordinates"]]
}
]
]
]

infoText=
"Code and Interface:W.Craig Carter 2026.

Please attribute or cite.This version should be considered a beta.Please inform me if you find any errors.
Comments are also welcome:ccarter@mit.edu

Normalization and units:The first facet has its surface tension γ=(Subscript[γ, o]) energy/(length^2). 
All facets' γ are non-dimensionalized to (Subscript[γ, o]):γ[hkl]/(Subscript[γ, o]).If you know the energy of the first facet,then you can compute any of the others.Energies of the facets and other information are avaiable in the Information Pane.

Note:
The Wulff shape lives in a space where length is in units of energy/(length^2),therefore
the volume of the Wulffshape has units (energy/(length^2))^3 which isn't terribly meaningful.If you think you have need to know the volume,you can sift through the code,but I don't mind being asked to include such information.I omit it because it is prone to misinterpretation.

What can go wrong:
1) If wulff shape is not complete---that is,there is no facet to close the wulff shape (imagine a box without a lid),then there will be a division by zero error.
2)
If you are defining facets but they are not appearing on the Wulff shape there are possibly two issues:
a) The facet's surface tension γ is too large.This is the trivial case,reduce its value to see if it appears.
b) There are two entries that contain the same family of normals (e.g.,for cubic symmetry when[100] and[001] are active facets) then only one of the equivalent facets
will be used.

There is a maximum number of facets:12. This is not a limitation of the algorithm or calculation time.

The number is limited because the interface gets kludgy.If you need more than 12 facets,then it would be better to use the functions:wulffData=createNormalsData[pointGroup][Transpose[MapThread[{#1,#2,#3}&,{directions,γ,color}]]];
wulffShapeData=wulffShapeConstruction[wulffData];
where directions is a list of directions like {{1,1,1},{1,0,0},etc} γ is a list of facet energies {1,1.1,1.4,..},and color is a list of colors {Red,RGBColor[1,0.5,0.1],..)

A previous version of this software,Wulffmaker,http://pruffle.mit.edu/wulffmaker/had some errors.This version has more functionality and hopefully... no errors.Wulff shape calculation algorithm is the (Polar Dual→Convex Hull→Polar Dual→Convex Hull) described in Roosen,McCormack,Carter,\"Wulffman: A tool for the calculation and display of crystal shapes\" https://doi.org/10.1016/S0927-0256(97)00167-5
";

errorText= "Failed to compute a valid Wulff shape.What can go wrong:If wulff shape is not complete---that is,there is no facet to close the wulff shape (imagine a box without a lid),sometimes this will result in a division by zero error.This typically happens with low symmetry point groups like 1 or \"-1\".To fix,you will need to add more facets to close the Wulff Polyhedron"

Compute equivalent normals and organize data

Clear[getNormalsDataStructure]

findNearestNormal[nf_][normal_]:= First[nf[normal]]

getNormalsDataStructure[lattice_,groupName_,spec:{{a_,b_,c_},angles:{α_,β_,γ_}},OptionsPattern[]][normalsColorsGammaTransposed_]:=
Block[
{allData = 
Association[
Flatten[MapThread[equivalentFacetsData[lattice,groupName,spec, "Color"->#3, "γ"->#2][#1]&,normalsColorsGammaTransposed],
1]
],
allCartesianNormals,
allCartesianGammaVectors,
nearestNormalFunction,
correspondingMillerIndices,
correspondingColors,
allMillerIndices,
allDualVectors,
colorsDirections

},
allMillerIndices= Keys[allData];
allCartesianNormals=Flatten[Values[allData][[All,"Equivalent Cartesian Normals"]],1];
allCartesianGammaVectors=Flatten[Values[allData][[All,"Cartesian γ-vectors"]],1];
nearestNormalFunction =findNearestNormal[ Nearest[allCartesianNormals,DistanceFunction->SquaredEuclideanDistance]];
correspondingMillerIndices=With[{allCorresponding= Flatten[Values[allData][[All,"Cartesian Normal To Original Miller"]],1]},
Association[Catenate[Normal/@allCorresponding]]
];
correspondingColors=With[{allCorresponding= Flatten[Values[allData][[All,"Cartesian Normal To Color"]],1]},
Association[Catenate[Normal/@allCorresponding]]
];

colorsDirections = With[{
color =allData[#]["Color"],
directions =allData[#]["Equivalent Miller Indices"] },
{color,# }&/@directions
]&/@Keys[allData];

allDualVectors=Flatten[Values@Query[All,"Cartesian Dual Vectors"][allData],1];
<|
"Lattice"->lattice,
"Point Group"->groupName,
"All Miller Indices"->allMillerIndices,
"Miller Equivalent Directions"->allData[[All,"Equivalent Miller Indices"]],
"All Cartesian Normals"->allCartesianNormals,
"All Cartesian Dual Vectors"->allDualVectors,
"All Cartesian γ-vectors"->allCartesianGammaVectors,
"Nearest Normal"->nearestNormalFunction,
"Cartesian Normals Corresponding Miller"->correspondingMillerIndices,
"Cartesian Normals Corresponding Color"->correspondingColors,
"Original γ"->Association[MapThread[#1->#2&,Most[normalsColorsGammaTransposed]]],
"Colors and Directions"->colorsDirections

|>


]

Compute equivalent facets and organize data

Clear[equivalentFacetsData];Options[equivalentFacetsData]= {"γ"->1,"Color"->Gray};

equivalentFacetsData[lattice_,groupName_,spec:{{a_,b_,c_},angles:{α_,β_,γ_}},OptionsPattern[]][millerIndices:{h_,k_, l_}]:=
Block[
{
equivalentMillerIndices = equivalentDirections[groupName][millerIndices],
equivalentCartesianNormals,
cartesianDirection
},

cartesianDirection = reciprocalLatticeVector[lattice][spec][millerIndices];

equivalentCartesianNormals=
(*Round[#,.000001]&/@*)equivalentNormals[groupName][cartesianDirection];

millerIndices->
<|
"Equivalent Miller Indices"->equivalentMillerIndices,
"Equivalent Cartesian Normals"->equivalentCartesianNormals,
"γ"->OptionValue["γ"],
"Color"->OptionValue["Color"],
"Cartesian γ-vectors"->OptionValue["γ"]equivalentCartesianNormals,
"Cartesian Dual Vectors"->equivalentCartesianNormals/OptionValue["γ"],
"Cartesian Normal To Original Miller"->
<|#->millerIndices&/@equivalentCartesianNormals|>,
"Cartesian Normal To Color"->
<|#->OptionValue["Color"]&/@equivalentCartesianNormals|>
|>
]

Polar dual → convex hull  → Polar dual → convex hull  method to compute Wulff Shape

facetNormal[listOfPolygonVertices_]:=Block[{p1,p2,p3},{p1,p2,p3}=Take[listOfPolygonVertices,3];Normalize[(p2-p1)\[Cross](p3-p2)]]

wulffShapeConstruction[getNormalsDataStructureResult_, OptionsPattern[]]:=
Block[
{
wulffDualVectors = getNormalsDataStructureResult["All Cartesian Dual Vectors"],
wulffDual,dualCoordinates,
dualFacets,convexifiedDualFacetCoordinates,convexifiedDualFacetNormals,convexifiedDualFacetDistances,
wulffVertices,wulffShape,wulffFacetPolygons,wulffFacetAreas,maxCoordinate,
wulffFacetCoordinates,wulffFacetNormals,wulffFacetNearestNormal,wulffGraphic,
wulffFacetColors


},

If[Length[getNormalsDataStructureResult["All Miller Indices"]]==0,
Return[<|"Valid Shape"->False|>]
];


wulffDual=ConvexHullRegion[wulffDualVectors];
If[!(Head[wulffDual]=== Polyhedron),
Return[<|"Valid Shape"->False|>]
];


dualCoordinates= PolyhedronCoordinates[wulffDual];

dualFacets=MeshPrimitives[wulffDual,2];
convexifiedDualFacetCoordinates =PolygonCoordinates/@dualFacets;
convexifiedDualFacetNormals=facetNormal/@convexifiedDualFacetCoordinates;
convexifiedDualFacetDistances =
MapThread[Abs[#1.#2]&,{Mean/@convexifiedDualFacetCoordinates,convexifiedDualFacetNormals}];
If[Min[convexifiedDualFacetDistances]< 10^-12,Return[<|"Valid Shape"->False|>]];
wv =wulffVertices =convexifiedDualFacetNormals/convexifiedDualFacetDistances;
(*wulffVertices = OptionValue["Transformation Matrix"].#&/@wulffVertices;*)



wulffShape =ConvexHullRegion[wulffVertices];
wulffFacetPolygons= MeshPrimitives[wulffShape,2];
wulffFacetAreas= Area/@wulffFacetPolygons;
wulffFacetCoordinates = PolygonCoordinates/@wulffFacetPolygons;
maxCoordinate= Max[Abs[Flatten[wulffFacetCoordinates]]];
wulffFacetNormals  = With[{normalsFromConvexHull= facetNormal/@wulffFacetCoordinates},
getNormalsDataStructureResult["Nearest Normal"]/@normalsFromConvexHull];
wulffFacetColors = getNormalsDataStructureResult["Cartesian Normals Corresponding Color"]/@wulffFacetNormals;

wulffGraphic=Graphics3D[MapThread[{#1,#2}&,{wulffFacetColors,wulffFacetPolygons }],Lighting->"Neutral",(*SphericalRegion->True, *)(*Axes->True,*)
PlotRangePadding->0,
ImagePadding->0,
ImageSize->Large,PlotRange->maxCoordinate{{-1,1},{-1,1},{-1,1}}];
<|
"Valid Shape"->True,

"Graphic"->wulffGraphic,

"Vertices"->wulffVertices,
"Polygon Areas"->MapThread[getNormalsDataStructureResult["Cartesian Normals Corresponding Miller"][#1]->#2&,{wulffFacetNormals,wulffFacetAreas}],
"Facets"->PolygonCoordinates/@wulffFacetPolygons,
"Normals"->wulffFacetNormals,


"Normal Families"->getNormalsDataStructureResult["Cartesian Normals Corresponding Miller"],
"Normal Colors"->getNormalsDataStructureResult["Cartesian Normals Corresponding Color"],
"Facet Counts"->With[{norms= getNormalsDataStructureResult["Cartesian Normals Corresponding Miller"],colors = getNormalsDataStructureResult["Cartesian Normals Corresponding Color"] },
Association[
Catenate[
{(#->Count[Values[norms],#])&/@Union[Values[norms]],
(#->Count[Values[colors],#])&/@Union[Values[colors]]
}
]
]
],
"Original γ"-> getNormalsDataStructureResult["Original γ"]
 |>
]