CommutativityPlot.mathematica

CommutativityPlot[group_, OptionsPattern[]] := 
 Module[{els, n, CycleLengths, ConjClasses, conjClasses, ConjClass, 
   ConjClassId, colorList, conjugacyClassColor, regularGridColor, 
   notCommutingColor, commutingColor, indexed, ConjClassSeparator, 
   tickers, markers, mx},
  
  els = GroupElements[group];
  n = Length[els];
  
  (* Initial sorting of elements provides a good approximation for \
sorting by conjugacy class, 
  	and provides a sorting for the conjugacy classes themselves *)
  
  CycleLengths[c_] := Sort[Length /@ c[[1]]];
  els = SortBy[GroupElements[group], 
    Function[g, {CycleLengths[g], g}]];
  
  (* Calculating and sorting by conjugacy classes *)
  
  ConjClass[g_, el_] := GroupOrbits[g, {el}];
  ConjClasses[g_] := DeleteDuplicates[
    Table[
     {ConjClass[g, GroupElements[g][[i]]]}, 
     {i, 1, GroupOrder[g]}
     ]
    ];
  conjClasses = ConjClasses[group];
  ConjClassId[el_] := 
   Position[conjClasses, {ConjClass[group, el]}][[1]][[1]];
  els = SortBy[GroupElements[group], Function[g, {ConjClassId[g], g}]];
  
  (************** Formattings ****************)
  
  colorList = ColorData[45, "ColorList"];
  conjugacyClassColor = colorList[[5]];
  regularGridColor = colorList[[10]];
  
  commutingColor = colorList[[3]];
  notCommutingColor = colorList[[7]];
  
  
  indexed = Thread[{Range[n], els}];
  
  (* Red grid lines for conjugacy classes *)
  
  ConjClassSeparator[p_] := Not[
    p[[1]] + 1 > Length[indexed] ||
     
     p[[1]] + 1 <= Length[indexed] && 
      ConjClassId[indexed[[p[[1]]]][[2]]] == 
       ConjClassId[indexed[[p[[1]] + 1]][[2]]]];
  ticks = If[OptionValue["Ticks"], True, False];
  permutationNames = OptionValue["PermutationNames"];
  tickers = If[ticks,
    Function[p, 
      If[
       ConjClassSeparator[p], {p[[1]], 
        conjugacyClassColor}, {p[[1]], {regularGridColor, Dashed}}]] /@ 
     indexed,
    Function[p, {p[[1]], conjugacyClassColor}] /@ 
     Select[indexed, ConjClassSeparator]
    ];
  
  (* Setting up markers with nice formatting of the permutations *)
  
  markers =  If[ticks,
    FormatCycle[c_] := 
     If[c == Cycles[{{}}], "( )", 
      StringReplace[
       StringJoin[ToString  /@ c[[1]]], {"{" -> "(", "}" -> ")", 
        "," -> ""}]];
    If[Length[permutationNames] > 0, 
     Function[
       x, {x[[1]], 
        FormatCycle[x[[2]]] <> "   " <> permutationNames[x[[2]]] } ] /@ 
      indexed,
     Function[x, {x[[1]], FormatCycle[x[[2]]]} ] /@ indexed
     ],
    Automatic
    ];(* Function[x, If[OddQ[First[x]], x, {x[[1]],""} ]] /@ 
  indexed;*)
  
  mx = ArrayReshape[Map[Function[ab,
      PermutationProduct[ab[[1]], ab[[2]]] == 
       PermutationProduct[ab[[2]], ab[[1]]]], Tuples[els, 2]], {n, n}];
  Return[
   MatrixPlot[mx, Mesh -> {tickers, tickers}, 
    ColorRules -> {True -> commutingColor, 
      False -> notCommutingColor}, 
    FrameTicks -> {markers, 
      Map[Function[v, {v[[1]], Rotate[v[[2]], 90 Degree]}], markers]}]]
  ](* end module*)
CommutatorPlot[QuaternionGroup, \
{"PermutationNames" -> quaternionPermutationNames}]
CommutatorPlot[PauliGroup, {"PermutationNames" -> 
   pauliGroupPermutationNames}]
CommutatorPlot[DihedralGroup[10]]
CommutatorPlot[SymmetricGroup[4]]
CommutatorPlot[CyclicGroup[4]]