Hot answers tagged

15

MMA v.8 provides support for (finite) Group Theory, however this answer will not make use of that functionality. We shall use the ** (NonCommutativeMultiply) command present in MMA, which allows us to create semigroups quite easily. In a fresh MMA session: Unprotect[NonCommutativeMultiply]; GroupAction[g_, s_] := (g ** #) & /@ s 1 is the identity: ...


13

IntegerDigits works Try powers = IntegerDigits[204, 2] {1, 1, 0, 0, 1, 1, 0, 0} Now, if you want that formatted as a sum of powers of two, you have to hold it. For example Total@MapIndexed[#1 Defer[2]^(First@#2 - 1) &, Reverse@powers] 2^2 + 2^3 + 2^6 + 2^7 EDIT Nicer code, given that your numbers go up to 255 pow2[num_]:=Inner[#1 2^...


12

I am not sure this is what you need. Please see if it helps. The little cubes are clickable, but not rotatable. We could put nicely formatted edge labels as well, but I didn't want to do that now as it would slow it down even more. conf = solved; Dynamic@Graph[ Join[ (conf -> twist[#, conf] &) /@ basic, (twist[#, conf] -> conf &) /@...


12

Because the image of the group under this (linear) representation is infinite, we will need to limit the orbits. Working in the abstract group Presuming it may eventually be of interest to depict multiple orbits, let's compute a large number of group elements once and for all. It seems efficient to do this abstractly, in terms of the given presentation, ...


12

The Susyno and LieART Mathematica packages can do this. I know best the first one (I wrote it), so let me use it as an example in this answer. Assuming that you have installed and loaded the package in a Mathematica session, your example ($\mathbf{10}\times\mathbf{27}$ in $SU(3)$) is computed as follows: ReduceRepProduct[SU3, {{3, 0}, {2, 2}}] This ...


11

The group has 6048 elements. (Could it be isomorphic to $U_3(3)$?--see below.) count = 0; (matrices = NestWhile[(Print[count++]; Union[#~Join~Flatten[Outer[Dot, {gMatrix, hMatrix, kMatrix}, #, 1], 1]]) &, {IdentityMatrix[7]}, Length[#2] != Length[#1] &, 2, 99]) // Length // Timing $\{2.2, 6048\}$ This code ...


11

There is a simpler function instead of GCD that allows you to skip the comparison with 1: CoprimeQ. Using it, we can do this: Z[n_] := With[{i = Range[n]}, Pick[i, CoprimeQ[i, n]]] Z[21] (* ==> {1, 2, 4, 5, 8, 10, 11, 13, 16, 17, 19, 20} *) Here I deliberately tried to avoid any cryptic symbols (although perhaps that should be par for the course in a ...


9

Hi all please send me an mail at spawn@math.upatras.gr or visit my web site www.math.upatras.gr/~spawn, although the version on the site is not updated you can find an online version of the help files of the package. Many things have been added since my thesis. Among them, I have added command for the algebraic manipulation of the symmetries (Levi ...


9

The Wolfram Demonstration in its original version was wrong. The demo has since been corrected (updated March 2013). The first five functions called $H$ there (which were originally the only functions listed) do not form a group. You need a sixth element to make the set closed under multiplication! This can be checked by defining the six functions as ...


8

Here is a brute force method: cycles[el_] := Module[{f, edges = Rule @@@ el // Dispatch}, f[x_, b___, x_] := {{x, b, x}}; f[___, x_, ___, x_] = {}; f[c___, v_] := Join @@ (f[c, v, #] & /@ ReplaceList[v, edges]); Join @@ f /@ Union @@ el ] In the code above the line f[___, x_, ___, x_] = {}; was used for clarity, but faster duplicate tests ...


8

Below is an implementation of Johnson's 1975 exhaustive algorithm (see PDF, AFAIK the fastest exhaustive algorithm), improved upon the rather procedural version of Daniel Skates (see Mathematica demonstration). A hand-crafted C-version of the code is also available (if you mail me), which adds a further tenfold increase of speed compared to the Mathematica ...


8

Additional methods using WeightedData, EmpiricalDistribution, GatherBy and SparseArray: {weights,classes} = weightsPerclass = {{1, 0.2, .3, .4, .1, .3, .9, 0}, {1, 2, 3, 1, 3, 1, 1, 5}}; WeightedData wd = WeightedData[classes, weights]; The property "EmpiricalPDF" almost gives what we need wd["EmpiricalPDF"] (* {{1,2,3,5},{0.8125,0.0625,0.125,0.}} *) ...


8

Use the PermutationOrder function: In[1]:= elt = Cycles[{{1, 2}, {3, 4, 5}}]; In[2]:= PermutationOrder[elt] Out[2]= 6 This is indeed the answer you expect, and the smallest power you can raise elt to and get the identity permutation. In[3]:= PermutationPower[elt, #] & /@ Range[6] Out[3]= {Cycles[{{1, 2}, {3, 4, 5}}], Cycles[{{3, 5, 4}}], Cycles[{{1, ...


7

You were almost there. Just add the following to your code: iC3v = Inverse /@ C3v; sa = SolveAlways[Flatten@ Table[basis[[i]][iC3v[[k]].{x, y}] == Sum[basis[[j]][{x, y}] d[k, j, i], {j, 3}], {i, 3}, {k, 6}], {x, y}]; MatrixForm /@ Table[d[k, i, j], {k, 6}, {i, 3}, {j, 3}] /. sa And you get your expected result: $\left( \begin{...


7

tl;dr: The cycles of group1 and group2 should not involve the same values. The simplest way to obtain a direct product is to use the function FiniteGroupData with the syntax FiniteGroupData[ { "DirectProduct", { $group_1$, $group_2$, ...} }, "PermutationGroupRepresentation"] From the examples The issue can be found by noticing ...


6

This isn't directly an answer, and I'll delete it if it is off target. But you might want to use some non-System` context functionality for taking polynomial-mod-2 products. Specifically this works with integer lists of coefficients. I'll show an example below. In[1110]:= SeedRandom[1111]; vals = RandomInteger[2^8 - 1, 2] intlists = Map[Reverse[...


6

The multiplication table is itself a list of permutations of a representation of the group so you can do In[1]:= m = {{1, 2, 3, 4}, {2, 3, 4, 1}, {3, 4, 1, 2}, {4, 1, 2, 3}}; In[2]:= G = PermutationGroup[m]; Now you can compute group properties as usual: In[3]:= GroupOrder[G] Out[3]= 4 In this case the permutation representation obtained is exactly ...


6

This works for 16 elements too: list0 = Range[4]; sep = 2; (* separation of exchangeable elements *) exchangeable = Select[Subsets[list0, {2}], Abs[Subtract @@ #] == sep &] (* {{1, 3}, {2, 4}} *) group = PermutationGroup[Cycles[{#}] & /@ exchangeable] (* PermutationGroup[{Cycles[{{1, 3}}], Cycles[{{2, 4}}]}] *) elements = GroupElements[group] (...


5

The SYM package was developed by Stylianos Dimas and may be found in Appendix A of his thesis at http://nemertes.lis.upatras.gr/jspui/bitstream/10889/1697/1/thesis.pdf


5

FWIW, here's a slightly shortened re-implementation of standardize[]: standardize[a_] := Module[{atemp = a, beta, gamma = 2}, Do[ beta = atemp[[alpha, x]]; If[beta >= gamma, If[beta > gamma, atemp[[{gamma, beta}]] = atemp[[{beta, gamma}]]; atemp = (atemp /. {beta -> gamma, gamma -> beta})]; gamma++], {alpha, 4}, {x, 4}];...


5

If you make standardize have attribute HoldFirst, your code works as is: ClearAll[standardize]; SetAttributes[standardize, HoldFirst]; standardize[a_] := Module[{alpha, beta, gamma, x}, gamma = 2; For[alpha = 1, alpha <= 4, alpha++, For[x = 1, x <= 4, x++, beta = a[[alpha, x]]; If[beta >= gamma, If[beta > gamma, a[[{gamma, beta}]] = ...


5

A brute-force approach would be to define the set of matrices and form all products of them: FixedPoint[Union[#, Dot @@@ Tuples[#, 2]] &, set] The Union sorts the entries so that duplicates are eliminated. The length of the resulting list is the order of the group. Edit to explain the code In the command FixedPoint, the first argument is a function ...


5

All right, here is a solution: Find group isomorphisms in Mathematica. It's not pretty, but it's practical for groups of order up to about 100. It takes 30 ms to find out that $\text{d8a}\cong\text{d8b}$, and 43 ms to produce the automorphism group on my Mac mini. It finds an isomorphism from $S_5\to S_5$ (order 120) in 7 s. Producing all of $Aut(S_5)$ takes ...


5

I prefer Jens' solution but here is another simple formation: z1[n_] := Select[Range[n], CoprimeQ[#, n] &] And one for just for fun: z2[n_] := Join @@ Position[Range[n]/n, _[_, n]]


5

You have defined the elements of group and could approach as follows: r[a_] = RotationMatrix[a Degree]; rot = {r90, r180, r270} = r /@ Range[90, 270, 90] ref = {rh, rv, d1, d2} = ReflectionMatrix[#] & /@ {{1, 0}, {0, 1}, {1, 1}, {-1, 1}}; tab = {IdentityMatrix[2]}~Join~rot~Join~ref; rules = {IdentityMatrix[2] -> "\!\(\*SubscriptBox[\(R\), \(0\)]\)...


5

The following is a hacky way of doing it for finite groups only: quotientGroup[g_, h_] := RightCosetRepresentative[h, #] & /@ GroupElements[g] // DeleteDuplicates


5

Extending Patrick Stevens answer and modifying it somewhat. As an example, I'll use the Quaternions {1, -1, i, -i, j, -j, k, -k} (per our discussion in the comments to his answer) and factor by the normal subgroup {-1, 1}. Warning: if the groups are too big, the following calculations will probably take too much time. To extract a permutation-group ...


5

Making an answer from my comment. Notation list = Level[Table[Table[{i, j}, {i, j + 1, 4}], {j, 1, 3}], {2}] (* {{2, 1}, {3, 1}, {4, 1}, {3, 2}, {4, 2}, {4, 3}} *) Proposition PermutationReplace[list, Cycles[{{1, 2}, {3, 4}}]] (* {{1, 2}, {4, 2}, {3, 2}, {4, 1}, {3, 1}, {3, 4}} *)


4

Here's a simple suggestion: define a function that expands commutators by applying the Leibnitz rule to each argument individually and using the distributive property of the ** operation. Since we can't apply commutativity, I have to spell out rules for different orders of factors. Then I apply the function to an example. cExpand[ expr_] := (expr //. { ...


4

The help page of GroupElementToWord shows that it has a Method option. The documentation for that option says that "GroupElementToWord uses the Minkwitz algorithm, with a number of parameters", and shows some examples on how changing those parameters can result in shorter words in the generators. The Minkwitz algorithm (Torsten Minkwitz, 1998) is based on ...



Only top voted, non community-wiki answers of a minimum length are eligible