Advertisement
lavery3

Find group isomorphisms in Mathematica

Jan 1st, 2015
1,082
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.66 KB | None | 0 0
  1. findGroupIsomorphisms[
  2. group1_,
  3. group2_,
  4. max_: \[Infinity]
  5. ] :=
  6. Module[{ng1, ng2, reverse, g1, g2, order, gs1, go1, gm1, gm2,
  7. os1, os2, inng1, abelianQ, targets, isomorphisms, w1,
  8. mt1, \[CurlyPhi]m1, \[CurlyPhi], homomorphismQ, t, ts},
  9. (*
  10. * Choose the domain group with fewest generators
  11. *)
  12. If[GroupOrder[group1] != GroupOrder[group2],
  13. Return[{}];
  14. ];
  15. {ng1, ng2} = Length[GroupGenerators[#]] & /@ {group1, group2};
  16. reverse = ng2 < ng1;
  17. If[reverse,
  18. {g1, g2} = {group2, group1};
  19. {ng1, ng2} = {ng2, ng1},
  20. {g1, g2} = {group1, group2}
  21. ];
  22. (*
  23. * Do some quick checks for isomorphism
  24. *)
  25. order = GroupOrder[g1];
  26. {gm1, gm2} = GroupElements /@ {g1, g2};
  27. {os1, os2} = Map[PermutationOrder, {gm1, gm2}, {2}];
  28. If[Sort[Tally[os1]] != Sort[Tally[os2]],
  29. Return[{}]
  30. ];
  31. (*
  32. * Pick possible targets in g2
  33. *)
  34. gs1 = GroupGenerators[g1];
  35. go1 = PermutationOrder /@ gs1;
  36. targets = Table[
  37. Pick[gm2, Thread[os2 == n]],
  38. {n, go1}
  39. ];
  40. targets = Tuples[targets];
  41. (*
  42. * List the inner automorphisms
  43. *)
  44. inng1 = Outer[
  45. GroupElementPosition[
  46. g1, #1\[PermutationProduct]#2\[PermutationProduct]\
  47. InversePermutation[#1]] &,
  48. gm1, gs1
  49. ];
  50. inng1 = Union[inng1];
  51. abelianQ = Length[inng1] == 1;
  52. (*
  53. *
  54. Here I should do something much more efficient for abelian groups...
  55. \
  56. *)
  57. (* Stub *)
  58. (*
  59. *
  60. Test every possible mapping of the generators
  61. *)
  62. w1 = GroupElementToWord[g1, #] & /@ gm1;
  63. mt1 = GroupMultiplicationTable[g1];
  64. isomorphisms = {};
  65. While[targets =!= {},
  66. t = targets[[-1]]; targets = Drop[targets, -1];
  67. \[CurlyPhi] = With[{t = t},
  68. Function[i, GroupElementFromWord[PermutationGroup[t], w1[[i]]]]
  69. ];
  70. ts = Map[\[CurlyPhi], inng1, {2}];
  71. targets = Complement[targets, ts];
  72. If[GroupOrder[PermutationGroup[t]] != order,
  73. Continue[]
  74. ];
  75. \[CurlyPhi]m1 =
  76. GroupElementFromWord[PermutationGroup[t], #] & /@ w1;
  77. homomorphismQ =
  78. Map[\[CurlyPhi], mt1, {2}] ==
  79. Outer[PermutationProduct, \[CurlyPhi]m1, \[CurlyPhi]m1];
  80. If[homomorphismQ,
  81. (*
  82. * We found some isomorphisms!
  83. *)
  84. isomorphisms = Join[isomorphisms, ts]
  85. ];
  86. If[Length[isomorphisms] >= max,
  87. Break[]
  88. ]
  89. ];
  90. (*
  91. * Return the isomorphisms as rule lists
  92. *)
  93. isomorphisms =
  94. Take[isomorphisms, Min[max, Length[isomorphisms]]];
  95. isomorphisms = {gs1, #} & /@ isomorphisms;
  96. If[reverse, isomorphisms = Reverse /@ isomorphisms];
  97. Apply[Rule, Transpose /@ isomorphisms, {2}]
  98. ]
  99.  
  100.  
  101. isomorphicGroupsQ[group1_, group2_] :=
  102. MatchQ[findGroupIsomorphisms[group1, group2, 1], {_}]
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement