# Find group isomorphisms in Mathematica

Jan 1st, 2015
924
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
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[
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], {_}]