SHARE
TWEET

Find group isomorphisms in Mathematica

lavery3 Jan 1st, 2015 (edited) 376 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[
  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], {_}]
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top