18

Li = Range[5]; TakeDrop[Li, #] & /@ Range[Length[Li]-1] // Column[Row/@#]& or, slightly shorter, i = 1; TakeDrop[Li, i++] & /@ Most[Li] // Column[Row/@#]& or, using just Range and organizing the result with Transpose: Transpose[{Range[Range[4]], Range[1 + Range[4], 5]}] // Column[Row/@#]& For an arbitrary list of size 5, say, lst ...


14

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


13

This is literally the canonical example from the ReplaceList documentation: ReplaceList[{a, b, c, d, e, f}, {x__, y__} -> {{x}, {y}}] {{{a}, {b, c, d, e, f}}, {{a, b}, {c, d, e, f}}, {{a, b, c}, {d, e, f}}, {{a, b, c, d}, {e, f}}, {{a, b, c, d, e}, {f}}}


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


11

mat = {Sort @ #, #} & @ PermutationList[a]; MatrixForm @ mat // TeXForm $ \left( \begin{array}{ccccccccccc} 1 & 2 & 3 & 4 & 5 & 6 & 7 & 8 & 9 & 10 & 11 \\ 9 & 11 & 7 & 8 & 10 & 2 & 1 & 5 & 3 & 4 & 6 \\ \end{array} \right)$


11

Be warned: this is a long answer, because I'm trying to be sufficiently general to treat basic graph colorings in Mathematica and maximally explanatory for anyone reading. tl;dr: Define graph colorings; create functions that identify generate colorings; then quotient the set of colorings by the graph automorphisms, by creating literal equivalence classes of ...


9

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


9

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

See: Hereman's "24 [symmetry-finding] software packages mainly for Mathematica (commercial software), some for Macsyma* (commercial software)." *Maxima/wxMaxima are free versions. Gerd Baumann's Symmetry Analysis of Differential Equations with Mathematica® comes with some extra materials that include a Mathematica package called MathLie, freely ...


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

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


8

SYM is compatible with any version of Mathematica. My site writes up to 8 because that was the latest version at the time. I should update my site ... =) Please send me an email at spawn@math.upatras.gr and I will provide you with the up to date version of SYM. P.S. Mathematica v10+ have a bug related to the UnProtect command, thats why you might have ...


8

Li = Range[5]; groups = Table[GatherBy[Li, # <= n &], {n, 4}] (* {{{1}, {2, 3, 4, 5}}, {{1, 2}, {3, 4, 5}}, {{1, 2, 3}, {4, 5}}, {{1, 2, 3, 4}, {5}}} *) To display this as shown in your question Column[StringJoin /@ Map[ToString, groups, {2}]] EDIT: Or more generally, Li = {a, c, b, e, d}; groups = Table[ GatherBy[Li, Position[Li, #][[...


8

In physics and on Wikipedia, Wigner's sign convention is used; Mathematica uses a different sign convention. To define a Wigner D matrix that adheres to the Wigner/Wikipedia sign convention, you can use myWignerD[{j_, m1_, m2_}, α_, β_, ɣ_] = WignerD[{j, -m1, -m2}, α, β, ɣ]; As far as I can tell, this definition confirms the formulas given at https://en....


8

Summary There are 3 independent degrees of freedom for the tensor $A_{abcd}$ if it is invariant under Rayleigh transformation, and it also satisfied $A_{abcd}=A_{cdab}$. The independent components can be taken as $A_{2332},A_{3223},$ and $A_{3322}$. If we further require that $A_{abcd}=A_{bacd}$ (and/or $A_{abcd}=A_{abdc}$), the number of independent ...


8

I think some of the rotations must be corrected: rot1 = Cycles[{{1, 2, 4, 3}, {5, 24, 9, 7}, {6, 23, 10, 8}}]; rot2 = Cycles[{{21, 22, 24, 23}, {1, 11, 20, 10}, {2, 5, 19, 16}}]; rot3 = Cycles[{{11, 5, 6, 12}, {1, 7, 17, 21}, {3, 13, 19, 23}}]; rot4 = Cycles[{{7, 8, 14, 13}, {3, 9, 18, 12}, {4, 15, 17, 6}}]; rot5 = Cycles[{{10, 16, 15, 9}, {2, 22, 18, 8}, {...


7

For future searchers who come across this question, there is now a function FindGroupIsomorphism in the Wolfram Function Repository.


7

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


7

For simplicity, let's set ncm[a__] := NonCommutativeMultiply[a] My recommendation for this problem is to choose a "normal order" for the group elements. That is, I would choose to represent the group elements in such a way that all the a's are to the left of the b's. To do this, we define our set of replacements in such a way that b's always move ...


7

Update: I just noticed this comment: The constraint I have is: a node can not be in two subgraphs. This is contradictory with the rest of the problem description: need to find all possible connected subgraphs Next time please formulate the problem more precisely. You probably wanted FindGraphPartition[g, 12] (see METIS), but that is not finding all ...


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


6

Update: This seems fixed in the latest RPi version, 11.2.0. This is a bug specific to the Raspberry Pi (or rather ARM versions of Mathematica?). I reported it on February 21, 2016, and Wolfram Support told me that it is a known issue. A workaround is to use the IGraph/M package, which provides the same functionality and works fine on the Raspberry Pi. &...


6

I find the OP questions somewhat unclear. In any case, the answers can be found in the tutorials "Permutations" and "Permutation Groups". I would like to permute the elements of the set A using symmetric group. In[44]:= Permute[{1,2,3},SymmetricGroup[3]] Out[44]= {{1, 2, 3}, {1, 3, 2}, {2, 1, 3}, {2, 3, 1}, {3, 1, 2}, {3, 2, 1}} The Mathematica ...


6

One should really use commutator rather than Commutator for future-proofing concerns, but I have some bad habits... Clear[Commutator] (* Manually implement the algebra of interest: *) Commutator[L1, L2] = I L3; Commutator[L2, L1] = -I L3; Commutator[L2, L3] = I L1; Commutator[L3, L2] = -I L1; Commutator[L3, L1] = I L2; Commutator[L1, L3] = -I L2; (* ...


6

Let us consider the axioms for a group: groupTheory={ForAll[{a,b,c},g[a,g[b,c]]==g[g[a,b],c]], ForAll[a,g[a,e]==a], ForAll[a,g[a,inv[a]]==e]}; As shown in the question, Murray's command for proving that the right identity is unique: FindEquationalProof[Implies[ForAll[a, g[a, f]==a], e==f], groupTheory ] fails with a message that there is an invalid ...


6

One idea is to overload MatrixForm so that it does this for you automatically: Unprotect[MatrixForm]; MatrixForm /: MakeBoxes[MatrixForm[cyc_Cycles], StandardForm] := With[ {list=PermutationList[cyc]}, ToBoxes[MatrixForm[{Range@Length@list, list}], StandardForm] ] Protect[MatrixForm]; Then: Cycles[{{1, 9, 3, 7}, {2, 11, 6}, {4, 8, 5, 10}}] //...


6

Use GroupElementToWord. There are some examples in the documentation, especially in the Neat Examples section which mentions Rubik's cube. Below I express the permutation that takes {3,1,2,4} to {1,2,3,4} in terms of a 'word' or sequence of the group generators (and their inverses). perms = { Cycles[{{1, 3}, {2, 4}}], Cycles[{{1, 2}}], Cycles[{{3, 4}}],...


6

I think this does it by brute force. Not sure if there is a better way: matroidauts[M_] := Module[{n, symgp, i, goodguys, M2}, n = Max[Flatten[M]]; symgp = GroupElements[SymmetricGroup[n]]; goodguys = {}; M2 = Sort[Sort /@ M]; For[i = 1, i <= Length[symgp], i = i + 1, If[M2 == Sort[Sort /@ PermutationReplace[M2, symgp[[i]]]], AppendTo[goodguys, symgp[[i]]...


5

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


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