# Tag Info

12

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 ...

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, ...

11

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: ...

10

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 &) ...

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 ...

9

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 ...

8

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 ...

8

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( ... 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 ... 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 = ... 6 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.}} *) ... 5 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 ... 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, ... 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}]] = ... 4 One approach, born out of curiosity more than anything, is to take the determinant, extract the permutations from the indices, and then cycle decompose. I don't think this is a very efficient method as Det is slow, but it seems to work. To cycle decompose, I use combinatoricatocycles[] with Mathematica 7 (see here), rather than the new Mathematica 8 ... 4 Mostly I cribbed this from here. I simply changed the line that converts input to the particular sparse representation used by the main part of the code. Important caveat: I do not know for a fact that this code is correct for the directed case. extendCycle[cyc_List, edges_List] := Map[If[# > First[cyc] && ! MemberQ[cyc, #], Append[cyc, #], ... 4 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 4 Many ways to do this. w = {{1, 0.2, .3, .4, .1, .3, .9, 0}, {1, 2, 3, 1, 3, 1, 1, 5}}; class = Union[w[[2]]]; Map[Total, Cases[Transpose[w], {x_, y_} /; y == # :> x] & /@ class]; {class, %} 3 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 ... 3 Not very elegant and it requires additional work on the rules : elem = {1, a, b} rules = {a^3 -> 1, a^4 -> a, b^2 -> 1, b^3 -> b, b a^2 -> a b, b^4 -> 1} bigG = Union[Times @@ # & /@ Tuples[elem, {2}]] bigS = Subsets[bigG, {3}] TableView[ Outer[Sort[#1 #2 //. rules] &, bigG, bigS, 1, 1], TableHeadings -> {bigG, bigS} ] ... 3 Let's define your function and my proposal: f1[l_, gr_] := Length@DeleteDuplicates@Permute[l, gr@Length@l] f2[l_, gr_] := GroupOrder@gr@Length@l / GroupOrder@GroupSetwiseStabilizer[gr@Length@l, {l}, Permute] f2 isn't always faster than f1,but can calculate things where f1 fails due to memory constraints. For example: Timing@f1[{a, a, a, a, ... 3 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 ... 3 Define the sum-of-characters expansion expan[j_] /; j >= 0 && IntegerQ[2 j + 1] := Sum[n[jL, jR] Sum[(q t)^iL, {iL, -jL, jL}] Sum[(q/t)^iR, {iR, -jR, jR}], {jL, 0, j, 1/2}, {jR, 0, j, 1/2}]; where j is the maximum spin that you want to use. Define a known expansion to demonstrate how the coefficients in expan[j] can be obtained. expr = 4 ... 3 Using Reap and Sow: Transpose[ Last@Reap[ MapThread[Sow, weightsPerclass], _, {#1, Total@#2} &]] {{1, 2, 3, 5}, {2.6, 0.2, 0.4, 0}} 3 If you have Association functionality there is a rather nice approach using Merge: w = {{1, 0.2, .3, .4, .1, .3, .9, 0}, {1, 2, 3, 1, 3, 1, 1, 5}}; Thread[#2 -> # & @@ w] ~Merge~ Total <|1 -> 2.6, 2 -> 0.2, 3 -> 0.4, 5 -> 0|> The output is itself an association. It may be desirable to keep the format. If not: List @@@ ... 2 Step for step: data = {{1, 0.2, .3, .4, .1, .3, .9, 0}, {1, 2, 3, 1, 3, 1, 1, 5}}; mult = data[[1]] * data[[2]] {1, 0.4, 0.9, 0.4, 0.3, 0.3, 0.9, 0} union = Union @ data[[2]] {1, 2, 3, 5} pos = Flatten /@ Map[Position[data[[2]], #] &, union] {{1, 4, 6, 7}, {2}, {3, 5}, {8}} total = Total /@ Map[mult[[pos[[#]]]] &, Range @ ... 2 PG = PermutationGroup[{Cycles[{{1, 3}, {2, 4}}], Cycles[{{1, 5}, {4, 6}}]}]; PermutationProduct @@ GroupElements @ PG Cycles[{{1, 5}, {4, 6}}] 2 I presume you mean the representation of the generators of su(2) (i.e. of the algebra) rather than a presentation of the group. Representations of the SU(2) group in any dimension can be obtained from WignerD. Something like SU2repj = Table[ WignerD[{j, m1, m2}, a, b, c], {m1, j, -j, -1}, {m2, j, -j, -1} ] /. j -> 2 will generate the$5\times5\$ ...

2

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 //. { ...

2

Try this: In[1]:= Unprotect[PermutationProduct]; PermutationProduct[left___, sum_Plus, right___] := PermutationProduct[left, #, right] & /@ sum; PermutationProduct[left___, c_ perm_?PermutationCyclesQ, right___] := c PermutationProduct[left, perm, right]; PermutationProduct[left___, 0, right___] := 0; ...

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